hmatrix 0.16.0.6 → 0.20.2
raw patch · 62 files changed
Files
- CHANGELOG +50/−1
- THANKS.md +67/−4
- hmatrix.cabal +99/−65
- src/C/lapack-aux.c +0/−1489
- src/C/lapack-aux.h +0/−62
- src/C/vector-aux.c +0/−798
- src/Data/Packed.hs +0/−26
- src/Data/Packed/Development.hs +0/−32
- src/Data/Packed/Foreign.hs +0/−100
- src/Data/Packed/IO.hs +0/−167
- src/Data/Packed/Internal.hs +0/−24
- src/Data/Packed/Internal/Common.hs +0/−160
- src/Data/Packed/Internal/Matrix.hs +0/−423
- src/Data/Packed/Internal/Numeric.hs +0/−720
- src/Data/Packed/Internal/Signatures.hs +0/−70
- src/Data/Packed/Internal/Vector.hs +0/−471
- src/Data/Packed/Matrix.hs +0/−494
- src/Data/Packed/Numeric.hs +0/−299
- src/Data/Packed/ST.hs +0/−178
- src/Data/Packed/Vector.hs +0/−125
- src/Internal/Algorithms.hs +1164/−0
- src/Internal/C/lapack-aux.c +2014/−0
- src/Internal/C/lapack-aux.h +111/−0
- src/Internal/C/vector-aux.c +1599/−0
- src/Internal/CG.hs +188/−0
- src/Internal/Chain.hs +150/−0
- src/Internal/Container.hs +302/−0
- src/Internal/Conversion.hs +93/−0
- src/Internal/Convolution.hs +161/−0
- src/Internal/Devel.hs +108/−0
- src/Internal/Element.hs +617/−0
- src/Internal/IO.hs +183/−0
- src/Internal/LAPACK.hs +758/−0
- src/Internal/Matrix.hs +721/−0
- src/Internal/Modular.hs +476/−0
- src/Internal/Numeric.hs +945/−0
- src/Internal/Random.hs +81/−0
- src/Internal/ST.hs +257/−0
- src/Internal/Sparse.hs +277/−0
- src/Internal/Static.hs +588/−0
- src/Internal/Util.hs +914/−0
- src/Internal/Vector.hs +468/−0
- src/Internal/Vectorized.hs +557/−0
- src/Numeric/Chain.hs +0/−144
- src/Numeric/Container.hs +0/−49
- src/Numeric/Conversion.hs +0/−91
- src/Numeric/LinearAlgebra.hs +256/−9
- src/Numeric/LinearAlgebra/Algorithms.hs +0/−961
- src/Numeric/LinearAlgebra/Data.hs +71/−33
- src/Numeric/LinearAlgebra/Devel.hs +21/−19
- src/Numeric/LinearAlgebra/HMatrix.hs +20/−219
- src/Numeric/LinearAlgebra/LAPACK.hs +0/−560
- src/Numeric/LinearAlgebra/Random.hs +0/−81
- src/Numeric/LinearAlgebra/Static.hs +346/−71
- src/Numeric/LinearAlgebra/Static/Internal.hs +0/−521
- src/Numeric/LinearAlgebra/Util.hs +0/−477
- src/Numeric/LinearAlgebra/Util/CG.hs +0/−171
- src/Numeric/LinearAlgebra/Util/Convolution.hs +0/−149
- src/Numeric/Matrix.hs +27/−7
- src/Numeric/Sparse.hs +0/−210
- src/Numeric/Vector.hs +33/−6
- src/Numeric/Vectorized.hs +0/−365
CHANGELOG view
@@ -1,3 +1,53 @@+0.18.0.0+--------++ * Many new functions and instances in the Static module++ * meanCov and gaussianSample use Herm type++ * thinQR, thinRQ++ * compactSVDTol++ * unitary changed to normalize, also admits Vector (Complex Double)++0.17.0.0+--------++ * eigSH, chol, and other functions that work with Hermitian or symmetric matrices+ now take a special "Herm" argument that can be created by means of "sym"+ or "mTm". The unchecked versions of those functions have been removed and we+ use "trustSym" to create the Herm type when the matrix is known to be Hermitian/symmetric.++ * Improved matrix extraction (??) and rectangular matrix slices without data copy++ * Basic support of Int32 and Int64 elements++ * remap, more general cond, sortIndex++ * Experimental support of type safe modular arithmetic, including linear+ system solver and LU factorization++ * Elementary row operations and inplace matrix slice products in the ST monad++ * Improved development tools.++ * Old compatibility modules removed, simpler organization of internal modules++ * unitary, pairwiseD2, tr'++ * ldlPacked, ldlSolve for indefinite symmetric systems (apparently not faster+ than the general solver based on the LU)++ * LU, LDL, and QR types for these compact decompositions.++0.16.1.0+--------++ * Added (|||) and (===) for "besides" and "above"++ * rowOuters+ 0.16.0.0 -------- @@ -238,4 +288,3 @@ * added NFData instances for Matrix and Vector. * liftVector, liftVector2 replaced by mapVector, zipVector.-
THANKS.md view
@@ -92,7 +92,7 @@ - Carter Schonwald helped with the configuration for Homebrew OS X and found a tolerance problem in test "1E5 rots". He also discovered- a bug in the signature of cmap.+ a bug in the signature of cmap and fixed the cabal file. - Duncan Coutts reported a problem with configure.hs and contributed a solution and a simplified Setup.lhs.@@ -103,7 +103,7 @@ deprecation warnings, used more explicit imports, and updated to ghc-7.4. - Tom Nielsen discovered a problem in Config.hs, exposed by link problems- in Ubuntu 11.10 beta.+ in Ubuntu 11.10 beta, and fixed the link options on freebsd. - Daniel Fischer reported some Haddock markup errors. @@ -159,7 +159,8 @@ - Denis Laxalde separated the gsl tests from the base ones. -- Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions.+- Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and+ added Cholesky to Static. He also added support for tridiagonal matrix solver and fixed several bugs. - Dylan Thurston reported an error in the glpk documentation and ambiguity in the description of linearSolve.@@ -169,5 +170,67 @@ - Ian Ross reported the max/minIndex bug. -- Niklas Hambüchen improved the documentation.+- Niklas Hambüchen improved the documentation and fixed compilation with GHC-8.2+ adding type signatures. Added disable-default-paths flag.++- "erdeszt" optimized "conv" using a direct vector reverse.++- John Shahbazian added support for openBLAS.++- "yongqli" reported the bug in randomVector (rand() is not thread-safe and drand48_r() is not portable).++- Kiwamu Ishikura improved randomVector for OSX++- C.J. East fixed the examples for simplex.++- Ben Gamari contributed fixes for ghc 7.10++- Piotr Mardziel added general sparse constraints to simplex and the interface to glp_exact++- Maxim Baz fixed an instance declaration for ghc 7.11++- Thomas M. DuBuisson fixed a C include file.++- Matt Peddie wrote the interfaces to the interpolation and simulated annealing modules.++- "maxc01" solved uninstallability in FreeBSD, improved urandom, and fixed a Windows+ link error using rand_s.++- "ntfrgl" added {take,drop}Last{Rows,Columns} and odeSolveVWith with generalized step control function+ and fixed link errors related to mod/mod_l.++- "cruegge" discovered a bug in the conjugate gradient solver for sparse symmetric systems.++- Ilan Godik and Douglas McClean helped with Windows support.++- Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation+ issues, and added support for stack-based build. He also added support for LTS 8.15+ under Windows.++- Greg Nwosu fixed arm compilation++- Patrik Jansson changed meanCov and gaussianSample to use Herm type. Fixed stack.yaml.++- Justin Le added NFData instances for Static types, added mapping and outer product+ methods to Domain, and many other functions to the Static module.++- Sidharth Kapur added Normed and numeric instances for several Static types,+fixed the CPP issue in cabal files, and made many other contributions.++- Matt Renaud improved the documentation.++- Joshua Moerman fixed cabal/stack flags for windows.++- Francesco Mazzoli, Niklas Hambüchen, Patrick Chilton, and Andras Slemmer+ discovered a serious and subtle bug in the wrapper helpers causing memory corruption.+ Andras Slemmer fixed the bug. Thank you all.++- Kevin Slagle implemented thinQR and thinRQ, much faster than the original qr,+ and added compactSVDTol. He also added an optimized reorderVector for hTensor.++- "fedeinthemix" suggested a better name and a more general type for unitary.++- Huw Campbell fixed a bug in equal.++- Hiromi Ishii fixed compilation problems for ghc-8.4
hmatrix.cabal view
@@ -1,130 +1,164 @@ Name: hmatrix-Version: 0.16.0.6+Version: 0.20.2 License: BSD3 License-file: LICENSE Author: Alberto Ruiz-Maintainer: Alberto Ruiz+Maintainer: Dominic Steinitz Stability: provisional-Homepage: https://github.com/albertoruiz/hmatrix+Homepage: https://github.com/haskell-numerics/hmatrix Synopsis: Numeric Linear Algebra-Description: Linear algebra based on BLAS and LAPACK.- .- The package is organized as follows:- .- ["Numeric.LinearAlgebra.HMatrix"] Starting point and recommended import module for most applications.- .- ["Numeric.LinearAlgebra.Static"] Experimental alternative interface.+Description: Linear systems, matrix decompositions, and other numerical computations based on BLAS and LAPACK. .- ["Numeric.LinearAlgebra.Devel"] Tools for extending the library.+ Standard interface: "Numeric.LinearAlgebra". .- (Other modules are exposed with hidden documentation for backwards compatibility.)+ Safer interface with statically checked dimensions: "Numeric.LinearAlgebra.Static". . Code examples: <http://dis.um.es/~alberto/hmatrix/hmatrix.html> Category: Math-tested-with: GHC==7.8+tested-with: GHC==8.10 -cabal-version: >=1.8+cabal-version: >=1.18 build-type: Simple extra-source-files: THANKS.md CHANGELOG -extra-source-files: src/C/lapack-aux.h+extra-source-files: src/Internal/C/lapack-aux.h +flag openblas+ description: Link with OpenBLAS (https://github.com/xianyi/OpenBLAS) optimized libraries.+ default: False+ manual: True++flag disable-default-paths+ description: When enabled, don't add default hardcoded include/link dirs by default. Needed for hermetic builds like in nix.+ default: False+ manual: True++flag no-random_r+ description: When enabled, don't depend on the random_r() C function.+ default: False+ manual: True+ library - Build-Depends: base >= 4 && < 5,+ default-language: Haskell2010++ Build-Depends: base >= 4.8 && < 5, binary, array, deepseq, random, split, bytestring,+ primitive, storable-complex,- vector >= 0.8+ semigroups,+ vector >= 0.11 hs-source-dirs: src - exposed-modules: Data.Packed,- Data.Packed.Vector,- Data.Packed.Matrix,- Data.Packed.Foreign,- Data.Packed.ST,- Data.Packed.Development,-- Numeric.LinearAlgebra- Numeric.LinearAlgebra.LAPACK- Numeric.LinearAlgebra.Algorithms- Numeric.Container- Numeric.LinearAlgebra.Util-+ exposed-modules: Numeric.LinearAlgebra Numeric.LinearAlgebra.Devel Numeric.LinearAlgebra.Data Numeric.LinearAlgebra.HMatrix Numeric.LinearAlgebra.Static- -- other-modules: Data.Packed.Internal,- Data.Packed.Internal.Common- Data.Packed.Internal.Signatures- Data.Packed.Internal.Vector- Data.Packed.Internal.Matrix- Data.Packed.IO- Numeric.Chain- Numeric.Vectorized+ other-modules: Internal.Vector+ Internal.Devel+ Internal.Vectorized+ Internal.Matrix+ Internal.ST+ Internal.IO+ Internal.Element+ Internal.Conversion+ Internal.LAPACK+ Internal.Numeric+ Internal.Algorithms+ Internal.Random+ Internal.Container+ Internal.Sparse+ Internal.Convolution+ Internal.Chain Numeric.Vector+ Internal.CG Numeric.Matrix- Data.Packed.Internal.Numeric- Data.Packed.Numeric- Numeric.LinearAlgebra.Util.Convolution- Numeric.LinearAlgebra.Util.CG- Numeric.LinearAlgebra.Random- Numeric.Conversion- Numeric.Sparse- Numeric.LinearAlgebra.Static.Internal+ Internal.Util+ Internal.Modular+ Internal.Static - C-sources: src/C/lapack-aux.c- src/C/vector-aux.c+ C-sources: src/Internal/C/lapack-aux.c+ src/Internal/C/vector-aux.c - extensions: ForeignFunctionInterface,- CPP+ other-extensions: ForeignFunctionInterface ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans+ -fno-prof-auto - cc-options: -O4 -msse2 -Wall+ cc-options: -O4 -Wall - cpp-options: -DBINARY+ if arch(x86_64)+ cc-options: -msse2+ if arch(i386)+ cc-options: -msse2 - extra-libraries: blas lapack + if flag(no-random_r)+ cc-options: -DNO_RANDOM_R+ if os(OSX)- extra-lib-dirs: /opt/local/lib/- include-dirs: /opt/local/include/- extra-lib-dirs: /usr/local/lib/- include-dirs: /usr/local/include/+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /opt/local/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack++ if !flag(disable-default-paths)+ extra-lib-dirs: /opt/local/lib/+ include-dirs: /opt/local/include/+ extra-lib-dirs: /usr/local/lib/+ include-dirs: /usr/local/include/ if arch(i386) cc-options: -arch i386 frameworks: Accelerate if os(freebsd)- extra-lib-dirs: /usr/local/lib- include-dirs: /usr/local/include- extra-libraries: blas lapack+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /usr/local/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack + if !flag(disable-default-paths)+ extra-lib-dirs: /usr/local/lib+ include-dirs: /usr/local/include+ extra-libraries: gfortran+ extra-lib-dirs: /usr/local/lib/gcc9 /usr/local/lib/gcc8 /usr/local/lib/gcc7+ if os(windows)- extra-libraries: blas lapack+ if flag(openblas)+ extra-libraries: openblas+ else+ extra-libraries: blas lapack if os(linux)+ if flag(openblas)+ if !flag(disable-default-paths)+ extra-lib-dirs: /usr/lib/openblas/lib+ extra-libraries: openblas+ else+ extra-libraries: blas lapack+ if arch(x86_64) cc-options: -fPIC source-repository head type: git- location: https://github.com/albertoruiz/hmatrix-+ location: https://github.com/haskell-numerics/hmatrix
− src/C/lapack-aux.c
@@ -1,1489 +0,0 @@-#include <stdio.h>-#include <stdlib.h>-#include <string.h>-#include <math.h>-#include <time.h>-#include "lapack-aux.h"--#define MACRO(B) do {B} while (0)-#define ERROR(CODE) MACRO(return CODE;)-#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})--#define MIN(A,B) ((A)<(B)?(A):(B))-#define MAX(A,B) ((A)>(B)?(A):(B))--// #define DBGL--#ifdef DBGL-#define DEBUGMSG(M) printf("\nLAPACK "M"\n");-#else-#define DEBUGMSG(M)-#endif--#define OK return 0;--// #ifdef DBGL-// #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL);-// #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;);-// #else-// #define DEBUGMSG(M)-// #define OK return 0;-// #endif--#define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \- for(q=0;q<M##r*M##c;q++) printf("%.1f ",M##p[q]); printf("\n");}--#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)--#define BAD_SIZE 2000-#define BAD_CODE 2001-#define MEM 2002-#define BAD_FILE 2003-#define SINGULAR 2004-#define NOCONVER 2005-#define NODEFPOS 2006-#define NOSPRTD 2007--//----------------------------------------void asm_finit() {-#ifdef i386--// asm("finit");-- static unsigned char buf[108];- asm("FSAVE %0":"=m" (buf));-- #if FPUDEBUG- if(buf[8]!=255 || buf[9]!=255) { // print warning in red- printf("%c[;31mWarning: FPU TAG = %x %x\%c[0m\n",0x1B,buf[8],buf[9],0x1B);- }- #endif-- #if NANDEBUG- asm("FRSTOR %0":"=m" (buf));- #endif--#endif-}--//-----------------------------------------#if NANDEBUG--#define CHECKNANR(M,msg) \-{ int k; \-for(k=0; k<(M##r * M##c); k++) { \- if(M##p[k] != M##p[k]) { \- printf(msg); \- TRACEMAT(M) \- /*exit(1);*/ \- } \-} \-}--#define CHECKNANC(M,msg) \-{ int k; \-for(k=0; k<(M##r * M##c); k++) { \- if( M##p[k].r != M##p[k].r \- || M##p[k].i != M##p[k].i) { \- printf(msg); \- /*exit(1);*/ \- } \-} \-}--#else-#define CHECKNANC(M,msg)-#define CHECKNANR(M,msg)-#endif--//-----------------------------------------//////////////////// real svd ////////////////////////////////////--/* Subroutine */ int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,- doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *- ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,- integer *info);--int svd_l_R(KDMAT(a),DMAT(u), DVEC(s),DMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);- char* jobu = "A";- if (up==NULL) {- jobu = "N";- } else {- if (uc==q) {- jobu = "S";- }- }- REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);- char* jobvt = "A";- integer ldvt = n;- if (vp==NULL) {- jobvt = "N";- } else {- if (vr==q) {- jobvt = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_R");- double *B = (double*)malloc(m*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(double));- integer lwork = -1;- integer res;- // ask for optimal lwork- double ans;- dgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- &ans, &lwork,- &res);- lwork = ceil(ans);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- dgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- work, &lwork,- &res);- CHECK(res,res);- free(work);- free(B);- OK-}--// (alternative version)--/* Subroutine */ int dgesdd_(char *jobz, integer *m, integer *n, doublereal *- a, integer *lda, doublereal *s, doublereal *u, integer *ldu,- doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,- integer *iwork, integer *info);--int svd_l_Rdd(KDMAT(a),DMAT(u), DVEC(s),DMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES((up == NULL && vp == NULL)- || (ur==m && vc==n- && ((uc == q && vr == q)- || (uc == m && vc==n))),BAD_SIZE);- char* jobz = "A";- integer ldvt = n;- if (up==NULL) {- jobz = "N";- } else {- if (uc==q && vr == q) {- jobz = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_Rdd");- double *B = (double*)malloc(m*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(double));- integer* iwk = (integer*) malloc(8*q*sizeof(integer));- CHECK(!iwk,MEM);- integer lwk = -1;- integer res;- // ask for optimal lwk- double ans;- dgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,iwk,&res);- lwk = ans;- double * workv = (double*)malloc(lwk*sizeof(double));- CHECK(!workv,MEM);- dgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,workv,&lwk,iwk,&res);- CHECK(res,res);- free(iwk);- free(workv);- free(B);- OK-}--//////////////////// complex svd ////////////////////////////////////--// not in clapack.h--int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,- doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,- integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,- integer *lwork, doublereal *rwork, integer *info);--int svd_l_C(KCMAT(a),CMAT(u), DVEC(s),CMAT(v)) {- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);- char* jobu = "A";- if (up==NULL) {- jobu = "N";- } else {- if (uc==q) {- jobu = "S";- }- }- REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);- char* jobvt = "A";- integer ldvt = n;- if (vp==NULL) {- jobvt = "N";- } else {- if (vr==q) {- jobvt = "S";- ldvt = q;- }- }DEBUGMSG("svd_l_C");- doublecomplex *B = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(doublecomplex));-- double *rwork = (double*) malloc(5*q*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- integer res;- // ask for optimal lwork- doublecomplex ans;- zgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- zgesvd_ (jobu,jobvt,- &m,&n,B,&m,- sp,- up,&m,- vp,&ldvt,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- free(B);- OK-}--int zgesdd_ (char *jobz, integer *m, integer *n,- doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,- integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,- integer *lwork, doublereal *rwork, integer* iwork, integer *info);--int svd_l_Cdd(KCMAT(a),CMAT(u), DVEC(s),CMAT(v)) {- //printf("entro\n");- integer m = ar;- integer n = ac;- integer q = MIN(m,n);- REQUIRES(sn==q,BAD_SIZE);- REQUIRES((up == NULL && vp == NULL)- || (ur==m && vc==n- && ((uc == q && vr == q)- || (uc == m && vc==n))),BAD_SIZE);- char* jobz = "A";- integer ldvt = n;- if (up==NULL) {- jobz = "N";- } else {- if (uc==q && vr == q) {- jobz = "S";- ldvt = q;- }- }- DEBUGMSG("svd_l_Cdd");- doublecomplex *B = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,m*n*sizeof(doublecomplex));- integer* iwk = (integer*) malloc(8*q*sizeof(integer));- CHECK(!iwk,MEM);- int lrwk;- if (0 && *jobz == 'N') {- lrwk = 5*q; // does not work, crash at free below- } else {- lrwk = 5*q*q + 7*q;- }- double *rwk = (double*)malloc(lrwk*sizeof(double));;- CHECK(!rwk,MEM);- //printf("%s %ld %d\n",jobz,q,lrwk);- integer lwk = -1;- integer res;- // ask for optimal lwk- doublecomplex ans;- zgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,rwk,iwk,&res);- lwk = ans.r;- //printf("lwk = %ld\n",lwk);- doublecomplex * workv = (doublecomplex*)malloc(lwk*sizeof(doublecomplex));- CHECK(!workv,MEM);- zgesdd_ (jobz,&m,&n,B,&m,sp,up,&m,vp,&ldvt,workv,&lwk,rwk,iwk,&res);- //printf("res = %ld\n",res);- CHECK(res,res);- free(workv); // printf("freed workv\n");- free(rwk); // printf("freed rwk\n");- free(iwk); // printf("freed iwk\n");- free(B); // printf("freed B, salgo\n");- OK-}--//////////////////// general complex eigensystem ////////////--/* Subroutine */ int zgeev_(char *jobvl, char *jobvr, integer *n,- doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl,- integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work,- integer *lwork, doublereal *rwork, integer *info);--int eig_l_C(KCMAT(a), CMAT(u), CVEC(s),CMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);- char jobvl = up==NULL?'N':'V';- REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);- char jobvr = vp==NULL?'N':'V';- DEBUGMSG("eig_l_C");- doublecomplex *B = (doublecomplex*)malloc(n*n*sizeof(doublecomplex));- CHECK(!B,MEM);- memcpy(B,ap,n*n*sizeof(doublecomplex));- double *rwork = (double*) malloc(2*n*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- integer res;- // ask for optimal lwork- doublecomplex ans;- //printf("ask zgeev\n");- zgeev_ (&jobvl,&jobvr,- &n,B,&n,- sp,- up,&n,- vp,&n,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- //printf("zgeev\n");- zgeev_ (&jobvl,&jobvr,- &n,B,&n,- sp,- up,&n,- vp,&n,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- free(B);- OK-}----//////////////////// general real eigensystem ////////////--/* Subroutine */ int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *- a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,- integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,- integer *lwork, integer *info);--int eig_l_R(KDMAT(a),DMAT(u), CVEC(s),DMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);- char jobvl = up==NULL?'N':'V';- REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);- char jobvr = vp==NULL?'N':'V';- DEBUGMSG("eig_l_R");- double *B = (double*)malloc(n*n*sizeof(double));- CHECK(!B,MEM);- memcpy(B,ap,n*n*sizeof(double));- integer lwork = -1;- integer res;- // ask for optimal lwork- double ans;- //printf("ask dgeev\n");- dgeev_ (&jobvl,&jobvr,- &n,B,&n,- (double*)sp, (double*)sp+n,- up,&n,- vp,&n,- &ans, &lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- //printf("dgeev\n");- dgeev_ (&jobvl,&jobvr,- &n,B,&n,- (double*)sp, (double*)sp+n,- up,&n,- vp,&n,- work, &lwork,- &res);- CHECK(res,res);- free(work);- free(B);- OK-}---//////////////////// symmetric real eigensystem ////////////--/* Subroutine */ int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,- integer *lda, doublereal *w, doublereal *work, integer *lwork,- integer *info);--int eig_l_S(int wantV,KDMAT(a),DVEC(s),DMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(vr==n && vc==n, BAD_SIZE);- char jobz = wantV?'V':'N';- DEBUGMSG("eig_l_S");- memcpy(vp,ap,n*n*sizeof(double));- integer lwork = -1;- char uplo = 'U';- integer res;- // ask for optimal lwork- double ans;- //printf("ask dsyev\n");- dsyev_ (&jobz,&uplo,- &n,vp,&n,- sp,- &ans, &lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- CHECK(!work,MEM);- dsyev_ (&jobz,&uplo,- &n,vp,&n,- sp,- work, &lwork,- &res);- CHECK(res,res);- free(work);- OK-}--//////////////////// hermitian complex eigensystem ////////////--/* Subroutine */ int zheev_(char *jobz, char *uplo, integer *n, doublecomplex- *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,- doublereal *rwork, integer *info);--int eig_l_H(int wantV,KCMAT(a),DVEC(s),CMAT(v)) {- integer n = ar;- REQUIRES(ac==n && sn==n, BAD_SIZE);- REQUIRES(vr==n && vc==n, BAD_SIZE);- char jobz = wantV?'V':'N';- DEBUGMSG("eig_l_H");- memcpy(vp,ap,2*n*n*sizeof(double));- double *rwork = (double*) malloc((3*n-2)*sizeof(double));- CHECK(!rwork,MEM);- integer lwork = -1;- char uplo = 'U';- integer res;- // ask for optimal lwork- doublecomplex ans;- //printf("ask zheev\n");- zheev_ (&jobz,&uplo,- &n,vp,&n,- sp,- &ans, &lwork,- rwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!work,MEM);- zheev_ (&jobz,&uplo,- &n,vp,&n,- sp,- work, &lwork,- rwork,- &res);- CHECK(res,res);- free(work);- free(rwork);- OK-}--//////////////////// general real linear system ////////////--/* Subroutine */ int dgesv_(integer *n, integer *nrhs, doublereal *a, integer- *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);--int linearSolveR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("linearSolveR_l");- double*AC = (double*)malloc(n*n*sizeof(double));- memcpy(AC,ap,n*n*sizeof(double));- memcpy(xp,bp,n*nhrs*sizeof(double));- integer * ipiv = (integer*)malloc(n*sizeof(integer));- integer res;- dgesv_ (&n,&nhrs,- AC, &n,- ipiv,- xp, &n,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(ipiv);- free(AC);- OK-}--//////////////////// general complex linear system ////////////--/* Subroutine */ int zgesv_(integer *n, integer *nrhs, doublecomplex *a,- integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *- info);--int linearSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("linearSolveC_l");- doublecomplex*AC = (doublecomplex*)malloc(n*n*sizeof(doublecomplex));- memcpy(AC,ap,n*n*sizeof(doublecomplex));- memcpy(xp,bp,n*nhrs*sizeof(doublecomplex));- integer * ipiv = (integer*)malloc(n*sizeof(integer));- integer res;- zgesv_ (&n,&nhrs,- AC, &n,- ipiv,- xp, &n,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(ipiv);- free(AC);- OK-}--//////// symmetric positive definite real linear system using Cholesky ////////////--/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs,- doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *- info);--int cholSolveR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("cholSolveR_l");- memcpy(xp,bp,n*nhrs*sizeof(double));- integer res;- dpotrs_ ("U",- &n,&nhrs,- (double*)ap, &n,- xp, &n,- &res);- CHECK(res,res);- OK-}--//////// Hermitian positive definite real linear system using Cholesky ////////////--/* Subroutine */ int zpotrs_(char *uplo, integer *n, integer *nrhs,- doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,- integer *info);--int cholSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer n = ar;- integer nhrs = bc;- REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);- DEBUGMSG("cholSolveC_l");- memcpy(xp,bp,n*nhrs*sizeof(doublecomplex));- integer res;- zpotrs_ ("U",- &n,&nhrs,- (doublecomplex*)ap, &n,- xp, &n,- &res);- CHECK(res,res);- OK-}--//////////////////// least squares real linear system ////////////--/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *- nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,- doublereal *work, integer *lwork, integer *info);--int linearSolveLSR_l(KDMAT(a),KDMAT(b),DMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveLSR_l");- double*AC = (double*)malloc(m*n*sizeof(double));- memcpy(AC,ap,m*n*sizeof(double));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(double));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(double));- }- }- integer res;- integer lwork = -1;- double ans;- dgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- &ans,&lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- dgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- work,&lwork,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(work);- free(AC);- OK-}--//////////////////// least squares complex linear system ////////////--/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer *- nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,- doublecomplex *work, integer *lwork, integer *info);--int linearSolveLSC_l(KCMAT(a),KCMAT(b),CMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveLSC_l");- doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- memcpy(AC,ap,m*n*sizeof(doublecomplex));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(doublecomplex));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(doublecomplex));- }- }- integer res;- integer lwork = -1;- doublecomplex ans;- zgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- &ans,&lwork,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- zgels_ ("N",&m,&n,&nrhs,- AC,&m,- xp,&ldb,- work,&lwork,- &res);- if(res>0) {- return SINGULAR;- }- CHECK(res,res);- free(work);- free(AC);- OK-}--//////////////////// least squares real linear system using SVD ////////////--/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs,- doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *- s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,- integer *info);--int linearSolveSVDR_l(double rcond,KDMAT(a),KDMAT(b),DMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveSVDR_l");- double*AC = (double*)malloc(m*n*sizeof(double));- double*S = (double*)malloc(MIN(m,n)*sizeof(double));- memcpy(AC,ap,m*n*sizeof(double));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(double));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(double));- }- }- integer res;- integer lwork = -1;- integer rank;- double ans;- dgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- &ans,&lwork,- &res);- lwork = ceil(ans);- //printf("ans = %d\n",lwork);- double * work = (double*)malloc(lwork*sizeof(double));- dgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- work,&lwork,- &res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(work);- free(S);- free(AC);- OK-}--//////////////////// least squares complex linear system using SVD ////////////--// not in clapack.h--int zgelss_(integer *m, integer *n, integer *nhrs,- doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s,- doublereal *rcond, integer* rank,- doublecomplex *work, integer* lwork, doublereal* rwork,- integer *info);--int linearSolveSVDC_l(double rcond, KCMAT(a),KCMAT(b),CMAT(x)) {- integer m = ar;- integer n = ac;- integer nrhs = bc;- integer ldb = xr;- REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE);- DEBUGMSG("linearSolveSVDC_l");- doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex));- double*S = (double*)malloc(MIN(m,n)*sizeof(double));- double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double));- memcpy(AC,ap,m*n*sizeof(doublecomplex));- if (m>=n) {- memcpy(xp,bp,m*nrhs*sizeof(doublecomplex));- } else {- int k;- for(k = 0; k<nrhs; k++) {- memcpy(xp+ldb*k,bp+m*k,m*sizeof(doublecomplex));- }- }- integer res;- integer lwork = -1;- integer rank;- doublecomplex ans;- zgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- &ans,&lwork,- RWORK,- &res);- lwork = ceil(ans.r);- //printf("ans = %d\n",lwork);- doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- zgelss_ (&m,&n,&nrhs,- AC,&m,- xp,&ldb,- S,- &rcond,&rank,- work,&lwork,- RWORK,- &res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(work);- free(RWORK);- free(S);- free(AC);- OK-}--//////////////////// Cholesky factorization /////////////////////////--/* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a,- integer *lda, integer *info);--int chol_l_H(KCMAT(a),CMAT(l)) {- integer n = ar;- REQUIRES(n>=1 && ac == n && lr==n && lc==n,BAD_SIZE);- DEBUGMSG("chol_l_H");- memcpy(lp,ap,n*n*sizeof(doublecomplex));- char uplo = 'U';- integer res;- zpotrf_ (&uplo,&n,lp,&n,&res);- CHECK(res>0,NODEFPOS);- CHECK(res,res);- doublecomplex zero = {0.,0.};- int r,c;- for (r=0; r<lr-1; r++) {- for(c=r+1; c<lc; c++) {- lp[r*lc+c] = zero;- }- }- OK-}---/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer *- lda, integer *info);--int chol_l_S(KDMAT(a),DMAT(l)) {- integer n = ar;- REQUIRES(n>=1 && ac == n && lr==n && lc==n,BAD_SIZE);- DEBUGMSG("chol_l_S");- memcpy(lp,ap,n*n*sizeof(double));- char uplo = 'U';- integer res;- dpotrf_ (&uplo,&n,lp,&n,&res);- CHECK(res>0,NODEFPOS);- CHECK(res,res);- int r,c;- for (r=0; r<lr-1; r++) {- for(c=r+1; c<lc; c++) {- lp[r*lc+c] = 0.;- }- }- OK-}--//////////////////// QR factorization /////////////////////////--/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *- lda, doublereal *tau, doublereal *work, integer *info);--int qr_l_R(KDMAT(a), DVEC(tau), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE);- DEBUGMSG("qr_l_R");- double *WORK = (double*)malloc(n*sizeof(double));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(double));- integer res;- dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);- CHECK(res,res);- free(WORK);- OK-}--/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a,- integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);--int qr_l_C(KCMAT(a), CVEC(tau), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE);- DEBUGMSG("qr_l_C");- doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);- CHECK(res,res);- free(WORK);- OK-}--/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal *- a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,- integer *info);--int c_dorgqr(KDMAT(a), KDVEC(tau), DMAT(r)) {- integer m = ar;- integer n = MIN(ac,ar);- integer k = taun;- DEBUGMSG("c_dorgqr");- integer lwork = 8*n; // FIXME- double *WORK = (double*)malloc(lwork*sizeof(double));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*k*sizeof(double));- integer res;- dorgqr_ (&m,&n,&k,rp,&m,(double*)taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}--/* Subroutine */ int zungqr_(integer *m, integer *n, integer *k,- doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);--int c_zungqr(KCMAT(a), KCVEC(tau), CMAT(r)) {- integer m = ar;- integer n = MIN(ac,ar);- integer k = taun;- DEBUGMSG("z_ungqr");- integer lwork = 8*n; // FIXME- doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*k*sizeof(doublecomplex));- integer res;- zungqr_ (&m,&n,&k,rp,&m,(doublecomplex*)taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}---//////////////////// Hessenberg factorization /////////////////////////--/* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi,- doublereal *a, integer *lda, doublereal *tau, doublereal *work,- integer *lwork, integer *info);--int hess_l_R(KDMAT(a), DVEC(tau), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE);- DEBUGMSG("hess_l_R");- integer lwork = 5*n; // fixme- double *WORK = (double*)malloc(lwork*sizeof(double));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(double));- integer res;- integer one = 1;- dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}---/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi,- doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *- work, integer *lwork, integer *info);--int hess_l_C(KCMAT(a), CVEC(tau), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE);- DEBUGMSG("hess_l_C");- integer lwork = 5*n; // fixme- doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- CHECK(!WORK,MEM);- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- integer one = 1;- zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);- CHECK(res,res);- free(WORK);- OK-}--//////////////////// Schur factorization /////////////////////////--/* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n,- doublereal *a, integer *lda, integer *sdim, doublereal *wr,- doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,- integer *lwork, logical *bwork, integer *info);--int schur_l_R(KDMAT(a), DMAT(u), DMAT(s)) {- integer m = ar;- integer n = ac;- REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE);- DEBUGMSG("schur_l_R");- //int k;- //printf("---------------------------\n");- //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");- //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");- //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");- memcpy(sp,ap,n*n*sizeof(double));- integer lwork = 6*n; // fixme- double *WORK = (double*)malloc(lwork*sizeof(double));- double *WR = (double*)malloc(n*sizeof(double));- double *WI = (double*)malloc(n*sizeof(double));- // WR and WI not really required in this call- logical *BWORK = (logical*)malloc(n*sizeof(logical));- integer res;- integer sdim;- dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res);- //printf("%p: ",ap); for(k=0;k<n*n;k++) printf("%f ",ap[k]); printf("\n");- //printf("%p: ",up); for(k=0;k<n*n;k++) printf("%f ",up[k]); printf("\n");- //printf("%p: ",sp); for(k=0;k<n*n;k++) printf("%f ",sp[k]); printf("\n");- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(WR);- free(WI);- free(BWORK);- free(WORK);- OK-}---/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n,- doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,- doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,- doublereal *rwork, logical *bwork, integer *info);--int schur_l_C(KCMAT(a), CMAT(u), CMAT(s)) {- integer m = ar;- integer n = ac;- REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE);- DEBUGMSG("schur_l_C");- memcpy(sp,ap,n*n*sizeof(doublecomplex));- integer lwork = 6*n; // fixme- doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));- doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex));- // W not really required in this call- logical *BWORK = (logical*)malloc(n*sizeof(logical));- double *RWORK = (double*)malloc(n*sizeof(double));- integer res;- integer sdim;- zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W,- up,&n,- WORK,&lwork,RWORK,BWORK,&res);- if(res>0) {- return NOCONVER;- }- CHECK(res,res);- free(W);- free(BWORK);- free(WORK);- OK-}--//////////////////// LU factorization /////////////////////////--/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer *- lda, integer *ipiv, integer *info);--int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);- DEBUGMSG("lu_l_R");- integer* auxipiv = (integer*)malloc(mn*sizeof(integer));- memcpy(rp,ap,m*n*sizeof(double));- integer res;- dgetrf_ (&m,&n,rp,&m,auxipiv,&res);- if(res>0) {- res = 0; // fixme- }- CHECK(res,res);- int k;- for (k=0; k<mn; k++) {- ipivp[k] = auxipiv[k];- }- free(auxipiv);- OK-}---/* Subroutine */ int zgetrf_(integer *m, integer *n, doublecomplex *a,- integer *lda, integer *ipiv, integer *info);--int lu_l_C(KCMAT(a), DVEC(ipiv), CMAT(r)) {- integer m = ar;- integer n = ac;- integer mn = MIN(m,n);- REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);- DEBUGMSG("lu_l_C");- integer* auxipiv = (integer*)malloc(mn*sizeof(integer));- memcpy(rp,ap,m*n*sizeof(doublecomplex));- integer res;- zgetrf_ (&m,&n,rp,&m,auxipiv,&res);- if(res>0) {- res = 0; // fixme- }- CHECK(res,res);- int k;- for (k=0; k<mn; k++) {- ipivp[k] = auxipiv[k];- }- free(auxipiv);- OK-}---//////////////////// LU substitution /////////////////////////--/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs,- doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *- ldb, integer *info);--int luS_l_R(KDMAT(a), KDVEC(ipiv), KDMAT(b), DMAT(x)) {- integer m = ar;- integer n = ac;- integer mrhs = br;- integer nrhs = bc;-- REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);- integer* auxipiv = (integer*)malloc(n*sizeof(integer));- int k;- for (k=0; k<n; k++) {- auxipiv[k] = (integer)ipivp[k];- }- integer res;- memcpy(xp,bp,mrhs*nrhs*sizeof(double));- dgetrs_ ("N",&n,&nrhs,(/*no const (!?)*/ double*)ap,&m,auxipiv,xp,&mrhs,&res);- CHECK(res,res);- free(auxipiv);- OK-}---/* Subroutine */ int zgetrs_(char *trans, integer *n, integer *nrhs,- doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,- integer *ldb, integer *info);--int luS_l_C(KCMAT(a), KDVEC(ipiv), KCMAT(b), CMAT(x)) {- integer m = ar;- integer n = ac;- integer mrhs = br;- integer nrhs = bc;-- REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);- integer* auxipiv = (integer*)malloc(n*sizeof(integer));- int k;- for (k=0; k<n; k++) {- auxipiv[k] = (integer)ipivp[k];- }- integer res;- memcpy(xp,bp,mrhs*nrhs*sizeof(doublecomplex));- zgetrs_ ("N",&n,&nrhs,(doublecomplex*)ap,&m,auxipiv,xp,&mrhs,&res);- CHECK(res,res);- free(auxipiv);- OK-}--//////////////////// Matrix Product /////////////////////////--void dgemm_(char *, char *, integer *, integer *, integer *,- double *, const double *, integer *, const double *,- integer *, double *, double *, integer *);--int multiplyR(int ta, int tb, KDMAT(a),KDMAT(b),DMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("dgemm_");- CHECKNANR(a,"NaN multR Input\n")- CHECKNANR(b,"NaN multR Input\n")- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- double alpha = 1;- double beta = 0;- dgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);- CHECKNANR(r,"NaN multR Output\n")- OK-}--void zgemm_(char *, char *, integer *, integer *, integer *,- doublecomplex *, const doublecomplex *, integer *, const doublecomplex *,- integer *, doublecomplex *, doublecomplex *, integer *);--int multiplyC(int ta, int tb, KCMAT(a),KCMAT(b),CMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("zgemm_");- CHECKNANC(a,"NaN multC Input\n")- CHECKNANC(b,"NaN multC Input\n")- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- doublecomplex alpha = {1,0};- doublecomplex beta = {0,0};- zgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,- ap,&lda,- bp,&ldb,&beta,- rp,&ldc);- CHECKNANC(r,"NaN multC Output\n")- OK-}--void sgemm_(char *, char *, integer *, integer *, integer *,- float *, const float *, integer *, const float *,- integer *, float *, float *, integer *);--int multiplyF(int ta, int tb, KFMAT(a),KFMAT(b),FMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("sgemm_");- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- float alpha = 1;- float beta = 0;- sgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);- OK-}--void cgemm_(char *, char *, integer *, integer *, integer *,- complex *, const complex *, integer *, const complex *,- integer *, complex *, complex *, integer *);--int multiplyQ(int ta, int tb, KQMAT(a),KQMAT(b),QMAT(r)) {- //REQUIRES(ac==br && ar==rr && bc==rc,BAD_SIZE);- DEBUGMSG("cgemm_");- integer m = ta?ac:ar;- integer n = tb?br:bc;- integer k = ta?ar:ac;- integer lda = ar;- integer ldb = br;- integer ldc = rr;- complex alpha = {1,0};- complex beta = {0,0};- cgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,- ap,&lda,- bp,&ldb,&beta,- rp,&ldc);- OK-}--//////////////////// transpose /////////////////////////--int transF(KFMAT(x),FMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transF");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transR(KDMAT(x),DMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transR");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transQ(KQMAT(x),QMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transQ");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transC(KCMAT(x),CMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- DEBUGMSG("transC");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- tp[i*tc+j] = xp[j*xc+i];- }- }- OK-}--int transP(KPMAT(x), PMAT(t)) {- REQUIRES(xr==tc && xc==tr,BAD_SIZE);- REQUIRES(xs==ts,NOCONVER);- DEBUGMSG("transP");- int i,j;- for (i=0; i<tr; i++) {- for (j=0; j<tc; j++) {- memcpy(tp+(i*tc+j)*xs,xp +(j*xc+i)*xs,xs);- }- }- OK-}--//////////////////// constant /////////////////////////--int constantF(float * pval, FVEC(r)) {- DEBUGMSG("constantF")- int k;- double val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantR(double * pval, DVEC(r)) {- DEBUGMSG("constantR")- int k;- double val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantQ(complex* pval, QVEC(r)) {- DEBUGMSG("constantQ")- int k;- complex val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantC(doublecomplex* pval, CVEC(r)) {- DEBUGMSG("constantC")- int k;- doublecomplex val = *pval;- for(k=0;k<rn;k++) {- rp[k]=val;- }- OK-}--int constantP(void* pval, PVEC(r)) {- DEBUGMSG("constantP")- int k;- for(k=0;k<rn;k++) {- memcpy(rp+k*rs,pval,rs);- }- OK-}--//////////////////// float-double conversion /////////////////////////--int float2double(FVEC(x),DVEC(y)) {- DEBUGMSG("float2double")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k];- }- OK-}--int double2float(DVEC(x),FVEC(y)) {- DEBUGMSG("double2float")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k];- }- OK-}--//////////////////// conjugate /////////////////////////--int conjugateQ(KQVEC(x),QVEC(t)) {- REQUIRES(xn==tn,BAD_SIZE);- DEBUGMSG("conjugateQ");- int k;- for(k=0;k<xn;k++) {- tp[k].r = xp[k].r;- tp[k].i = -xp[k].i;- }- OK-}--int conjugateC(KCVEC(x),CVEC(t)) {- REQUIRES(xn==tn,BAD_SIZE);- DEBUGMSG("conjugateC");- int k;- for(k=0;k<xn;k++) {- tp[k].r = xp[k].r;- tp[k].i = -xp[k].i;- }- OK-}--//////////////////// step /////////////////////////--int stepF(FVEC(x),FVEC(y)) {- DEBUGMSG("stepF")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k]>0;- }- OK-}--int stepD(DVEC(x),DVEC(y)) {- DEBUGMSG("stepD")- int k;- for(k=0;k<xn;k++) {- yp[k]=xp[k]>0;- }- OK-}--//////////////////// cond /////////////////////////--int condF(FVEC(x),FVEC(y),FVEC(lt),FVEC(eq),FVEC(gt),FVEC(r)) {- REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE);- DEBUGMSG("condF")- int k;- for(k=0;k<xn;k++) {- rp[k] = xp[k]<yp[k]?ltp[k]:(xp[k]>yp[k]?gtp[k]:eqp[k]);- }- OK-}--int condD(DVEC(x),DVEC(y),DVEC(lt),DVEC(eq),DVEC(gt),DVEC(r)) {- REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE);- DEBUGMSG("condD")- int k;- for(k=0;k<xn;k++) {- rp[k] = xp[k]<yp[k]?ltp[k]:(xp[k]>yp[k]?gtp[k]:eqp[k]);- }- OK-}-
− src/C/lapack-aux.h
@@ -1,62 +0,0 @@-/*- * We have copied the definitions in f2c.h required- * to compile clapack.h, modified to support both- * 32 and 64 bit-- http://opengrok.creo.hu/dragonfly/xref/src/contrib/gcc-3.4/libf2c/readme.netlib- http://www.ibm.com/developerworks/library/l-port64.html- */--#ifdef _LP64-typedef int integer;-typedef unsigned int uinteger;-typedef int logical;-typedef long longint; /* system-dependent */-typedef unsigned long ulongint; /* system-dependent */-#else-typedef long int integer;-typedef unsigned long int uinteger;-typedef long int logical;-typedef long long longint; /* system-dependent */-typedef unsigned long long ulongint; /* system-dependent */-#endif--typedef char *address;-typedef short int shortint;-typedef float real;-typedef double doublereal;-typedef struct { real r, i; } complex;-typedef struct { doublereal r, i; } doublecomplex;-typedef short int shortlogical;-typedef char logical1;-typedef char integer1;--typedef logical (*L_fp)();-typedef short ftnlen;--/********************************************************/--#define IVEC(A) int A##n, int*A##p-#define FVEC(A) int A##n, float*A##p-#define DVEC(A) int A##n, double*A##p-#define QVEC(A) int A##n, complex*A##p-#define CVEC(A) int A##n, doublecomplex*A##p-#define PVEC(A) int A##n, void* A##p, int A##s-#define FMAT(A) int A##r, int A##c, float* A##p-#define DMAT(A) int A##r, int A##c, double* A##p-#define QMAT(A) int A##r, int A##c, complex* A##p-#define CMAT(A) int A##r, int A##c, doublecomplex* A##p-#define PMAT(A) int A##r, int A##c, void* A##p, int A##s--#define KIVEC(A) int A##n, const int*A##p-#define KFVEC(A) int A##n, const float*A##p-#define KDVEC(A) int A##n, const double*A##p-#define KQVEC(A) int A##n, const complex*A##p-#define KCVEC(A) int A##n, const doublecomplex*A##p-#define KPVEC(A) int A##n, const void* A##p, int A##s-#define KFMAT(A) int A##r, int A##c, const float* A##p-#define KDMAT(A) int A##r, int A##c, const double* A##p-#define KQMAT(A) int A##r, int A##c, const complex* A##p-#define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p-#define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s-
− src/C/vector-aux.c
@@ -1,798 +0,0 @@-#include <complex.h>--typedef double complex TCD;-typedef float complex TCF;--#undef complex--#include "lapack-aux.h"--#define V(x) x##n,x##p--#include <string.h>-#include <math.h>-#include <stdio.h>-#include <stdlib.h>--#define MACRO(B) do {B} while (0)-#define ERROR(CODE) MACRO(return CODE;)-#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})-#define OK return 0;--#define MIN(A,B) ((A)<(B)?(A):(B))-#define MAX(A,B) ((A)>(B)?(A):(B))--#ifdef DBG-#define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M);-#else-#define DEBUGMSG(M)-#endif--#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)--#define BAD_SIZE 2000-#define BAD_CODE 2001-#define MEM 2002-#define BAD_FILE 2003---int sumF(KFVEC(x),FVEC(r)) {- DEBUGMSG("sumF");- REQUIRES(rn==1,BAD_SIZE);- int i;- float res = 0;- for (i = 0; i < xn; i++) res += xp[i];- rp[0] = res;- OK-}- -int sumR(KDVEC(x),DVEC(r)) {- DEBUGMSG("sumR");- REQUIRES(rn==1,BAD_SIZE);- int i;- double res = 0;- for (i = 0; i < xn; i++) res += xp[i];- rp[0] = res;- OK-}---int sumQ(KQVEC(x),QVEC(r)) {- DEBUGMSG("sumQ");- REQUIRES(rn==1,BAD_SIZE);- int i;- complex res;- res.r = 0;- res.i = 0;- for (i = 0; i < xn; i++) {- res.r += xp[i].r;- res.i += xp[i].i;- }- rp[0] = res;- OK-}- -int sumC(KCVEC(x),CVEC(r)) {- DEBUGMSG("sumC");- REQUIRES(rn==1,BAD_SIZE);- int i;- doublecomplex res;- res.r = 0;- res.i = 0;- for (i = 0; i < xn; i++) {- res.r += xp[i].r;- res.i += xp[i].i;- }- rp[0] = res;- OK-}---int prodF(KFVEC(x),FVEC(r)) {- DEBUGMSG("prodF");- REQUIRES(rn==1,BAD_SIZE);- int i;- float res = 1;- for (i = 0; i < xn; i++) res *= xp[i];- rp[0] = res;- OK-}- -int prodR(KDVEC(x),DVEC(r)) {- DEBUGMSG("prodR");- REQUIRES(rn==1,BAD_SIZE);- int i;- double res = 1;- for (i = 0; i < xn; i++) res *= xp[i];- rp[0] = res;- OK-}---int prodQ(KQVEC(x),QVEC(r)) {- DEBUGMSG("prodQ");- REQUIRES(rn==1,BAD_SIZE);- int i;- complex res;- float temp;- res.r = 1;- res.i = 0;- for (i = 0; i < xn; i++) {- temp = res.r * xp[i].r - res.i * xp[i].i;- res.i = res.r * xp[i].i + res.i * xp[i].r;- res.r = temp;- }- rp[0] = res;- OK-}- -int prodC(KCVEC(x),CVEC(r)) {- DEBUGMSG("prodC");- REQUIRES(rn==1,BAD_SIZE);- int i;- doublecomplex res;- double temp;- res.r = 1;- res.i = 0;- for (i = 0; i < xn; i++) {- temp = res.r * xp[i].r - res.i * xp[i].i;- res.i = res.r * xp[i].i + res.i * xp[i].r;- res.r = temp;- }- rp[0] = res;- OK-}-- -double dnrm2_(integer*, const double*, integer*);-double dasum_(integer*, const double*, integer*);--double vector_max(KDVEC(x)) {- double r = xp[0];- int k;- for (k = 1; k<xn; k++) {- if(xp[k]>r) {- r = xp[k];- }- }- return r;-}--double vector_min(KDVEC(x)) {- double r = xp[0];- int k;- for (k = 1; k<xn; k++) {- if(xp[k]<r) {- r = xp[k];- }- }- return r;-}--double vector_max_index(KDVEC(x)) {- int k, r = 0;- for (k = 1; k<xn; k++) {- if(xp[k]>xp[r]) {- r = k;- }- }- return r;-}--double vector_min_index(KDVEC(x)) {- int k, r = 0;- for (k = 1; k<xn; k++) {- if(xp[k]<xp[r]) {- r = k;- }- }- return r;-}- -int toScalarR(int code, KDVEC(x), DVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarR");- double res;- integer one = 1;- integer n = xn;- switch(code) {- case 0: { res = dnrm2_(&n,xp,&one); break; }- case 1: { res = dasum_(&n,xp,&one); break; }- case 2: { res = vector_max_index(V(x)); break; }- case 3: { res = vector_max(V(x)); break; }- case 4: { res = vector_min_index(V(x)); break; }- case 5: { res = vector_min(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}---float snrm2_(integer*, const float*, integer*);-float sasum_(integer*, const float*, integer*);--float vector_max_f(KFVEC(x)) {- float r = xp[0];- int k;- for (k = 1; k<xn; k++) {- if(xp[k]>r) {- r = xp[k];- }- }- return r;-}--float vector_min_f(KFVEC(x)) {- float r = xp[0];- int k;- for (k = 1; k<xn; k++) {- if(xp[k]<r) {- r = xp[k];- }- }- return r;-}--float vector_max_index_f(KFVEC(x)) {- int k, r = 0;- for (k = 1; k<xn; k++) {- if(xp[k]>xp[r]) {- r = k;- }- }- return r;-}--float vector_min_index_f(KFVEC(x)) {- int k, r = 0;- for (k = 1; k<xn; k++) {- if(xp[k]<xp[r]) {- r = k;- }- }- return r;-}---int toScalarF(int code, KFVEC(x), FVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarF");- float res;- integer one = 1;- integer n = xn;- switch(code) {- case 0: { res = snrm2_(&n,xp,&one); break; }- case 1: { res = sasum_(&n,xp,&one); break; }- case 2: { res = vector_max_index_f(V(x)); break; }- case 3: { res = vector_max_f(V(x)); break; }- case 4: { res = vector_min_index_f(V(x)); break; }- case 5: { res = vector_min_f(V(x)); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}--double dznrm2_(integer*, const doublecomplex*, integer*);-double dzasum_(integer*, const doublecomplex*, integer*);--int toScalarC(int code, KCVEC(x), DVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarC");- double res;- integer one = 1;- integer n = xn;- switch(code) {- case 0: { res = dznrm2_(&n,xp,&one); break; }- case 1: { res = dzasum_(&n,xp,&one); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}---double scnrm2_(integer*, const complex*, integer*);-double scasum_(integer*, const complex*, integer*);--int toScalarQ(int code, KQVEC(x), FVEC(r)) { - REQUIRES(rn==1,BAD_SIZE);- DEBUGMSG("toScalarQ");- float res;- integer one = 1;- integer n = xn;- switch(code) {- case 0: { res = scnrm2_(&n,xp,&one); break; }- case 1: { res = scasum_(&n,xp,&one); break; }- default: ERROR(BAD_CODE);- }- rp[0] = res;- OK-}---inline double sign(double x) {- if(x>0) {- return +1.0;- } else if (x<0) {- return -1.0;- } else {- return 0.0;- }-}--inline float float_sign(float x) {- if(x>0) {- return +1.0;- } else if (x<0) {- return -1.0;- } else {- return 0.0;- }-}---#define OP(C,F) case C: { for(k=0;k<xn;k++) rp[k] = F(xp[k]); OK }-#define OPV(C,E) case C: { for(k=0;k<xn;k++) rp[k] = E; OK }-int mapR(int code, KDVEC(x), DVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapR");- switch (code) {- OP(0,sin)- OP(1,cos)- OP(2,tan)- OP(3,fabs)- OP(4,asin)- OP(5,acos)- OP(6,atan)- OP(7,sinh)- OP(8,cosh)- OP(9,tanh)- OP(10,asinh)- OP(11,acosh)- OP(12,atanh)- OP(13,exp)- OP(14,log)- OP(15,sign)- OP(16,sqrt)- default: ERROR(BAD_CODE);- }-}--int mapF(int code, KFVEC(x), FVEC(r)) {- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapF");- switch (code) {- OP(0,sin)- OP(1,cos)- OP(2,tan)- OP(3,fabs)- OP(4,asin)- OP(5,acos)- OP(6,atan)- OP(7,sinh)- OP(8,cosh)- OP(9,tanh)- OP(10,asinh)- OP(11,acosh)- OP(12,atanh)- OP(13,exp)- OP(14,log)- OP(15,sign)- OP(16,sqrt)- default: ERROR(BAD_CODE);- }-}---inline double abs_complex(doublecomplex z) {- return sqrt(z.r*z.r + z.i*z.i);-}--inline doublecomplex complex_abs_complex(doublecomplex z) {- doublecomplex r;- r.r = abs_complex(z);- r.i = 0;- return r;-}--inline doublecomplex complex_signum_complex(doublecomplex z) {- doublecomplex r;- double mag;- if (z.r == 0 && z.i == 0) {- r.r = 0;- r.i = 0;- } else {- mag = abs_complex(z);- r.r = z.r/mag;- r.i = z.i/mag;- }- return r;-}--#define OPb(C,F) case C: { for(k=0;k<xn;k++) r2p[k] = F(x2p[k]); OK }-int mapC(int code, KCVEC(x), CVEC(r)) {- TCD* x2p = (TCD*)xp;- TCD* r2p = (TCD*)rp;- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapC");- switch (code) {- OPb(0,csin)- OPb(1,ccos)- OPb(2,ctan)- OP(3,complex_abs_complex)- OPb(4,casin)- OPb(5,cacos)- OPb(6,catan)- OPb(7,csinh)- OPb(8,ccosh)- OPb(9,ctanh)- OPb(10,casinh)- OPb(11,cacosh)- OPb(12,catanh)- OPb(13,cexp)- OPb(14,clog)- OP(15,complex_signum_complex)- OPb(16,csqrt)- default: ERROR(BAD_CODE);- }-}----inline complex complex_f_math_fun(doublecomplex (*cf)(doublecomplex), complex a)-{- doublecomplex c;- doublecomplex r;-- complex float_r;-- c.r = a.r;- c.i = a.i;-- r = (*cf)(c);-- float_r.r = r.r;- float_r.i = r.i;-- return float_r;-}---#define OPC(C,F) case C: { for(k=0;k<xn;k++) rp[k] = complex_f_math_fun(&F,xp[k]); OK }-int mapQ(int code, KQVEC(x), QVEC(r)) {- TCF* x2p = (TCF*)xp;- TCF* r2p = (TCF*)rp;- int k;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapQ");- switch (code) {- OPb(0,csinf)- OPb(1,ccosf)- OPb(2,ctanf)- OPC(3,complex_abs_complex)- OPb(4,casinf)- OPb(5,cacosf)- OPb(6,catanf)- OPb(7,csinhf)- OPb(8,ccoshf)- OPb(9,ctanhf)- OPb(10,casinhf)- OPb(11,cacoshf)- OPb(12,catanhf)- OPb(13,cexpf)- OPb(14,clogf)- OPC(15,complex_signum_complex)- OPb(16,csqrtf)- default: ERROR(BAD_CODE);- }-}---int mapValR(int code, double* pval, KDVEC(x), DVEC(r)) {- int k;- double val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValR");- switch (code) {- OPV(0,val*xp[k])- OPV(1,val/xp[k])- OPV(2,val+xp[k])- OPV(3,val-xp[k])- OPV(4,pow(val,xp[k]))- OPV(5,pow(xp[k],val))- default: ERROR(BAD_CODE);- }-}--int mapValF(int code, float* pval, KFVEC(x), FVEC(r)) {- int k;- float val = *pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValF");- switch (code) {- OPV(0,val*xp[k])- OPV(1,val/xp[k])- OPV(2,val+xp[k])- OPV(3,val-xp[k])- OPV(4,pow(val,xp[k]))- OPV(5,pow(xp[k],val))- default: ERROR(BAD_CODE);- }-}----inline doublecomplex complex_add(doublecomplex a, doublecomplex b) {- doublecomplex r;- r.r = a.r+b.r;- r.i = a.i+b.i;- return r;-}--#define OPVb(C,E) case C: { for(k=0;k<xn;k++) r2p[k] = E; OK }-int mapValC(int code, doublecomplex* pval, KCVEC(x), CVEC(r)) {- TCD* x2p = (TCD*)xp;- TCD* r2p = (TCD*)rp;- int k;- TCD val = * (TCD*)pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValC");- switch (code) {- OPVb(0,val*x2p[k])- OPVb(1,val/x2p[k])- OPVb(2,val+x2p[k])- OPVb(3,val-x2p[k])- OPVb(4,cpow(val,x2p[k]))- OPVb(5,cpow(x2p[k],val))- default: ERROR(BAD_CODE);- }-}---int mapValQ(int code, complex* pval, KQVEC(x), QVEC(r)) {- TCF* x2p = (TCF*)xp;- TCF* r2p = (TCF*)rp;- int k;- TCF val = *(TCF*)pval;- REQUIRES(xn == rn,BAD_SIZE);- DEBUGMSG("mapValQ");- switch (code) {- OPVb(0,val*x2p[k])- OPVb(1,val/x2p[k])- OPVb(2,val+x2p[k])- OPVb(3,val-x2p[k])- OPVb(4,cpow(val,x2p[k]))- OPVb(5,cpow(x2p[k],val))- default: ERROR(BAD_CODE);- }-}----#define OPZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = E(ap[k],bp[k]); OK }-#define OPZV(C,msg,E) case C: {DEBUGMSG(msg) res = E(V(r),V(b)); CHECK(res,res); OK }-#define OPZO(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = ap[k] O bp[k]; OK }--int zipR(int code, KDVEC(a), KDVEC(b), DVEC(r)) {-REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPZO(0,"zipR Add",+)- OPZO(1,"zipR Sub",-)- OPZO(2,"zipR Mul",*)- OPZO(3,"zipR Div",/)- OPZE(4,"zipR Pow", pow)- OPZE(5,"zipR ATan2",atan2)- default: ERROR(BAD_CODE);- }-}--int zipF(int code, KFVEC(a), KFVEC(b), FVEC(r)) {-REQUIRES(an == bn && an == rn, BAD_SIZE);- int k;- switch(code) {- OPZO(0,"zipR Add",+)- OPZO(1,"zipR Sub",-)- OPZO(2,"zipR Mul",*)- OPZO(3,"zipR Div",/)- OPZE(4,"zipR Pow", pow)- OPZE(5,"zipR ATan2",atan2)- default: ERROR(BAD_CODE);- }-}----#define OPZOb(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = a2p[k] O b2p[k]; OK }-#define OPZEb(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = E(a2p[k],b2p[k]); OK }-int zipC(int code, KCVEC(a), KCVEC(b), CVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- TCD* a2p = (TCD*)ap;- TCD* b2p = (TCD*)bp;- TCD* r2p = (TCD*)rp;- int k;- switch(code) {- OPZOb(0,"zipC Add",+)- OPZOb(1,"zipC Sub",-)- OPZOb(2,"zipC Mul",*)- OPZOb(3,"zipC Div",/)- OPZEb(4,"zipC Pow",cpow)- default: ERROR(BAD_CODE);- }-}------#define OPCZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = complex_f_math_op(&E,ap[k],bp[k]); OK }--int zipQ(int code, KQVEC(a), KQVEC(b), QVEC(r)) {- REQUIRES(an == bn && an == rn, BAD_SIZE);- TCF* a2p = (TCF*)ap;- TCF* b2p = (TCF*)bp;- TCF* r2p = (TCF*)rp;-- int k;- switch(code) {- OPZOb(0,"zipC Add",+)- OPZOb(1,"zipC Sub",-)- OPZOb(2,"zipC Mul",*)- OPZOb(3,"zipC Div",/)- OPZEb(4,"zipC Pow",cpowf)- default: ERROR(BAD_CODE);- }-}--////////////////////////////////////////////////////////////////////////////////--int vectorScan(char * file, int* n, double**pp){- FILE * fp;- fp = fopen (file, "r");- if(!fp) {- ERROR(BAD_FILE);- }- int nbuf = 100*100;- double * p = (double*)malloc(nbuf*sizeof(double));- int k=0;- double d;- int ok;- for (;;) {- ok = fscanf(fp,"%lf",&d);- if (ok<1) {- break;- }- if (k==nbuf) {- nbuf = nbuf * 2;- p = (double*)realloc(p,nbuf*sizeof(double));- // printf("R\n");- }- p[k++] = d;- }- *n = k;- *pp = p;- fclose(fp);- OK-} --int saveMatrix(char * file, char * format, KDMAT(a)){- FILE * fp;- fp = fopen (file, "w");- int r, c;- for (r=0;r<ar; r++) {- for (c=0; c<ac; c++) {- fprintf(fp,format,ap[r*ac+c]);- if (c<ac-1) {- fprintf(fp," ");- } else {- fprintf(fp,"\n");- }- }- }- fclose(fp);- OK-}--////////////////////////////////////////////////////////////////////////////////--// http://c-faq.com/lib/gaussian.html-double gaussrand()-{- static double V1, V2, S;- static int phase = 0;- double X;-- if(phase == 0) {- do {- double U1 = (double)rand() / RAND_MAX;- double U2 = (double)rand() / RAND_MAX;-- V1 = 2 * U1 - 1;- V2 = 2 * U2 - 1;- S = V1 * V1 + V2 * V2;- } while(S >= 1 || S == 0);-- X = V1 * sqrt(-2 * log(S) / S);- } else- X = V2 * sqrt(-2 * log(S) / S);-- phase = 1 - phase;-- return X;-}--int random_vector(int seed, int code, DVEC(r)) {- srand(seed);- int k;- switch (code) {- case 0: { // uniform- for (k=0; k<rn; k++) {- rp[k] = (double)rand()/RAND_MAX;- }- OK- }- case 1: { // gaussian- for (k=0; k<rn; k++) {- rp[k] = gaussrand();- }- OK- }-- default: ERROR(BAD_CODE);- }-}--////////////////////////////////////////////////////////////////////////////////--int smXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {- int r, c;- for (r = 0; r < rowsn - 1; r++) {- rp[r] = 0;- for (c = rowsp[r]; c < rowsp[r+1]; c++) {- rp[r] += valsp[c-1] * xp[colsp[c-1]-1];- }- }- OK-}--int smTXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {- int r,c;- for (c = 0; c < rn; c++) {- rp[c] = 0;- }- for (r = 0; r < rowsn - 1; r++) {- for (c = rowsp[r]; c < rowsp[r+1]; c++) {- rp[colsp[c-1]-1] += valsp[c-1] * xp[r];- }- }- OK-}--////////////////////////////////////////////////////////////////////////////////--int-compare_doubles (const void *a, const void *b) {- return *(double*)a > *(double*)b;-}--int sort_values(KDVEC(v),DVEC(r)) {- memcpy(rp,vp,vn*sizeof(double));- qsort(rp,rn,sizeof(double),compare_doubles);- OK-}--////////////////////////////////////////////////////////////////////////////////--int round_vector(KDVEC(v),DVEC(r)) {- int k;- for(k=0; k<vn; k++) {- rp[k] = round(vp[k]);- }- OK-}-
− src/Data/Packed.hs
@@ -1,26 +0,0 @@-------------------------------------------------------------------------------{- |-Module : Data.Packed-Copyright : (c) Alberto Ruiz 2006-2014-License : BSD3-Maintainer : Alberto Ruiz-Stability : provisional--Types for dense 'Vector' and 'Matrix' of 'Storable' elements.---}-------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed (- -- * Vector- --- -- | Vectors are @Data.Vector.Storable.Vector@ from the \"vector\" package.- module Data.Packed.Vector,- -- * Matrix- module Data.Packed.Matrix,-) where--import Data.Packed.Vector-import Data.Packed.Matrix-
− src/Data/Packed/Development.hs
@@ -1,32 +0,0 @@---------------------------------------------------------------------------------- |--- Module : Data.Packed.Development--- Copyright : (c) Alberto Ruiz 2009--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional--- Portability : portable------ The library can be easily extended with additional foreign functions--- using the tools in this module. Illustrative usage examples can be found--- in the @examples\/devel@ folder included in the package.----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.Development (- createVector, createMatrix,- vec, mat,- app1, app2, app3, app4,- app5, app6, app7, app8, app9, app10,- MatrixOrder(..), orderOf, cmat, fmat,- matrixFromVector,- unsafeFromForeignPtr,- unsafeToForeignPtr,- check, (//),- at', atM', fi-) where--import Data.Packed.Internal-
− src/Data/Packed/Foreign.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE MagicHash, UnboxedTuples #-}--- | FFI and hmatrix helpers.------ Sample usage, to upload a perspective matrix to a shader.------ @ glUniformMatrix4fv 0 1 (fromIntegral gl_TRUE) \`appMatrix\` perspective 0.01 100 (pi\/2) (4\/3) --- @----{-# OPTIONS_HADDOCK hide #-}-module Data.Packed.Foreign - ( app- , appVector, appVectorLen- , appMatrix, appMatrixLen, appMatrixRaw, appMatrixRawLen- , unsafeMatrixToVector, unsafeMatrixToForeignPtr- ) where-import Data.Packed.Internal-import qualified Data.Vector.Storable as S-import Foreign (Ptr, ForeignPtr, Storable)-import Foreign.C.Types (CInt)-import GHC.Base (IO(..), realWorld#)--{-# INLINE unsafeInlinePerformIO #-}--- | If we use unsafePerformIO, it may not get inlined, so in a function that returns IO (which are all safe uses of app* in this module), there would be--- unecessary calls to unsafePerformIO or its internals.-unsafeInlinePerformIO :: IO a -> a-unsafeInlinePerformIO (IO f) = case f realWorld# of- (# _, x #) -> x--{-# INLINE app #-}--- | Only useful since it is left associated with a precedence of 1, unlike 'Prelude.$', which is right associative.--- e.g.------ @--- someFunction--- \`appMatrixLen\` m--- \`appVectorLen\` v--- \`app\` other--- \`app\` arguments--- \`app\` go here--- @------ One could also write:------ @--- (someFunction --- \`appMatrixLen\` m--- \`appVectorLen\` v) --- other --- arguments --- (go here)--- @----app :: (a -> b) -> a -> b-app f = f--{-# INLINE appVector #-}-appVector :: Storable a => (Ptr a -> b) -> Vector a -> b-appVector f x = unsafeInlinePerformIO (S.unsafeWith x (return . f))--{-# INLINE appVectorLen #-}-appVectorLen :: Storable a => (CInt -> Ptr a -> b) -> Vector a -> b-appVectorLen f x = unsafeInlinePerformIO (S.unsafeWith x (return . f (fromIntegral (S.length x))))--{-# INLINE appMatrix #-}-appMatrix :: Element a => (Ptr a -> b) -> Matrix a -> b-appMatrix f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f))--{-# INLINE appMatrixLen #-}-appMatrixLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b-appMatrixLen f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f r c))- where- r = fromIntegral (rows x)- c = fromIntegral (cols x)--{-# INLINE appMatrixRaw #-}-appMatrixRaw :: Storable a => (Ptr a -> b) -> Matrix a -> b-appMatrixRaw f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f))--{-# INLINE appMatrixRawLen #-}-appMatrixRawLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b-appMatrixRawLen f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f r c))- where- r = fromIntegral (rows x)- c = fromIntegral (cols x)--infixl 1 `app`-infixl 1 `appVector`-infixl 1 `appMatrix`-infixl 1 `appMatrixRaw`--{-# INLINE unsafeMatrixToVector #-}--- | This will disregard the order of the matrix, and simply return it as-is. --- If the order of the matrix is RowMajor, this function is identical to 'flatten'.-unsafeMatrixToVector :: Matrix a -> Vector a-unsafeMatrixToVector = xdat--{-# INLINE unsafeMatrixToForeignPtr #-}-unsafeMatrixToForeignPtr :: Storable a => Matrix a -> (ForeignPtr a, Int)-unsafeMatrixToForeignPtr m = S.unsafeToForeignPtr0 (xdat m)-
− src/Data/Packed/IO.hs
@@ -1,167 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Packed.IO--- Copyright : (c) Alberto Ruiz 2010--- License : BSD3------ Maintainer : Alberto Ruiz--- Stability : provisional------ Display, formatting and IO functions for numeric 'Vector' and 'Matrix'----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.IO (- dispf, disps, dispcf, vecdisp, latexFormat, format,- readMatrix, fromArray2D, loadMatrix, loadMatrix', saveMatrix-) where--import Data.Packed-import Text.Printf(printf)-import Data.List(intersperse)-import Data.Complex-import Numeric.Vectorized(vectorScan,saveMatrix)-import Control.Applicative((<$>))-import Data.Packed.Internal--{- | Creates a string from a matrix given a separator and a function to show each entry. Using-this function the user can easily define any desired display function:--@import Text.Printf(printf)@--@disp = putStr . format \" \" (printf \"%.2f\")@---}-format :: (Element t) => String -> (t -> String) -> Matrix t -> String-format sep f m = table sep . map (map f) . toLists $ m--{- | Show a matrix with \"autoscaling\" and a given number of decimal places.-->>> putStr . disps 2 $ 120 * (3><4) [1..]-3x4 E3- 0.12 0.24 0.36 0.48- 0.60 0.72 0.84 0.96- 1.08 1.20 1.32 1.44---}-disps :: Int -> Matrix Double -> String-disps d x = sdims x ++ " " ++ formatScaled d x--{- | Show a matrix with a given number of decimal places.-->>> dispf 2 (1/3 + ident 3)-"3x3\n1.33 0.33 0.33\n0.33 1.33 0.33\n0.33 0.33 1.33\n"-->>> putStr . dispf 2 $ (3><4)[1,1.5..]-3x4-1.00 1.50 2.00 2.50-3.00 3.50 4.00 4.50-5.00 5.50 6.00 6.50-->>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1)-0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00---}-dispf :: Int -> Matrix Double -> String-dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x--sdims x = show (rows x) ++ "x" ++ show (cols x)--formatFixed d x = format " " (printf ("%."++show d++"f")) $ x--isInt = all lookslikeInt . toList . flatten--formatScaled dec t = "E"++show o++"\n" ++ ss- where ss = format " " (printf fmt. g) t- g x | o >= 0 = x/10^(o::Int)- | otherwise = x*10^(-o)- o | rows t == 0 || cols t == 0 = 0- | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t- fmt = '%':show (dec+3) ++ '.':show dec ++"f"--{- | Show a vector using a function for showing matrices.-->>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1)-10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00---}-vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String-vecdisp f v- = ((show (dim v) ++ " |> ") ++) . (++"\n")- . unwords . lines . tail . dropWhile (not . (`elem` " \n"))- . f . trans . reshape 1- $ v--{- | Tool to display matrices with latex syntax.-->>> latexFormat "bmatrix" (dispf 2 $ ident 2)-"\\begin{bmatrix}\n1 & 0\n\\\\\n0 & 1\n\\end{bmatrix}"---}-latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc.- -> String -- ^ Formatted matrix, with elements separated by spaces and newlines- -> String-latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}"- where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines---- | Pretty print a complex number with at most n decimal digits.-showComplex :: Int -> Complex Double -> String-showComplex d (a:+b)- | isZero a && isZero b = "0"- | isZero b = sa- | isZero a && isOne b = s2++"i"- | isZero a = sb++"i"- | isOne b = sa++s3++"i"- | otherwise = sa++s1++sb++"i"- where- sa = shcr d a- sb = shcr d b- s1 = if b<0 then "" else "+"- s2 = if b<0 then "-" else ""- s3 = if b<0 then "-" else "+"--shcr d a | lookslikeInt a = printf "%.0f" a- | otherwise = printf ("%."++show d++"f") a---lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx- where shx = show x--isZero x = show x `elem` ["0.0","-0.0"]-isOne x = show x `elem` ["1.0","-1.0"]---- | Pretty print a complex matrix with at most n decimal digits.-dispcf :: Int -> Matrix (Complex Double) -> String-dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m-------------------------------------------------------------------------- | reads a matrix from a string containing a table of numbers.-readMatrix :: String -> Matrix Double-readMatrix = fromLists . map (map read). map words . filter (not.null) . lines------------------------------------------------------------------------------------apparentCols :: FilePath -> IO Int-apparentCols s = f . dropWhile null . map words . lines <$> readFile s- where- f [] = 0- f (x:_) = length x----- | load a matrix from an ASCII file formatted as a 2D table.-loadMatrix :: FilePath -> IO (Matrix Double)-loadMatrix f = do- v <- vectorScan f- c <- apparentCols f- if (dim v `mod` c /= 0)- then- error $ printf "loadMatrix: %d elements and %d columns in file %s"- (dim v) c f- else- return (reshape c v)---loadMatrix' name = mbCatch (loadMatrix name)-
− src/Data/Packed/Internal.hs
@@ -1,24 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal--- Copyright : (c) Alberto Ruiz 2007--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Reexports all internal modules------------------------------------------------------------------------------------ #hide--module Data.Packed.Internal (- module Data.Packed.Internal.Common,- module Data.Packed.Internal.Signatures,- module Data.Packed.Internal.Vector,- module Data.Packed.Internal.Matrix,-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector-import Data.Packed.Internal.Matrix
− src/Data/Packed/Internal/Common.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Module : Data.Packed.Internal.Common--- Copyright : (c) Alberto Ruiz 2007--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional--------- Development utilities.------module Data.Packed.Internal.Common(- Adapt,- app1, app2, app3, app4,- app5, app6, app7, app8, app9, app10,- (//), check, mbCatch,- splitEvery, common, compatdim,- fi,- table,- finit-) where--import Control.Monad(when)-import Foreign.C.Types-import Foreign.Storable.Complex()-import Data.List(transpose,intersperse)-import Control.Exception as E---- | @splitEvery 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@-splitEvery :: Int -> [a] -> [[a]]-splitEvery _ [] = []-splitEvery k l = take k l : splitEvery k (drop k l)---- | obtains the common value of a property of a list-common :: (Eq a) => (b->a) -> [b] -> Maybe a-common f = commonval . map f where- commonval :: (Eq a) => [a] -> Maybe a- commonval [] = Nothing- commonval [a] = Just a- commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing---- | common value with \"adaptable\" 1-compatdim :: [Int] -> Maybe Int-compatdim [] = Nothing-compatdim [a] = Just a-compatdim (a:b:xs)- | a==b = compatdim (b:xs)- | a==1 = compatdim (b:xs)- | b==1 = compatdim (a:xs)- | otherwise = Nothing---- | Formatting tool-table :: String -> [[String]] -> String-table sep as = unlines . map unwords' $ transpose mtp where - mt = transpose as- longs = map (maximum . map length) mt- mtp = zipWith (\a b -> map (pad a) b) longs mt- pad n str = replicate (n - length str) ' ' ++ str- unwords' = concat . intersperse sep---- | postfix function application (@flip ($)@)-(//) :: x -> (x -> y) -> y-infixl 0 //-(//) = flip ($)---- | specialized fromIntegral-fi :: Int -> CInt-fi = fromIntegral---- hmm..-ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f-ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f-ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f-ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f-ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 f = w1 o1 $ ww5 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 . f-ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 f = w1 o1 $ ww6 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 . f-ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 f = w1 o1 $ ww7 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 . f-ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 f = w1 o1 $ ww8 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 . f-ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 f = w1 o1 $ ww9 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 . f--type Adapt f t r = t -> ((f -> r) -> IO()) -> IO()--type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO()-type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2-type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3-type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4-type Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 = Adapt f t1 r1 -> t1 -> Adapt4 r1 t2 r2 t3 r3 t4 r4 t5-type Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 = Adapt f t1 r1 -> t1 -> Adapt5 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6-type Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 = Adapt f t1 r1 -> t1 -> Adapt6 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7-type Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 = Adapt f t1 r1 -> t1 -> Adapt7 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8-type Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 = Adapt f t1 r1 -> t1 -> Adapt8 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9-type Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 = Adapt f t1 r1 -> t1 -> Adapt9 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10--app1 :: f -> Adapt1 f t1-app2 :: f -> Adapt2 f t1 r1 t2-app3 :: f -> Adapt3 f t1 r1 t2 r2 t3-app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4-app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5-app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6-app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7-app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8-app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9-app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10--app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s-app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s-app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $- \a1 a2 a3 -> f // a1 // a2 // a3 // check s-app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $- \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s-app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $- \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s-app6 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 s = ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 $- \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s-app7 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 s = ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 $- \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s-app8 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 s = ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 $- \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s-app9 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 s = ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 $- \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s-app10 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 s = ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 $- \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s------ GSL error codes are <= 1024--- | error codes for the auxiliary functions required by the wrappers-errorCode :: CInt -> String-errorCode 2000 = "bad size"-errorCode 2001 = "bad function code"-errorCode 2002 = "memory problem"-errorCode 2003 = "bad file"-errorCode 2004 = "singular"-errorCode 2005 = "didn't converge"-errorCode 2006 = "the input matrix is not positive definite"-errorCode 2007 = "not yet supported in this OS"-errorCode n = "code "++show n----- | clear the fpu-foreign import ccall unsafe "asm_finit" finit :: IO ()---- | check the error code-check :: String -> IO CInt -> IO ()-check msg f = do-#if FINIT- finit-#endif- err <- f- when (err/=0) $ error (msg++": "++errorCode err)- return ()---- | Error capture and conversion to Maybe-mbCatch :: IO x -> IO (Maybe x)-mbCatch act = E.catch (Just `fmap` act) f- where f :: SomeException -> IO (Maybe x)- f _ = return Nothing-
− src/Data/Packed/Internal/Matrix.hs
@@ -1,423 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}---- |--- Module : Data.Packed.Internal.Matrix--- Copyright : (c) Alberto Ruiz 2007--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Internal matrix representation-----module Data.Packed.Internal.Matrix(- Matrix(..), rows, cols, cdat, fdat,- MatrixOrder(..), orderOf,- createMatrix, mat,- cmat, fmat,- toLists, flatten, reshape,- Element(..),- trans,- fromRows, toRows, fromColumns, toColumns,- matrixFromVector,- subMatrix,- liftMatrix, liftMatrix2,- (@@>), atM',- singleton,- emptyM,- size, shSize, conformVs, conformMs, conformVTo, conformMTo-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector--import Foreign.Marshal.Alloc(alloca, free)-import Foreign.Marshal.Array(newArray)-import Foreign.Ptr(Ptr, castPtr)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff, poke, sizeOf)-import Data.Complex(Complex)-import Foreign.C.Types-import System.IO.Unsafe(unsafePerformIO)-import Control.DeepSeq---------------------------------------------------------------------{- Design considerations for the Matrix Type- -------------------------------------------- we must easily handle both row major and column major order,- for bindings to LAPACK and GSL/C--- we'd like to simplify redundant matrix transposes:- - Some of them arise from the order requirements of some functions- - some functions (matrix product) admit transposed arguments--- maybe we don't really need this kind of simplification:- - more complex code- - some computational overhead- - only appreciable gain in code with a lot of redundant transpositions- and cheap matrix computations--- we could carry both the matrix and its (lazily computed) transpose.- This may save some transpositions, but it is necessary to keep track of the- data which is actually computed to be used by functions like the matrix product- which admit both orders.--- but if we need the transposed data and it is not in the structure, we must make- sure that we touch the same foreignptr that is used in the computation.--- a reasonable solution is using two constructors for a matrix. Transposition just- "flips" the constructor. Actual data transposition is not done if followed by a- matrix product or another transpose.---}--data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq)--transOrder RowMajor = ColumnMajor-transOrder ColumnMajor = RowMajor-{- | Matrix representation suitable for BLAS\/LAPACK computations.--The elements are stored in a continuous memory array.---}--data Matrix t = Matrix { irows :: {-# UNPACK #-} !Int- , icols :: {-# UNPACK #-} !Int- , xdat :: {-# UNPACK #-} !(Vector t)- , order :: !MatrixOrder }--- RowMajor: preferred by C, fdat may require a transposition--- ColumnMajor: preferred by LAPACK, cdat may require a transposition--cdat = xdat-fdat = xdat--rows :: Matrix t -> Int-rows = irows--cols :: Matrix t -> Int-cols = icols--orderOf :: Matrix t -> MatrixOrder-orderOf = order----- | Matrix transpose.-trans :: Matrix t -> Matrix t-trans Matrix {irows = r, icols = c, xdat = d, order = o } = Matrix { irows = c, icols = r, xdat = d, order = transOrder o}--cmat :: (Element t) => Matrix t -> Matrix t-cmat m@Matrix{order = RowMajor} = m-cmat Matrix {irows = r, icols = c, xdat = d, order = ColumnMajor } = Matrix { irows = r, icols = c, xdat = transdata r d c, order = RowMajor}--fmat :: (Element t) => Matrix t -> Matrix t-fmat m@Matrix{order = ColumnMajor} = m-fmat Matrix {irows = r, icols = c, xdat = d, order = RowMajor } = Matrix { irows = r, icols = c, xdat = transdata c d r, order = ColumnMajor}---- C-Haskell matrix adapter--- mat :: Adapt (CInt -> CInt -> Ptr t -> r) (Matrix t) r--mat :: (Storable t) => Matrix t -> (((CInt -> CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b-mat a f =- unsafeWith (xdat a) $ \p -> do- let m g = do- g (fi (rows a)) (fi (cols a)) p- f m--{- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose.-->>> flatten (ident 3)-fromList [1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0]---}-flatten :: Element t => Matrix t -> Vector t-flatten = xdat . cmat--{--type Mt t s = Int -> Int -> Ptr t -> s--infixr 6 ::>-type t ::> s = Mt t s--}---- | the inverse of 'Data.Packed.Matrix.fromLists'-toLists :: (Element t) => Matrix t -> [[t]]-toLists m = splitEvery (cols m) . toList . flatten $ m---- | Create a matrix from a list of vectors.--- All vectors must have the same dimension,--- or dimension 1, which is are automatically expanded.-fromRows :: Element t => [Vector t] -> Matrix t-fromRows [] = emptyM 0 0-fromRows vs = case compatdim (map dim vs) of- Nothing -> error $ "fromRows expects vectors with equal sizes (or singletons), given: " ++ show (map dim vs)- Just 0 -> emptyM r 0- Just c -> matrixFromVector RowMajor r c . vjoin . map (adapt c) $ vs- where- r = length vs- adapt c v- | c == 0 = fromList[]- | dim v == c = v- | otherwise = constantD (v@>0) c---- | extracts the rows of a matrix as a list of vectors-toRows :: Element t => Matrix t -> [Vector t]-toRows m- | c == 0 = replicate r (fromList[])- | otherwise = toRows' 0- where- v = flatten m- r = rows m- c = cols m- toRows' k | k == r*c = []- | otherwise = subVector k c v : toRows' (k+c)---- | Creates a matrix from a list of vectors, as columns-fromColumns :: Element t => [Vector t] -> Matrix t-fromColumns m = trans . fromRows $ m---- | Creates a list of vectors from the columns of a matrix-toColumns :: Element t => Matrix t -> [Vector t]-toColumns m = toRows . trans $ m---- | Reads a matrix position.-(@@>) :: Storable t => Matrix t -> (Int,Int) -> t-infixl 9 @@>-m@Matrix {irows = r, icols = c} @@> (i,j)- | safe = if i<0 || i>=r || j<0 || j>=c- then error "matrix indexing out of range"- else atM' m i j- | otherwise = atM' m i j-{-# INLINE (@@>) #-}---- Unsafe matrix access without range checking-atM' Matrix {icols = c, xdat = v, order = RowMajor} i j = v `at'` (i*c+j)-atM' Matrix {irows = r, xdat = v, order = ColumnMajor} i j = v `at'` (j*r+i)-{-# INLINE atM' #-}----------------------------------------------------------------------matrixFromVector o r c v- | r * c == dim v = m- | otherwise = error $ "can't reshape vector dim = "++ show (dim v)++" to matrix " ++ shSize m- where- m = Matrix { irows = r, icols = c, xdat = v, order = o }---- allocates memory for a new matrix-createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a)-createMatrix ord r c = do- p <- createVector (r*c)- return (matrixFromVector ord r c p)--{- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = trans . reshape r@-where r is the desired number of rows.)-->>> reshape 4 (fromList [1..12])-(3><4)- [ 1.0, 2.0, 3.0, 4.0- , 5.0, 6.0, 7.0, 8.0- , 9.0, 10.0, 11.0, 12.0 ]---}-reshape :: Storable t => Int -> Vector t -> Matrix t-reshape 0 v = matrixFromVector RowMajor 0 0 v-reshape c v = matrixFromVector RowMajor (dim v `div` c) c v--singleton x = reshape 1 (fromList [x])---- | application of a vector function on the flattened matrix elements-liftMatrix :: (Storable a, Storable b) => (Vector a -> Vector b) -> Matrix a -> Matrix b-liftMatrix f Matrix { irows = r, icols = c, xdat = d, order = o } = matrixFromVector o r c (f d)---- | application of a vector function on the flattened matrices elements-liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t-liftMatrix2 f m1 m2- | not (compat m1 m2) = error "nonconformant matrices in liftMatrix2"- | otherwise = case orderOf m1 of- RowMajor -> matrixFromVector RowMajor (rows m1) (cols m1) (f (xdat m1) (flatten m2))- ColumnMajor -> matrixFromVector ColumnMajor (rows m1) (cols m1) (f (xdat m1) ((xdat.fmat) m2))---compat :: Matrix a -> Matrix b -> Bool-compat m1 m2 = rows m1 == rows m2 && cols m1 == cols m2----------------------------------------------------------------------{- | Supported matrix elements.-- This class provides optimized internal- operations for selected element types.- It provides unoptimised defaults for any 'Storable' type,- so you can create instances simply as:-- >instance Element Foo--}-class (Storable a) => Element a where- subMatrixD :: (Int,Int) -- ^ (r0,c0) starting position - -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix- -> Matrix a -> Matrix a- subMatrixD = subMatrix'- transdata :: Int -> Vector a -> Int -> Vector a- transdata = transdataP -- transdata'- constantD :: a -> Int -> Vector a- constantD = constantP -- constant'---instance Element Float where- transdata = transdataAux ctransF- constantD = constantAux cconstantF--instance Element Double where- transdata = transdataAux ctransR- constantD = constantAux cconstantR--instance Element (Complex Float) where- transdata = transdataAux ctransQ- constantD = constantAux cconstantQ--instance Element (Complex Double) where- transdata = transdataAux ctransC- constantD = constantAux cconstantC-----------------------------------------------------------------------transdataAux fun c1 d c2 =- if noneed- then d- else unsafePerformIO $ do- v <- createVector (dim d)- unsafeWith d $ \pd ->- unsafeWith v $ \pv ->- fun (fi r1) (fi c1) pd (fi r2) (fi c2) pv // check "transdataAux"- return v- where r1 = dim d `div` c1- r2 = dim d `div` c2- noneed = dim d == 0 || r1 == 1 || c1 == 1--transdataP :: Storable a => Int -> Vector a -> Int -> Vector a-transdataP c1 d c2 =- if noneed- then d- else unsafePerformIO $ do- v <- createVector (dim d)- unsafeWith d $ \pd ->- unsafeWith v $ \pv ->- ctransP (fi r1) (fi c1) (castPtr pd) (fi sz) (fi r2) (fi c2) (castPtr pv) (fi sz) // check "transdataP"- return v- where r1 = dim d `div` c1- r2 = dim d `div` c2- sz = sizeOf (d @> 0)- noneed = dim d == 0 || r1 == 1 || c1 == 1--foreign import ccall unsafe "transF" ctransF :: TFMFM-foreign import ccall unsafe "transR" ctransR :: TMM-foreign import ccall unsafe "transQ" ctransQ :: TQMQM-foreign import ccall unsafe "transC" ctransC :: TCMCM-foreign import ccall unsafe "transP" ctransP :: CInt -> CInt -> Ptr () -> CInt -> CInt -> CInt -> Ptr () -> CInt -> IO CInt--------------------------------------------------------------------------constantAux fun x n = unsafePerformIO $ do- v <- createVector n- px <- newArray [x]- app1 (fun px) vec v "constantAux"- free px- return v--foreign import ccall unsafe "constantF" cconstantF :: Ptr Float -> TF--foreign import ccall unsafe "constantR" cconstantR :: Ptr Double -> TV--foreign import ccall unsafe "constantQ" cconstantQ :: Ptr (Complex Float) -> TQV--foreign import ccall unsafe "constantC" cconstantC :: Ptr (Complex Double) -> TCV--constantP :: Storable a => a -> Int -> Vector a-constantP a n = unsafePerformIO $ do- let sz = sizeOf a- v <- createVector n- unsafeWith v $ \p -> do- alloca $ \k -> do- poke k a- cconstantP (castPtr k) (fi n) (castPtr p) (fi sz) // check "constantP"- return v-foreign import ccall unsafe "constantP" cconstantP :: Ptr () -> CInt -> Ptr () -> CInt -> IO CInt---------------------------------------------------------------------------- | Extracts a submatrix from a matrix.-subMatrix :: Element a- => (Int,Int) -- ^ (r0,c0) starting position - -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix- -> Matrix a -- ^ input matrix- -> Matrix a -- ^ result-subMatrix (r0,c0) (rt,ct) m- | 0 <= r0 && 0 <= rt && r0+rt <= (rows m) &&- 0 <= c0 && 0 <= ct && c0+ct <= (cols m) = subMatrixD (r0,c0) (rt,ct) m- | otherwise = error $ "wrong subMatrix "++- show ((r0,c0),(rt,ct))++" of "++show(rows m)++"x"++ show (cols m)--subMatrix'' (r0,c0) (rt,ct) c v = unsafePerformIO $ do- w <- createVector (rt*ct)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) _ = return ()- go !i (-1) = go (i-1) (ct-1)- go !i !j = do x <- peekElemOff p ((i+r0)*c+j+c0)- pokeElemOff q (i*ct+j) x- go i (j-1)- go (rt-1) (ct-1)- return w--subMatrix' (r0,c0) (rt,ct) (Matrix { icols = c, xdat = v, order = RowMajor}) = Matrix rt ct (subMatrix'' (r0,c0) (rt,ct) c v) RowMajor-subMatrix' (r0,c0) (rt,ct) m = trans $ subMatrix' (c0,r0) (ct,rt) (trans m)------------------------------------------------------------------------------maxZ xs = if minimum xs == 0 then 0 else maximum xs--conformMs ms = map (conformMTo (r,c)) ms- where- r = maxZ (map rows ms)- c = maxZ (map cols ms)- --conformVs vs = map (conformVTo n) vs- where- n = maxZ (map dim vs)--conformMTo (r,c) m- | size m == (r,c) = m- | size m == (1,1) = matrixFromVector RowMajor r c (constantD (m@@>(0,0)) (r*c))- | size m == (r,1) = repCols c m- | size m == (1,c) = repRows r m- | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to (" ++ show r ++ "><"++ show c ++")"--conformVTo n v- | dim v == n = v- | dim v == 1 = constantD (v@>0) n- | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n--repRows n x = fromRows (replicate n (flatten x))-repCols n x = fromColumns (replicate n (flatten x))--size m = (rows m, cols m)--shSize m = "(" ++ show (rows m) ++"><"++ show (cols m)++")"--emptyM r c = matrixFromVector RowMajor r c (fromList[])--------------------------------------------------------------------------instance (Storable t, NFData t) => NFData (Matrix t)- where- rnf m | d > 0 = rnf (v @> 0)- | otherwise = ()- where- d = dim v- v = xdat m-
− src/Data/Packed/Internal/Numeric.hs
@@ -1,720 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Packed.Internal.Numeric--- Copyright : (c) Alberto Ruiz 2010-14--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional-----------------------------------------------------------------------------------module Data.Packed.Internal.Numeric (- -- * Basic functions- ident, diag, ctrans,- -- * Generic operations- Container(..),- scalar, conj, scale, arctan2, cmap,- atIndex, minIndex, maxIndex, minElement, maxElement,- sumElements, prodElements,- step, cond, find, assoc, accum,- Transposable(..), Linear(..), Testable(..),- -- * Matrix product and related functions- Product(..), udot,- mXm,mXv,vXm,- outer, kronecker,- -- * sorting- sortVector,- -- * Element conversion- Convert(..),- Complexable(),- RealElement(),- roundVector,- RealOf, ComplexOf, SingleOf, DoubleOf,- IndexOf,- module Data.Complex-) where--import Data.Packed-import Data.Packed.ST as ST-import Numeric.Conversion-import Data.Packed.Development-import Numeric.Vectorized-import Data.Complex-import Control.Applicative((<*>))--import Numeric.LinearAlgebra.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ)-import Data.Packed.Internal-----------------------------------------------------------------------type family IndexOf (c :: * -> *)--type instance IndexOf Vector = Int-type instance IndexOf Matrix = (Int,Int)--type family ArgOf (c :: * -> *) a--type instance ArgOf Vector a = a -> a-type instance ArgOf Matrix a = a -> a -> a------------------------------------------------------------------------- | Basic element-by-element functions for numeric containers-class (Complexable c, Fractional e, Element e) => Container c e- where- size' :: c e -> IndexOf c- scalar' :: e -> c e- conj' :: c e -> c e- scale' :: e -> c e -> c e- -- | scale the element by element reciprocal of the object:- --- -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@- scaleRecip :: e -> c e -> c e- addConstant :: e -> c e -> c e- add :: c e -> c e -> c e- sub :: c e -> c e -> c e- -- | element by element multiplication- mul :: c e -> c e -> c e- -- | element by element division- divide :: c e -> c e -> c e- equal :: c e -> c e -> Bool- --- -- element by element inverse tangent- arctan2' :: c e -> c e -> c e- cmap' :: (Element b) => (e -> b) -> c e -> c b- konst' :: e -> IndexOf c -> c e- build' :: IndexOf c -> (ArgOf c e) -> c e- atIndex' :: c e -> IndexOf c -> e- minIndex' :: c e -> IndexOf c- maxIndex' :: c e -> IndexOf c- minElement' :: c e -> e- maxElement' :: c e -> e- sumElements' :: c e -> e- prodElements' :: c e -> e- step' :: RealElement e => c e -> c e- cond' :: RealElement e- => c e -- ^ a- -> c e -- ^ b- -> c e -- ^ l- -> c e -- ^ e- -> c e -- ^ g- -> c e -- ^ result- find' :: (e -> Bool) -> c e -> [IndexOf c]- assoc' :: IndexOf c -- ^ size- -> e -- ^ default value- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result- accum' :: c e -- ^ initial structure- -> (e -> e -> e) -- ^ update function- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result------------------------------------------------------------------------------instance Container Vector Float- where- size' = dim- scale' = vectorMapValF Scale- scaleRecip = vectorMapValF Recip- addConstant = vectorMapValF AddConstant- add = vectorZipF Add- sub = vectorZipF Sub- mul = vectorZipF Mul- divide = vectorZipF Div- equal u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0- arctan2' = vectorZipF ATan2- scalar' x = fromList [x]- konst' = constantD- build' = buildV- conj' = id- cmap' = mapVector- atIndex' = (@>)- minIndex' = emptyErrorV "minIndex" (round . toScalarF MinIdx)- maxIndex' = emptyErrorV "maxIndex" (round . toScalarF MaxIdx)- minElement' = emptyErrorV "minElement" (toScalarF Min)- maxElement' = emptyErrorV "maxElement" (toScalarF Max)- sumElements' = sumF- prodElements' = prodF- step' = stepF- find' = findV- assoc' = assocV- accum' = accumV- cond' = condV condF--instance Container Vector Double- where- size' = dim- scale' = vectorMapValR Scale- scaleRecip = vectorMapValR Recip- addConstant = vectorMapValR AddConstant- add = vectorZipR Add- sub = vectorZipR Sub- mul = vectorZipR Mul- divide = vectorZipR Div- equal u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0- arctan2' = vectorZipR ATan2- scalar' x = fromList [x]- konst' = constantD- build' = buildV- conj' = id- cmap' = mapVector- atIndex' = (@>)- minIndex' = emptyErrorV "minIndex" (round . toScalarR MinIdx)- maxIndex' = emptyErrorV "maxIndex" (round . toScalarR MaxIdx)- minElement' = emptyErrorV "minElement" (toScalarR Min)- maxElement' = emptyErrorV "maxElement" (toScalarR Max)- sumElements' = sumR- prodElements' = prodR- step' = stepD- find' = findV- assoc' = assocV- accum' = accumV- cond' = condV condD--instance Container Vector (Complex Double)- where- size' = dim- scale' = vectorMapValC Scale- scaleRecip = vectorMapValC Recip- addConstant = vectorMapValC AddConstant- add = vectorZipC Add- sub = vectorZipC Sub- mul = vectorZipC Mul- divide = vectorZipC Div- equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0- arctan2' = vectorZipC ATan2- scalar' x = fromList [x]- konst' = constantD- build' = buildV- conj' = conjugateC- cmap' = mapVector- atIndex' = (@>)- minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))- maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))- minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')- maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')- sumElements' = sumC- prodElements' = prodC- step' = undefined -- cannot match- find' = findV- assoc' = assocV- accum' = accumV- cond' = undefined -- cannot match--instance Container Vector (Complex Float)- where- size' = dim- scale' = vectorMapValQ Scale- scaleRecip = vectorMapValQ Recip- addConstant = vectorMapValQ AddConstant- add = vectorZipQ Add- sub = vectorZipQ Sub- mul = vectorZipQ Mul- divide = vectorZipQ Div- equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0- arctan2' = vectorZipQ ATan2- scalar' x = fromList [x]- konst' = constantD- build' = buildV- conj' = conjugateQ- cmap' = mapVector- atIndex' = (@>)- minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))- maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))- minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')- maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')- sumElements' = sumQ- prodElements' = prodQ- step' = undefined -- cannot match- find' = findV- assoc' = assocV- accum' = accumV- cond' = undefined -- cannot match-------------------------------------------------------------------instance (Container Vector a) => Container Matrix a- where- size' = size- scale' x = liftMatrix (scale' x)- scaleRecip x = liftMatrix (scaleRecip x)- addConstant x = liftMatrix (addConstant x)- add = liftMatrix2 add- sub = liftMatrix2 sub- mul = liftMatrix2 mul- divide = liftMatrix2 divide- equal a b = cols a == cols b && flatten a `equal` flatten b- arctan2' = liftMatrix2 arctan2'- scalar' x = (1><1) [x]- konst' v (r,c) = matrixFromVector RowMajor r c (konst' v (r*c))- build' = buildM- conj' = liftMatrix conj'- cmap' f = liftMatrix (mapVector f)- atIndex' = (@@>)- minIndex' = emptyErrorM "minIndex of Matrix" $- \m -> divMod (minIndex' $ flatten m) (cols m)- maxIndex' = emptyErrorM "maxIndex of Matrix" $- \m -> divMod (maxIndex' $ flatten m) (cols m)- minElement' = emptyErrorM "minElement of Matrix" (atIndex' <*> minIndex')- maxElement' = emptyErrorM "maxElement of Matrix" (atIndex' <*> maxIndex')- sumElements' = sumElements . flatten- prodElements' = prodElements . flatten- step' = liftMatrix step- find' = findM- assoc' = assocM- accum' = accumM- cond' = condM---emptyErrorV msg f v =- if dim v > 0- then f v- else error $ msg ++ " of Vector with dim = 0"--emptyErrorM msg f m =- if rows m > 0 && cols m > 0- then f m- else error $ msg++" "++shSize m-------------------------------------------------------------------------------------- | create a structure with a single element------ >>> let v = fromList [1..3::Double]--- >>> v / scalar (norm2 v)--- fromList [0.2672612419124244,0.5345224838248488,0.8017837257372732]----scalar :: Container c e => e -> c e-scalar = scalar'---- | complex conjugate-conj :: Container c e => c e -> c e-conj = conj'---- | multiplication by scalar-scale :: Container c e => e -> c e -> c e-scale = scale'--arctan2 :: Container c e => c e -> c e -> c e-arctan2 = arctan2'---- | like 'fmap' (cannot implement instance Functor because of Element class constraint)-cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b-cmap = cmap'---- | indexing function-atIndex :: Container c e => c e -> IndexOf c -> e-atIndex = atIndex'---- | index of minimum element-minIndex :: Container c e => c e -> IndexOf c-minIndex = minIndex'---- | index of maximum element-maxIndex :: Container c e => c e -> IndexOf c-maxIndex = maxIndex'---- | value of minimum element-minElement :: Container c e => c e -> e-minElement = minElement'---- | value of maximum element-maxElement :: Container c e => c e -> e-maxElement = maxElement'---- | the sum of elements-sumElements :: Container c e => c e -> e-sumElements = sumElements'---- | the product of elements-prodElements :: Container c e => c e -> e-prodElements = prodElements'----- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@------ >>> step $ linspace 5 (-1,1::Double)--- 5 |> [0.0,0.0,0.0,1.0,1.0]----step- :: (RealElement e, Container c e)- => c e- -> c e-step = step'----- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@.------ Arguments with any dimension = 1 are automatically expanded:------ >>> cond ((1><4)[1..]) ((3><1)[1..]) 0 100 ((3><4)[1..]) :: Matrix Double--- (3><4)--- [ 100.0, 2.0, 3.0, 4.0--- , 0.0, 100.0, 7.0, 8.0--- , 0.0, 0.0, 100.0, 12.0 ]----cond- :: (RealElement e, Container c e)- => c e -- ^ a- -> c e -- ^ b- -> c e -- ^ l- -> c e -- ^ e- -> c e -- ^ g- -> c e -- ^ result-cond = cond'----- | Find index of elements which satisfy a predicate------ >>> find (>0) (ident 3 :: Matrix Double)--- [(0,0),(1,1),(2,2)]----find- :: Container c e- => (e -> Bool)- -> c e- -> [IndexOf c]-find = find'----- | Create a structure from an association list------ >>> assoc 5 0 [(3,7),(1,4)] :: Vector Double--- fromList [0.0,4.0,0.0,7.0,0.0]------ >>> assoc (2,3) 0 [((0,2),7),((1,0),2*i-3)] :: Matrix (Complex Double)--- (2><3)--- [ 0.0 :+ 0.0, 0.0 :+ 0.0, 7.0 :+ 0.0--- , (-3.0) :+ 2.0, 0.0 :+ 0.0, 0.0 :+ 0.0 ]----assoc- :: Container c e- => IndexOf c -- ^ size- -> e -- ^ default value- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result-assoc = assoc'----- | Modify a structure using an update function------ >>> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double--- (5><5)--- [ 1.0, 0.0, 0.0, 3.0, 0.0--- , 0.0, 6.0, 0.0, 0.0, 0.0--- , 0.0, 0.0, 1.0, 0.0, 0.0--- , 0.0, 0.0, 0.0, 1.0, 0.0--- , 0.0, 0.0, 0.0, 0.0, 1.0 ]------ computation of histogram:------ >>> accum (konst 0 7) (+) (map (flip (,) 1) [4,5,4,1,5,2,5]) :: Vector Double--- fromList [0.0,1.0,1.0,0.0,2.0,3.0,0.0]----accum- :: Container c e- => c e -- ^ initial structure- -> (e -> e -> e) -- ^ update function- -> [(IndexOf c, e)] -- ^ association list- -> c e -- ^ result-accum = accum'--------------------------------------------------------------------------------------- | Matrix product and related functions-class (Num e, Element e) => Product e where- -- | matrix product- multiply :: Matrix e -> Matrix e -> Matrix e- -- | sum of absolute value of elements (differs in complex case from @norm1@)- absSum :: Vector e -> RealOf e- -- | sum of absolute value of elements- norm1 :: Vector e -> RealOf e- -- | euclidean norm- norm2 :: Vector e -> RealOf e- -- | element of maximum magnitude- normInf :: Vector e -> RealOf e--instance Product Float where- norm2 = emptyVal (toScalarF Norm2)- absSum = emptyVal (toScalarF AbsSum)- norm1 = emptyVal (toScalarF AbsSum)- normInf = emptyVal (maxElement . vectorMapF Abs)- multiply = emptyMul multiplyF--instance Product Double where- norm2 = emptyVal (toScalarR Norm2)- absSum = emptyVal (toScalarR AbsSum)- norm1 = emptyVal (toScalarR AbsSum)- normInf = emptyVal (maxElement . vectorMapR Abs)- multiply = emptyMul multiplyR--instance Product (Complex Float) where- norm2 = emptyVal (toScalarQ Norm2)- absSum = emptyVal (toScalarQ AbsSum)- norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapQ Abs)- normInf = emptyVal (maxElement . fst . fromComplex . vectorMapQ Abs)- multiply = emptyMul multiplyQ--instance Product (Complex Double) where- norm2 = emptyVal (toScalarC Norm2)- absSum = emptyVal (toScalarC AbsSum)- norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapC Abs)- normInf = emptyVal (maxElement . fst . fromComplex . vectorMapC Abs)- multiply = emptyMul multiplyC--emptyMul m a b- | x1 == 0 && x2 == 0 || r == 0 || c == 0 = konst' 0 (r,c)- | otherwise = m a b- where- r = rows a- x1 = cols a- x2 = rows b- c = cols b--emptyVal f v =- if dim v > 0- then f v- else 0---- FIXME remove unused C wrappers--- | unconjugated dot product-udot :: Product e => Vector e -> Vector e -> e-udot u v- | dim u == dim v = val (asRow u `multiply` asColumn v)- | otherwise = error $ "different dimensions "++show (dim u)++" and "++show (dim v)++" in dot product"- where- val m | dim u > 0 = m@@>(0,0)- | otherwise = 0---------------------------------------------------------------- synonym for matrix product-mXm :: Product t => Matrix t -> Matrix t -> Matrix t-mXm = multiply---- matrix - vector product-mXv :: Product t => Matrix t -> Vector t -> Vector t-mXv m v = flatten $ m `mXm` (asColumn v)---- vector - matrix product-vXm :: Product t => Vector t -> Matrix t -> Vector t-vXm v m = flatten $ (asRow v) `mXm` m--{- | Outer product of two vectors.-->>> fromList [1,2,3] `outer` fromList [5,2,3]-(3><3)- [ 5.0, 2.0, 3.0- , 10.0, 4.0, 6.0- , 15.0, 6.0, 9.0 ]---}-outer :: (Product t) => Vector t -> Vector t -> Matrix t-outer u v = asColumn u `multiply` asRow v--{- | Kronecker product of two matrices.--@m1=(2><3)- [ 1.0, 2.0, 0.0- , 0.0, -1.0, 3.0 ]-m2=(4><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0- , 7.0, 8.0, 9.0- , 10.0, 11.0, 12.0 ]@-->>> kronecker m1 m2-(8><9)- [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0- , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0- , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0- , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0- , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0- , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0- , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0- , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ]---}-kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t-kronecker a b = fromBlocks- . splitEvery (cols a)- . map (reshape (cols b))- . toRows- $ flatten a `outer` flatten b------------------------------------------------------------------------class Convert t where- real :: Container c t => c (RealOf t) -> c t- complex :: Container c t => c t -> c (ComplexOf t)- single :: Container c t => c t -> c (SingleOf t)- double :: Container c t => c t -> c (DoubleOf t)- toComplex :: (Container c t, RealElement t) => (c t, c t) -> c (Complex t)- fromComplex :: (Container c t, RealElement t) => c (Complex t) -> (c t, c t)---instance Convert Double where- real = id- complex = comp'- single = single'- double = id- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert Float where- real = id- complex = comp'- single = id- double = double'- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert (Complex Double) where- real = comp'- complex = id- single = single'- double = id- toComplex = toComplex'- fromComplex = fromComplex'--instance Convert (Complex Float) where- real = comp'- complex = id- single = id- double = double'- toComplex = toComplex'- fromComplex = fromComplex'-----------------------------------------------------------------------type family RealOf x--type instance RealOf Double = Double-type instance RealOf (Complex Double) = Double--type instance RealOf Float = Float-type instance RealOf (Complex Float) = Float--type family ComplexOf x--type instance ComplexOf Double = Complex Double-type instance ComplexOf (Complex Double) = Complex Double--type instance ComplexOf Float = Complex Float-type instance ComplexOf (Complex Float) = Complex Float--type family SingleOf x--type instance SingleOf Double = Float-type instance SingleOf Float = Float--type instance SingleOf (Complex a) = Complex (SingleOf a)--type family DoubleOf x--type instance DoubleOf Double = Double-type instance DoubleOf Float = Double--type instance DoubleOf (Complex a) = Complex (DoubleOf a)--type family ElementOf c--type instance ElementOf (Vector a) = a-type instance ElementOf (Matrix a) = a----------------------------------------------------------------buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ]- where rs = map fromIntegral [0 .. (rc-1)]- cs = map fromIntegral [0 .. (cc-1)]--buildV n f = fromList [f k | k <- ks]- where ks = map fromIntegral [0 .. (n-1)]------------------------------------------------------------- | conjugate transpose-ctrans :: (Container Vector e, Element e) => Matrix e -> Matrix e-ctrans = liftMatrix conj' . trans---- | Creates a square matrix with a given diagonal.-diag :: (Num a, Element a) => Vector a -> Matrix a-diag v = diagRect 0 v n n where n = dim v---- | creates the identity matrix of given dimension-ident :: (Num a, Element a) => Int -> Matrix a-ident n = diag (constantD 1 n)------------------------------------------------------------findV p x = foldVectorWithIndex g [] x where- g k z l = if p z then k:l else l--findM p x = map ((`divMod` cols x)) $ findV p (flatten x)--assocV n z xs = ST.runSTVector $ do- v <- ST.newVector z n- mapM_ (\(k,x) -> ST.writeVector v k x) xs- return v--assocM (r,c) z xs = ST.runSTMatrix $ do- m <- ST.newMatrix z r c- mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs- return m--accumV v0 f xs = ST.runSTVector $ do- v <- ST.thawVector v0- mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs- return v--accumM m0 f xs = ST.runSTMatrix $ do- m <- ST.thawMatrix m0- mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs- return m--------------------------------------------------------------------------condM a b l e t = matrixFromVector RowMajor (rows a'') (cols a'') $ cond a' b' l' e' t'- where- args@(a'':_) = conformMs [a,b,l,e,t]- [a', b', l', e', t'] = map flatten args--condV f a b l e t = f a' b' l' e' t'- where- [a', b', l', e', t'] = conformVs [a,b,l,e,t]------------------------------------------------------------------------------------class Transposable m mt | m -> mt, mt -> m- where- -- | (conjugate) transpose- tr :: m -> mt--instance (Container Vector t) => Transposable (Matrix t) (Matrix t)- where- tr = ctrans--class Linear t v- where- scalarL :: t -> v- addL :: v -> v -> v- scaleL :: t -> v -> v---class Testable t- where- checkT :: t -> (Bool, IO())- ioCheckT :: t -> IO (Bool, IO())- ioCheckT = return . checkT-----------------------------------------------------------------------------------
− src/Data/Packed/Internal/Signatures.hs
@@ -1,70 +0,0 @@--- |--- Module : Data.Packed.Internal.Signatures--- Copyright : (c) Alberto Ruiz 2009--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Signatures of the C functions.------module Data.Packed.Internal.Signatures where--import Foreign.Ptr(Ptr)-import Data.Complex(Complex)-import Foreign.C.Types(CInt)--type PF = Ptr Float ---type PD = Ptr Double ---type PQ = Ptr (Complex Float) ---type PC = Ptr (Complex Double) ---type TF = CInt -> PF -> IO CInt ---type TFF = CInt -> PF -> TF ---type TFV = CInt -> PF -> TV ---type TVF = CInt -> PD -> TF ---type TFFF = CInt -> PF -> TFF ---type TV = CInt -> PD -> IO CInt ---type TVV = CInt -> PD -> TV ---type TVVV = CInt -> PD -> TVV ---type TFM = CInt -> CInt -> PF -> IO CInt ---type TFMFM = CInt -> CInt -> PF -> TFM ---type TFMFMFM = CInt -> CInt -> PF -> TFMFM ---type TM = CInt -> CInt -> PD -> IO CInt ---type TMM = CInt -> CInt -> PD -> TM ---type TVMM = CInt -> PD -> TMM ---type TMVMM = CInt -> CInt -> PD -> TVMM ---type TMMM = CInt -> CInt -> PD -> TMM ---type TVM = CInt -> PD -> TM ---type TVVM = CInt -> PD -> TVM ---type TMV = CInt -> CInt -> PD -> TV ---type TMMV = CInt -> CInt -> PD -> TMV ---type TMVM = CInt -> CInt -> PD -> TVM ---type TMMVM = CInt -> CInt -> PD -> TMVM ---type TCM = CInt -> CInt -> PC -> IO CInt ---type TCVCM = CInt -> PC -> TCM ---type TCMCVCM = CInt -> CInt -> PC -> TCVCM ---type TMCMCVCM = CInt -> CInt -> PD -> TCMCVCM ---type TCMCMCVCM = CInt -> CInt -> PC -> TCMCVCM ---type TCMCM = CInt -> CInt -> PC -> TCM ---type TVCM = CInt -> PD -> TCM ---type TCMVCM = CInt -> CInt -> PC -> TVCM ---type TCMCMVCM = CInt -> CInt -> PC -> TCMVCM ---type TCMCMCM = CInt -> CInt -> PC -> TCMCM ---type TCV = CInt -> PC -> IO CInt ---type TCVCV = CInt -> PC -> TCV ---type TCVCVCV = CInt -> PC -> TCVCV ---type TCVV = CInt -> PC -> TV ---type TQV = CInt -> PQ -> IO CInt ---type TQVQV = CInt -> PQ -> TQV ---type TQVQVQV = CInt -> PQ -> TQVQV ---type TQVF = CInt -> PQ -> TF ---type TQM = CInt -> CInt -> PQ -> IO CInt ---type TQMQM = CInt -> CInt -> PQ -> TQM ---type TQMQMQM = CInt -> CInt -> PQ -> TQMQM ---type TCMCV = CInt -> CInt -> PC -> TCV ---type TVCV = CInt -> PD -> TCV ---type TCVM = CInt -> PC -> TM ---type TMCVM = CInt -> CInt -> PD -> TCVM ---type TMMCVM = CInt -> CInt -> PD -> TMCVM ---
− src/Data/Packed/Internal/Vector.hs
@@ -1,471 +0,0 @@-{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-}--- |--- Module : Data.Packed.Internal.Vector--- Copyright : (c) Alberto Ruiz 2007--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Vector implementation--------------------------------------------------------------------------------------module Data.Packed.Internal.Vector (- Vector, dim,- fromList, toList, (|>),- vjoin, (@>), safe, at, at', subVector, takesV,- mapVector, mapVectorWithIndex, zipVectorWith, unzipVectorWith,- mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,- foldVector, foldVectorG, foldLoop, foldVectorWithIndex,- createVector, vec,- asComplex, asReal, float2DoubleV, double2FloatV,- stepF, stepD, condF, condD,- conjugateQ, conjugateC,- cloneVector,- unsafeToForeignPtr,- unsafeFromForeignPtr,- unsafeWith-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Foreign.Marshal.Array(peekArray, copyArray, advancePtr)-import Foreign.ForeignPtr(ForeignPtr, castForeignPtr)-import Foreign.Ptr(Ptr)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff, sizeOf)-import Foreign.C.Types-import Data.Complex-import Control.Monad(when)-import System.IO.Unsafe(unsafePerformIO)--#if __GLASGOW_HASKELL__ >= 605-import GHC.ForeignPtr (mallocPlainForeignPtrBytes)-#else-import Foreign.ForeignPtr (mallocForeignPtrBytes)-#endif--import GHC.Base-#if __GLASGOW_HASKELL__ < 612-import GHC.IOBase hiding (liftIO)-#endif--import qualified Data.Vector.Storable as Vector-import Data.Vector.Storable(Vector,- fromList,- unsafeToForeignPtr,- unsafeFromForeignPtr,- unsafeWith)----- | Number of elements-dim :: (Storable t) => Vector t -> Int-dim = Vector.length----- C-Haskell vector adapter--- vec :: Adapt (CInt -> Ptr t -> r) (Vector t) r-vec :: (Storable t) => Vector t -> (((CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b-vec x f = unsafeWith x $ \p -> do- let v g = do- g (fi $ dim x) p- f v-{-# INLINE vec #-}----- allocates memory for a new vector-createVector :: Storable a => Int -> IO (Vector a)-createVector n = do- when (n < 0) $ error ("trying to createVector of negative dim: "++show n)- fp <- doMalloc undefined- return $ unsafeFromForeignPtr fp 0 n- where- --- -- Use the much cheaper Haskell heap allocated storage- -- for foreign pointer space we control- --- doMalloc :: Storable b => b -> IO (ForeignPtr b)- doMalloc dummy = do-#if __GLASGOW_HASKELL__ >= 605- mallocPlainForeignPtrBytes (n * sizeOf dummy)-#else- mallocForeignPtrBytes (n * sizeOf dummy)-#endif--{- | creates a Vector from a list:--@> fromList [2,3,5,7]-4 |> [2.0,3.0,5.0,7.0]@---}--safeRead v = inlinePerformIO . unsafeWith v-{-# INLINE safeRead #-}--inlinePerformIO :: IO a -> a-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r-{-# INLINE inlinePerformIO #-}--{- | extracts the Vector elements to a list-->>> toList (linspace 5 (1,10))-[1.0,3.25,5.5,7.75,10.0]---}-toList :: Storable a => Vector a -> [a]-toList v = safeRead v $ peekArray (dim v)--{- | Create a vector from a list of elements and explicit dimension. The input- list is explicitly truncated if it is too long, so it may safely- be used, for instance, with infinite lists.-->>> 5 |> [1..]-fromList [1.0,2.0,3.0,4.0,5.0]---}-(|>) :: (Storable a) => Int -> [a] -> Vector a-infixl 9 |>-n |> l = if length l' == n- then fromList l'- else error "list too short for |>"- where l' = take n l----- | access to Vector elements without range checking-at' :: Storable a => Vector a -> Int -> a-at' v n = safeRead v $ flip peekElemOff n-{-# INLINE at' #-}------- turn off bounds checking with -funsafe at configure time.--- ghc will optimise away the salways true case at compile time.----#if defined(UNSAFE)-safe :: Bool-safe = False-#else-safe = True-#endif---- | access to Vector elements with range checking.-at :: Storable a => Vector a -> Int -> a-at v n- | safe = if n >= 0 && n < dim v- then at' v n- else error "vector index out of range"- | otherwise = at' v n-{-# INLINE at #-}--{- | takes a number of consecutive elements from a Vector-->>> subVector 2 3 (fromList [1..10])-fromList [3.0,4.0,5.0]---}-subVector :: Storable t => Int -- ^ index of the starting element- -> Int -- ^ number of elements to extract- -> Vector t -- ^ source- -> Vector t -- ^ result-subVector = Vector.slice---{- | Reads a vector position:-->>> fromList [0..9] @> 7-7.0---}-(@>) :: Storable t => Vector t -> Int -> t-infixl 9 @>-(@>) = at---{- | concatenate a list of vectors-->>> vjoin [fromList [1..5::Double], konst 1 3]-fromList [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]---}-vjoin :: Storable t => [Vector t] -> Vector t-vjoin [] = fromList []-vjoin [v] = v-vjoin as = unsafePerformIO $ do- let tot = sum (map dim as)- r <- createVector tot- unsafeWith r $ \ptr ->- joiner as tot ptr- return r- where joiner [] _ _ = return ()- joiner (v:cs) _ p = do- let n = dim v- unsafeWith v $ \pb -> copyArray p pb n- joiner cs 0 (advancePtr p n)---{- | Extract consecutive subvectors of the given sizes.-->>> takesV [3,4] (linspace 10 (1,10::Double))-[fromList [1.0,2.0,3.0],fromList [4.0,5.0,6.0,7.0]]---}-takesV :: Storable t => [Int] -> Vector t -> [Vector t]-takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)- | otherwise = go ms w- where go [] _ = []- go (n:ns) v = subVector 0 n v- : go ns (subVector n (dim v - n) v)--------------------------------------------------------------------- | transforms a complex vector into a real vector with alternating real and imaginary parts -asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a-asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)- where (fp,i,n) = unsafeToForeignPtr v---- | transforms a real vector into a complex vector with alternating real and imaginary parts-asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)-asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)- where (fp,i,n) = unsafeToForeignPtr v-------------------------------------------------------------------float2DoubleV :: Vector Float -> Vector Double-float2DoubleV v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_float2double vec v vec r "float2double"- return r--double2FloatV :: Vector Double -> Vector Float-double2FloatV v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_double2float vec v vec r "double2float2"- return r---foreign import ccall unsafe "float2double" c_float2double:: TFV-foreign import ccall unsafe "double2float" c_double2float:: TVF-------------------------------------------------------------------stepF :: Vector Float -> Vector Float-stepF v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_stepF vec v vec r "stepF"- return r--stepD :: Vector Double -> Vector Double-stepD v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_stepD vec v vec r "stepD"- return r--foreign import ccall unsafe "stepF" c_stepF :: TFF-foreign import ccall unsafe "stepD" c_stepD :: TVV-------------------------------------------------------------------condF :: Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float-condF x y l e g = unsafePerformIO $ do- r <- createVector (dim x)- app6 c_condF vec x vec y vec l vec e vec g vec r "condF"- return r--condD :: Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double-condD x y l e g = unsafePerformIO $ do- r <- createVector (dim x)- app6 c_condD vec x vec y vec l vec e vec g vec r "condD"- return r--foreign import ccall unsafe "condF" c_condF :: CInt -> PF -> CInt -> PF -> CInt -> PF -> TFFF-foreign import ccall unsafe "condD" c_condD :: CInt -> PD -> CInt -> PD -> CInt -> PD -> TVVV------------------------------------------------------------------------------------conjugateAux fun x = unsafePerformIO $ do- v <- createVector (dim x)- app2 fun vec x vec v "conjugateAux"- return v--conjugateQ :: Vector (Complex Float) -> Vector (Complex Float)-conjugateQ = conjugateAux c_conjugateQ-foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TQVQV--conjugateC :: Vector (Complex Double) -> Vector (Complex Double)-conjugateC = conjugateAux c_conjugateC-foreign import ccall unsafe "conjugateC" c_conjugateC :: TCVCV------------------------------------------------------------------------------------cloneVector :: Storable t => Vector t -> IO (Vector t)-cloneVector v = do- let n = dim v- r <- createVector n- let f _ s _ d = copyArray d s n >> return 0- app2 f vec v vec r "cloneVector"- return r------------------------------------------------------------------------ | map on Vectors-mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b-mapVector f v = unsafePerformIO $ do- w <- createVector (dim v)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) = return ()- go !k = do x <- peekElemOff p k- pokeElemOff q k (f x)- go (k-1)- go (dim v -1)- return w-{-# INLINE mapVector #-}---- | zipWith for Vectors-zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c-zipVectorWith f u v = unsafePerformIO $ do- let n = min (dim u) (dim v)- w <- createVector n- unsafeWith u $ \pu ->- unsafeWith v $ \pv ->- unsafeWith w $ \pw -> do- let go (-1) = return ()- go !k = do x <- peekElemOff pu k- y <- peekElemOff pv k- pokeElemOff pw k (f x y)- go (k-1)- go (n -1)- return w-{-# INLINE zipVectorWith #-}---- | unzipWith for Vectors-unzipVectorWith :: (Storable (a,b), Storable c, Storable d) - => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)-unzipVectorWith f u = unsafePerformIO $ do- let n = dim u- v <- createVector n- w <- createVector n- unsafeWith u $ \pu ->- unsafeWith v $ \pv ->- unsafeWith w $ \pw -> do- let go (-1) = return ()- go !k = do z <- peekElemOff pu k- let (x,y) = f z - pokeElemOff pv k x- pokeElemOff pw k y- go (k-1)- go (n-1)- return (v,w)-{-# INLINE unzipVectorWith #-}--foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b-foldVector f x v = unsafePerformIO $- unsafeWith v $ \p -> do- let go (-1) s = return s- go !k !s = do y <- peekElemOff p k- go (k-1::Int) (f y s)- go (dim v -1) x-{-# INLINE foldVector #-}---- the zero-indexed index is passed to the folding function-foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b-foldVectorWithIndex f x v = unsafePerformIO $- unsafeWith v $ \p -> do- let go (-1) s = return s- go !k !s = do y <- peekElemOff p k- go (k-1::Int) (f k y s)- go (dim v -1) x-{-# INLINE foldVectorWithIndex #-}--foldLoop f s0 d = go (d - 1) s0- where- go 0 s = f (0::Int) s- go !j !s = go (j - 1) (f j s)--foldVectorG f s0 v = foldLoop g s0 (dim v)- where g !k !s = f k (at' v) s- {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)-{-# INLINE foldVectorG #-}------------------------------------------------------------------------- | monadic map over Vectors--- the monad @m@ must be strict-mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)-mapVectorM f v = do- w <- return $! unsafePerformIO $! createVector (dim v)- mapVectorM' w 0 (dim v -1)- return w- where mapVectorM' w' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f x- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f x- _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- mapVectorM' w' (k+1) t-{-# INLINE mapVectorM #-}---- | monadic map over Vectors-mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()-mapVectorM_ f v = do- mapVectorM' 0 (dim v -1)- where mapVectorM' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k- f x- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - _ <- f x- mapVectorM' (k+1) t-{-# INLINE mapVectorM_ #-}---- | monadic map over Vectors with the zero-indexed index passed to the mapping function--- the monad @m@ must be strict-mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)-mapVectorWithIndexM f v = do- w <- return $! unsafePerformIO $! createVector (dim v)- mapVectorM' w 0 (dim v -1)- return w- where mapVectorM' w' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f k x- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - y <- f k x- _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y- mapVectorM' w' (k+1) t-{-# INLINE mapVectorWithIndexM #-}---- | monadic map over Vectors with the zero-indexed index passed to the mapping function-mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()-mapVectorWithIndexM_ f v = do- mapVectorM' 0 (dim v -1)- where mapVectorM' !k !t- | k == t = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k- f k x- | otherwise = do- x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k - _ <- f k x- mapVectorM' (k+1) t-{-# INLINE mapVectorWithIndexM_ #-}---mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b---mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])-mapVectorWithIndex f v = unsafePerformIO $ do- w <- createVector (dim v)- unsafeWith v $ \p ->- unsafeWith w $ \q -> do- let go (-1) = return ()- go !k = do x <- peekElemOff p k- pokeElemOff q k (f k x)- go (k-1)- go (dim v -1)- return w-{-# INLINE mapVectorWithIndex #-}--
− src/Data/Packed/Matrix.hs
@@ -1,494 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module : Data.Packed.Matrix--- Copyright : (c) Alberto Ruiz 2007-10--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ A Matrix representation suitable for numerical computations using LAPACK and GSL.------ This module provides basic functions for manipulation of structure.--------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.Matrix (- Matrix,- Element,- rows,cols,- (><),- trans,- reshape, flatten,- fromLists, toLists, buildMatrix,- (@@>),- asRow, asColumn,- fromRows, toRows, fromColumns, toColumns,- fromBlocks, diagBlock, toBlocks, toBlocksEvery,- repmat,- flipud, fliprl,- subMatrix, takeRows, dropRows, takeColumns, dropColumns,- extractRows, extractColumns,- diagRect, takeDiag,- mapMatrix, mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_,- liftMatrix, liftMatrix2, liftMatrix2Auto,fromArray2D-) where--import Data.Packed.Internal-import qualified Data.Packed.ST as ST-import Data.Array--import Data.List(transpose,intersperse)-import Foreign.Storable(Storable)-import Control.Monad(liftM)-----------------------------------------------------------------------#ifdef BINARY--import Data.Binary--instance (Binary (Vector a), Element a) => Binary (Matrix a) where- put m = do- put (cols m)- put (flatten m)- get = do- c <- get- v <- get- return (reshape c v)--#endif-----------------------------------------------------------------------instance (Show a, Element a) => (Show (Matrix a)) where- show m | rows m == 0 || cols m == 0 = sizes m ++" []"- show m = (sizes m++) . dsp . map (map show) . toLists $ m--sizes m = "("++show (rows m)++"><"++show (cols m)++")\n"--dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp- where- mt = transpose as- longs = map (maximum . map length) mt- mtp = zipWith (\a b -> map (pad a) b) longs mt- pad n str = replicate (n - length str) ' ' ++ str- unwords' = concat . intersperse ", "----------------------------------------------------------------------instance (Element a, Read a) => Read (Matrix a) where- readsPrec _ s = [((rs><cs) . read $ listnums, rest)]- where (thing,rest) = breakAt ']' s- (dims,listnums) = breakAt ')' thing- cs = read . init . fst. breakAt ')' . snd . breakAt '<' $ dims- rs = read . snd . breakAt '(' .init . fst . breakAt '>' $ dims---breakAt c l = (a++[c],tail b) where- (a,b) = break (==c) l------------------------------------------------------------------------ | creates a matrix from a vertical list of matrices-joinVert :: Element t => [Matrix t] -> Matrix t-joinVert [] = emptyM 0 0-joinVert ms = case common cols ms of- Nothing -> error "(impossible) joinVert on matrices with different number of columns"- Just c -> matrixFromVector RowMajor (sum (map rows ms)) c $ vjoin (map flatten ms)---- | creates a matrix from a horizontal list of matrices-joinHoriz :: Element t => [Matrix t] -> Matrix t-joinHoriz ms = trans. joinVert . map trans $ ms--{- | Create a matrix from blocks given as a list of lists of matrices.--Single row-column components are automatically expanded to match the-corresponding common row and column:--@-disp = putStr . dispf 2-@-->>> disp $ fromBlocks [[ident 5, 7, row[10,20]], [3, diagl[1,2,3], 0]]-8x10-1 0 0 0 0 7 7 7 10 20-0 1 0 0 0 7 7 7 10 20-0 0 1 0 0 7 7 7 10 20-0 0 0 1 0 7 7 7 10 20-0 0 0 0 1 7 7 7 10 20-3 3 3 3 3 1 0 0 0 0-3 3 3 3 3 0 2 0 0 0-3 3 3 3 3 0 0 3 0 0---}-fromBlocks :: Element t => [[Matrix t]] -> Matrix t-fromBlocks = fromBlocksRaw . adaptBlocks--fromBlocksRaw mms = joinVert . map joinHoriz $ mms--adaptBlocks ms = ms' where- bc = case common length ms of- Just c -> c- Nothing -> error "fromBlocks requires rectangular [[Matrix]]"- rs = map (compatdim . map rows) ms- cs = map (compatdim . map cols) (transpose ms)- szs = sequence [rs,cs]- ms' = splitEvery bc $ zipWith g szs (concat ms)-- g [Just nr,Just nc] m- | nr == r && nc == c = m- | r == 1 && c == 1 = matrixFromVector RowMajor nr nc (constantD x (nr*nc))- | r == 1 = fromRows (replicate nr (flatten m))- | otherwise = fromColumns (replicate nc (flatten m))- where- r = rows m- c = cols m- x = m@@>(0,0)- g _ _ = error "inconsistent dimensions in fromBlocks"-------------------------------------------------------------------------------------{- | create a block diagonal matrix-->>> disp 2 $ diagBlock [konst 1 (2,2), konst 2 (3,5), col [5,7]]-7x8-1 1 0 0 0 0 0 0-1 1 0 0 0 0 0 0-0 0 2 2 2 2 2 0-0 0 2 2 2 2 2 0-0 0 2 2 2 2 2 0-0 0 0 0 0 0 0 5-0 0 0 0 0 0 0 7-->>> diagBlock [(0><4)[], konst 2 (2,3)] :: Matrix Double-(2><7)- [ 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0- , 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 ]---}-diagBlock :: (Element t, Num t) => [Matrix t] -> Matrix t-diagBlock ms = fromBlocks $ zipWith f ms [0..]- where- f m k = take n $ replicate k z ++ m : repeat z- n = length ms- z = (1><1) [0]--------------------------------------------------------------------------------------- | Reverse rows-flipud :: Element t => Matrix t -> Matrix t-flipud m = extractRows [r-1,r-2 .. 0] $ m- where- r = rows m---- | Reverse columns-fliprl :: Element t => Matrix t -> Matrix t-fliprl m = extractColumns [c-1,c-2 .. 0] $ m- where- c = cols m----------------------------------------------------------------{- | creates a rectangular diagonal matrix:-->>> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double-(4><5)- [ 10.0, 7.0, 7.0, 7.0, 7.0- , 7.0, 20.0, 7.0, 7.0, 7.0- , 7.0, 7.0, 30.0, 7.0, 7.0- , 7.0, 7.0, 7.0, 7.0, 7.0 ]---}-diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t-diagRect z v r c = ST.runSTMatrix $ do- m <- ST.newMatrix z r c- let d = min r c `min` (dim v)- mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1]- return m---- | extracts the diagonal from a rectangular matrix-takeDiag :: (Element t) => Matrix t -> Vector t-takeDiag m = fromList [flatten m `at` (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]]----------------------------------------------------------------{- | create a general matrix-->>> (2><3) [2, 4, 7+2*𝑖, -3, 11, 0]-(2><3)- [ 2.0 :+ 0.0, 4.0 :+ 0.0, 7.0 :+ 2.0- , (-3.0) :+ (-0.0), 11.0 :+ 0.0, 0.0 :+ 0.0 ]--The input list is explicitly truncated, so that it can-safely be used with lists that are too long (like infinite lists).-->>> (2><3)[1..]-(2><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0 ]--This is the format produced by the instances of Show (Matrix a), which-can also be used for input.---}-(><) :: (Storable a) => Int -> Int -> [a] -> Matrix a-r >< c = f where- f l | dim v == r*c = matrixFromVector RowMajor r c v- | otherwise = error $ "inconsistent list size = "- ++show (dim v) ++" in ("++show r++"><"++show c++")"- where v = fromList $ take (r*c) l---------------------------------------------------------------------- | Creates a matrix with the first n rows of another matrix-takeRows :: Element t => Int -> Matrix t -> Matrix t-takeRows n mt = subMatrix (0,0) (n, cols mt) mt--- | Creates a copy of a matrix without the first n rows-dropRows :: Element t => Int -> Matrix t -> Matrix t-dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt--- |Creates a matrix with the first n columns of another matrix-takeColumns :: Element t => Int -> Matrix t -> Matrix t-takeColumns n mt = subMatrix (0,0) (rows mt, n) mt--- | Creates a copy of a matrix without the first n columns-dropColumns :: Element t => Int -> Matrix t -> Matrix t-dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt--------------------------------------------------------------------{- | Creates a 'Matrix' from a list of lists (considered as rows).-->>> fromLists [[1,2],[3,4],[5,6]]-(3><2)- [ 1.0, 2.0- , 3.0, 4.0- , 5.0, 6.0 ]---}-fromLists :: Element t => [[t]] -> Matrix t-fromLists = fromRows . map fromList---- | creates a 1-row matrix from a vector------ >>> asRow (fromList [1..5])--- (1><5)--- [ 1.0, 2.0, 3.0, 4.0, 5.0 ]----asRow :: Storable a => Vector a -> Matrix a-asRow = trans . asColumn---- | creates a 1-column matrix from a vector------ >>> asColumn (fromList [1..5])--- (5><1)--- [ 1.0--- , 2.0--- , 3.0--- , 4.0--- , 5.0 ]----asColumn :: Storable a => Vector a -> Matrix a-asColumn v = reshape 1 v----{- | creates a Matrix of the specified size using the supplied function to- to map the row\/column position to the value at that row\/column position.--@> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c)-(3><4)- [ 0.0, 0.0, 0.0, 0.0, 0.0- , 0.0, 1.0, 2.0, 3.0, 4.0- , 0.0, 2.0, 4.0, 6.0, 8.0]@--Hilbert matrix of order N:--@hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@---}-buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a-buildMatrix rc cc f =- fromLists $ map (map f)- $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]---------------------------------------------------------fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e-fromArray2D m = (r><c) (elems m)- where ((r0,c0),(r1,c1)) = bounds m- r = r1-r0+1- c = c1-c0+1----- | rearranges the rows of a matrix according to the order given in a list of integers.-extractRows :: Element t => [Int] -> Matrix t -> Matrix t-extractRows [] m = emptyM 0 (cols m)-extractRows l m = fromRows $ extract (toRows m) l- where- extract l' is = [l'!!i | i<- map verify is]- verify k- | k >= 0 && k < rows m = k- | otherwise = error $ "can't extract row "- ++show k++" in list " ++ show l ++ " from matrix " ++ shSize m---- | rearranges the rows of a matrix according to the order given in a list of integers.-extractColumns :: Element t => [Int] -> Matrix t -> Matrix t-extractColumns l m = trans . extractRows (map verify l) . trans $ m- where- verify k- | k >= 0 && k < cols m = k- | otherwise = error $ "can't extract column "- ++show k++" in list " ++ show l ++ " from matrix " ++ shSize m----{- | creates matrix by repetition of a matrix a given number of rows and columns-->>> repmat (ident 2) 2 3-(4><6)- [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0- , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0- , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0- , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ]---}-repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t-repmat m r c- | r == 0 || c == 0 = emptyM (r*rows m) (c*cols m)- | otherwise = fromBlocks $ replicate r $ replicate c $ m---- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix.-liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t-liftMatrix2Auto f m1 m2- | compat' m1 m2 = lM f m1 m2- | ok = lM f m1' m2'- | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2- where- (r1,c1) = size m1- (r2,c2) = size m2- r = max r1 r2- c = max c1 c2- r0 = min r1 r2- c0 = min c1 c2- ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2- m1' = conformMTo (r,c) m1- m2' = conformMTo (r,c) m2---- FIXME do not flatten if equal order-lM f m1 m2 = matrixFromVector- RowMajor- (max (rows m1) (rows m2))- (max (cols m1) (cols m2))- (f (flatten m1) (flatten m2))--compat' :: Matrix a -> Matrix b -> Bool-compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2- where- s1 = size m1- s2 = size m2----------------------------------------------------------------toBlockRows [r] m- | r == rows m = [m]-toBlockRows rs m- | cols m > 0 = map (reshape (cols m)) (takesV szs (flatten m))- | otherwise = map g rs- where- szs = map (* cols m) rs- g k = (k><0)[]--toBlockCols [c] m | c == cols m = [m]-toBlockCols cs m = map trans . toBlockRows cs . trans $ m---- | Partition a matrix into blocks with the given numbers of rows and columns.--- The remaining rows and columns are discarded.-toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]]-toBlocks rs cs m- | ok = map (toBlockCols cs) . toBlockRows rs $ m- | otherwise = error $ "toBlocks: bad partition: "++show rs++" "++show cs- ++ " "++shSize m- where- ok = sum rs <= rows m && sum cs <= cols m && all (>=0) rs && all (>=0) cs---- | Fully partition a matrix into blocks of the same size. If the dimensions are not--- a multiple of the given size the last blocks will be smaller.-toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]]-toBlocksEvery r c m- | r < 1 || c < 1 = error $ "toBlocksEvery expects block sizes > 0, given "++show r++" and "++ show c- | otherwise = toBlocks rs cs m- where- (qr,rr) = rows m `divMod` r- (qc,rc) = cols m `divMod` c- rs = replicate qr r ++ if rr > 0 then [rr] else []- cs = replicate qc c ++ if rc > 0 then [rc] else []------------------------------------------------------------------------- Given a column number and a function taking matrix indexes, returns--- a function which takes vector indexes (that can be used on the--- flattened matrix).-mk :: Int -> ((Int, Int) -> t) -> (Int -> t)-mk c g = \k -> g (divMod k c)--{- |-->>> mapMatrixWithIndexM_ (\(i,j) v -> printf "m[%d,%d] = %.f\n" i j v :: IO()) ((2><3)[1 :: Double ..])-m[0,0] = 1-m[0,1] = 2-m[0,2] = 3-m[1,0] = 4-m[1,1] = 5-m[1,2] = 6---}-mapMatrixWithIndexM_- :: (Element a, Num a, Monad m) =>- ((Int, Int) -> a -> m ()) -> Matrix a -> m ()-mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m- where- c = cols m--{- |-->>> mapMatrixWithIndexM (\(i,j) v -> Just $ 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)-Just (3><3)- [ 100.0, 1.0, 2.0- , 10.0, 111.0, 12.0- , 20.0, 21.0, 122.0 ]---}-mapMatrixWithIndexM- :: (Element a, Storable b, Monad m) =>- ((Int, Int) -> a -> m b) -> Matrix a -> m (Matrix b)-mapMatrixWithIndexM g m = liftM (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m - where- c = cols m--{- |-->>> mapMatrixWithIndex (\\(i,j) v -> 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)-(3><3)- [ 100.0, 1.0, 2.0- , 10.0, 111.0, 12.0- , 20.0, 21.0, 122.0 ]-- -}-mapMatrixWithIndex- :: (Element a, Storable b) =>- ((Int, Int) -> a -> b) -> Matrix a -> Matrix b-mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m- where- c = cols m--mapMatrix :: (Storable a, Storable b) => (a -> b) -> Matrix a -> Matrix b-mapMatrix f = liftMatrix (mapVector f)
− src/Data/Packed/Numeric.hs
@@ -1,299 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Data.Packed.Numeric--- Copyright : (c) Alberto Ruiz 2010-14--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Basic numeric operations on 'Vector' and 'Matrix', including conversion routines.------ The 'Container' class is used to define optimized generic functions which work--- on 'Vector' and 'Matrix' with real or complex elements.------ Some of these functions are also available in the instances of the standard--- numeric Haskell classes provided by "Numeric.LinearAlgebra".----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.Numeric (- -- * Basic functions- module Data.Packed,- Konst(..), Build(..),- linspace,- diag, ident,- ctrans,- -- * Generic operations- Container(..), Numeric,- -- add, mul, sub, divide, equal, scaleRecip, addConstant,- scalar, conj, scale, arctan2, cmap,- atIndex, minIndex, maxIndex, minElement, maxElement,- sumElements, prodElements,- step, cond, find, assoc, accum,- Transposable(..), Linear(..),- -- * Matrix product- Product(..), udot, dot, (<·>), (#>), app,- Mul(..),- (<.>),- optimiseMult,- mXm,mXv,vXm,LSDiv,(<\>),- outer, kronecker,- -- * Random numbers- RandDist(..),- randomVector,- gaussianSample,- uniformSample,- meanCov,- -- * sorting- sortVector,- -- * Element conversion- Convert(..),- Complexable(),- RealElement(),- RealOf, ComplexOf, SingleOf, DoubleOf,- roundVector,- IndexOf,- module Data.Complex,- -- * IO- module Data.Packed.IO,- -- * Misc- Testable(..)-) where--import Data.Packed-import Data.Packed.Internal.Numeric-import Data.Complex-import Numeric.LinearAlgebra.Algorithms(Field,linearSolveSVD)-import Data.Monoid(Monoid(mconcat))-import Data.Packed.IO-import Numeric.LinearAlgebra.Random----------------------------------------------------------------------{- | Creates a real vector containing a range of values:-->>> linspace 5 (-3,7::Double)-fromList [-3.0,-0.5,2.0,4.5,7.0]@-->>> linspace 5 (8,2+i) :: Vector (Complex Double)-fromList [8.0 :+ 0.0,6.5 :+ 0.25,5.0 :+ 0.5,3.5 :+ 0.75,2.0 :+ 1.0]--Logarithmic spacing can be defined as follows:--@logspace n (a,b) = 10 ** linspace n (a,b)@--}-linspace :: (Container Vector e) => Int -> (e, e) -> Vector e-linspace 0 _ = fromList[]-linspace 1 (a,b) = fromList[(a+b)/2]-linspace n (a,b) = addConstant a $ scale s $ fromList $ map fromIntegral [0 .. n-1]- where s = (b-a)/fromIntegral (n-1)------------------------------------------------------------------------------------infixl 7 <.>--- | An infix synonym for 'dot'-(<.>) :: Numeric t => Vector t -> Vector t -> t-(<.>) = dot---infixr 8 <·>, #>--{- | infix synonym for 'dot'-->>> vector [1,2,3,4] <·> vector [-2,0,1,1]-5.0-->>> let 𝑖 = 0:+1 :: ℂ->>> fromList [1+𝑖,1] <·> fromList [1,1+𝑖]-2.0 :+ 0.0--(the dot symbol "·" is obtained by Alt-Gr .)---}-(<·>) :: Numeric t => Vector t -> Vector t -> t-(<·>) = dot---{- | infix synonym for 'app'-->>> let m = (2><3) [1..]->>> m-(2><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0 ]-->>> let v = vector [10,20,30]-->>> m #> v-fromList [140.0,320.0]---}-(#>) :: Numeric t => Matrix t -> Vector t -> Vector t-(#>) = mXv---- | dense matrix-vector product-app :: Numeric t => Matrix t -> Vector t -> Vector t-app = (#>)------------------------------------------------------------------------------------class Mul a b c | a b -> c where- infixl 7 <>- -- | Matrix-matrix, matrix-vector, and vector-matrix products.- (<>) :: Product t => a t -> b t -> c t--instance Mul Matrix Matrix Matrix where- (<>) = mXm--instance Mul Matrix Vector Vector where- (<>) m v = flatten $ m <> asColumn v--instance Mul Vector Matrix Vector where- (<>) v m = flatten $ asRow v <> m------------------------------------------------------------------------------------{- | Least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD)--@-a = (3><2)- [ 1.0, 2.0- , 2.0, 4.0- , 2.0, -1.0 ]-@--@-v = vector [13.0,27.0,1.0]-@-->>> let x = a <\> v->>> x-fromList [3.0799999999999996,5.159999999999999]-->>> a #> x-fromList [13.399999999999999,26.799999999999997,1.0]--It also admits multiple right-hand sides stored as columns in a matrix.---}-infixl 7 <\>-(<\>) :: (LSDiv c, Field t) => Matrix t -> c t -> c t-(<\>) = linSolve--class LSDiv c- where- linSolve :: Field t => Matrix t -> c t -> c t--instance LSDiv Vector- where- linSolve m v = flatten (linearSolveSVD m (reshape 1 v))--instance LSDiv Matrix- where- linSolve = linearSolveSVD------------------------------------------------------------------------------------class Konst e d c | d -> c, c -> d- where- -- |- -- >>> konst 7 3 :: Vector Float- -- fromList [7.0,7.0,7.0]- --- -- >>> konst i (3::Int,4::Int)- -- (3><4)- -- [ 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0- -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0- -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 ]- --- konst :: e -> d -> c e--instance Container Vector e => Konst e Int Vector- where- konst = konst'--instance Container Vector e => Konst e (Int,Int) Matrix- where- konst = konst'------------------------------------------------------------------------------------class Build d f c e | d -> c, c -> d, f -> e, f -> d, f -> c, c e -> f, d e -> f- where- -- |- -- >>> build 5 (**2) :: Vector Double- -- fromList [0.0,1.0,4.0,9.0,16.0]- --- -- Hilbert matrix of order N:- --- -- >>> let hilb n = build (n,n) (\i j -> 1/(i+j+1)) :: Matrix Double- -- >>> putStr . dispf 2 $ hilb 3- -- 3x3- -- 1.00 0.50 0.33- -- 0.50 0.33 0.25- -- 0.33 0.25 0.20- --- build :: d -> f -> c e--instance Container Vector e => Build Int (e -> e) Vector e- where- build = build'--instance Container Matrix e => Build (Int,Int) (e -> e -> e) Matrix e- where- build = build'-------------------------------------------------------------------------------------- @dot u v = 'udot' ('conj' u) v@-dot :: (Numeric t) => Vector t -> Vector t -> t-dot u v = udot (conj u) v------------------------------------------------------------------------------------optimiseMult :: Monoid (Matrix t) => [Matrix t] -> Matrix t-optimiseMult = mconcat-------------------------------------------------------------------------------------{- | Compute mean vector and covariance matrix of the rows of a matrix.-->>> meanCov $ gaussianSample 666 1000 (fromList[4,5]) (diagl[2,3])-(fromList [4.010341078059521,5.0197204699640405],-(2><2)- [ 1.9862461923890056, -1.0127225830525157e-2- , -1.0127225830525157e-2, 3.0373954915729318 ])---}-meanCov :: Matrix Double -> (Vector Double, Matrix Double)-meanCov x = (med,cov) where- r = rows x- k = 1 / fromIntegral r- med = konst k r `vXm` x- meds = konst 1 r `outer` med- xc = x `sub` meds- cov = scale (recip (fromIntegral (r-1))) (trans xc `mXm` xc)------------------------------------------------------------------------------------class ( Container Vector t- , Container Matrix t- , Konst t Int Vector- , Konst t (Int,Int) Matrix- , Product t- ) => Numeric t--instance Numeric Double-instance Numeric (Complex Double)-instance Numeric Float-instance Numeric (Complex Float)--
− src/Data/Packed/ST.hs
@@ -1,178 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.ST--- Copyright : (c) Alberto Ruiz 2008--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ In-place manipulation inside the ST monad.--- See examples/inplace.hs in the distribution.----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.ST (- -- * Mutable Vectors- STVector, newVector, thawVector, freezeVector, runSTVector,- readVector, writeVector, modifyVector, liftSTVector,- -- * Mutable Matrices- STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix,- readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,- -- * Unsafe functions- newUndefinedVector,- unsafeReadVector, unsafeWriteVector,- unsafeThawVector, unsafeFreezeVector,- newUndefinedMatrix,- unsafeReadMatrix, unsafeWriteMatrix,- unsafeThawMatrix, unsafeFreezeMatrix-) where--import Data.Packed.Internal--import Control.Monad.ST(ST, runST)-import Foreign.Storable(Storable, peekElemOff, pokeElemOff)--#if MIN_VERSION_base(4,4,0)-import Control.Monad.ST.Unsafe(unsafeIOToST)-#else-import Control.Monad.ST(unsafeIOToST)-#endif--{-# INLINE ioReadV #-}-ioReadV :: Storable t => Vector t -> Int -> IO t-ioReadV v k = unsafeWith v $ \s -> peekElemOff s k--{-# INLINE ioWriteV #-}-ioWriteV :: Storable t => Vector t -> Int -> t -> IO ()-ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x--newtype STVector s t = STVector (Vector t)--thawVector :: Storable t => Vector t -> ST s (STVector s t)-thawVector = unsafeIOToST . fmap STVector . cloneVector--unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t)-unsafeThawVector = unsafeIOToST . return . STVector--runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t-runSTVector st = runST (st >>= unsafeFreezeVector)--{-# INLINE unsafeReadVector #-}-unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t-unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x--{-# INLINE unsafeWriteVector #-}-unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s ()-unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k--{-# INLINE modifyVector #-}-modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s ()-modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k--liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s1 t -> ST s2 a-liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x--freezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t)-freezeVector v = liftSTVector id v--unsafeFreezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t)-unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x--{-# INLINE safeIndexV #-}-safeIndexV f (STVector v) k- | k < 0 || k>= dim v = error $ "out of range error in vector (dim="- ++show (dim v)++", pos="++show k++")"- | otherwise = f (STVector v) k--{-# INLINE readVector #-}-readVector :: Storable t => STVector s t -> Int -> ST s t-readVector = safeIndexV unsafeReadVector--{-# INLINE writeVector #-}-writeVector :: Storable t => STVector s t -> Int -> t -> ST s ()-writeVector = safeIndexV unsafeWriteVector--newUndefinedVector :: Storable t => Int -> ST s (STVector s t)-newUndefinedVector = unsafeIOToST . fmap STVector . createVector--{-# INLINE newVector #-}-newVector :: Storable t => t -> Int -> ST s (STVector s t)-newVector x n = do- v <- newUndefinedVector n- let go (-1) = return v- go !k = unsafeWriteVector v k x >> go (k-1 :: Int)- go (n-1)-----------------------------------------------------------------------------{-# INLINE ioReadM #-}-ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t-ioReadM (Matrix _ nc cv RowMajor) r c = ioReadV cv (r*nc+c)-ioReadM (Matrix nr _ fv ColumnMajor) r c = ioReadV fv (c*nr+r)--{-# INLINE ioWriteM #-}-ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO ()-ioWriteM (Matrix _ nc cv RowMajor) r c val = ioWriteV cv (r*nc+c) val-ioWriteM (Matrix nr _ fv ColumnMajor) r c val = ioWriteV fv (c*nr+r) val--newtype STMatrix s t = STMatrix (Matrix t)--thawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)-thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix--unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)-unsafeThawMatrix = unsafeIOToST . return . STMatrix--runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t-runSTMatrix st = runST (st >>= unsafeFreezeMatrix)--{-# INLINE unsafeReadMatrix #-}-unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t-unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r--{-# INLINE unsafeWriteMatrix #-}-unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()-unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c--{-# INLINE modifyMatrix #-}-modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s ()-modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c--liftSTMatrix :: (Storable t) => (Matrix t -> a) -> STMatrix s1 t -> ST s2 a-liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x--unsafeFreezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t)-unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x--freezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t)-freezeMatrix m = liftSTMatrix id m--cloneMatrix (Matrix r c d o) = cloneVector d >>= return . (\d' -> Matrix r c d' o)--{-# INLINE safeIndexM #-}-safeIndexM f (STMatrix m) r c- | r<0 || r>=rows m ||- c<0 || c>=cols m = error $ "out of range error in matrix (size="- ++show (rows m,cols m)++", pos="++show (r,c)++")"- | otherwise = f (STMatrix m) r c--{-# INLINE readMatrix #-}-readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t-readMatrix = safeIndexM unsafeReadMatrix--{-# INLINE writeMatrix #-}-writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()-writeMatrix = safeIndexM unsafeWriteMatrix--newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t)-newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c--{-# NOINLINE newMatrix #-}-newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t)-newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c)-
− src/Data/Packed/Vector.hs
@@ -1,125 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module : Data.Packed.Vector--- Copyright : (c) Alberto Ruiz 2007-10--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ 1D arrays suitable for numeric computations using external libraries.------ This module provides basic functions for manipulation of structure.----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Data.Packed.Vector (- Vector,- fromList, (|>), toList, buildVector,- dim, (@>),- subVector, takesV, vjoin, join,- mapVector, mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith,- mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,- foldLoop, foldVector, foldVectorG, foldVectorWithIndex,- toByteString, fromByteString-) where--import Data.Packed.Internal.Vector-import Foreign.Storable-----------------------------------------------------------------------#ifdef BINARY--import Data.Binary-import Control.Monad(replicateM)--import Data.ByteString.Internal as BS-import Foreign.ForeignPtr(castForeignPtr)-import Data.Vector.Storable.Internal(updPtr)-import Foreign.Ptr(plusPtr)----- a 64K cache, with a Double taking 13 bytes in Bytestring,--- implies a chunk size of 5041-chunk :: Int-chunk = 5000--chunks :: Int -> [Int]-chunks d = let c = d `div` chunk- m = d `mod` chunk- in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk)--putVector v = mapM_ put $! toList v--getVector d = do- xs <- replicateM d get- return $! fromList xs------------------------------------------------------------------------------------toByteString :: Storable t => Vector t -> ByteString-toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v)- where- (fp,o,_n) = unsafeToForeignPtr v- sz = sizeOf (v@>0)---fromByteString :: Storable t => ByteString -> Vector t-fromByteString (BS.PS fp o n) = r- where- r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n'- n' = n `div` sz- sz = sizeOf (r@>0)------------------------------------------------------------------------------------instance (Binary a, Storable a) => Binary (Vector a) where-- put v = do- let d = dim v- put d- mapM_ putVector $! takesV (chunks d) v-- -- put = put . v2bs-- get = do- d <- get- vs <- mapM getVector $ chunks d- return $! vjoin vs-- -- get = fmap bs2v get--#endif------------------------------------------------------------------------{- | creates a Vector of the specified length using the supplied function to- to map the index to the value at that index.--@> buildVector 4 fromIntegral-4 |> [0.0,1.0,2.0,3.0]@---}-buildVector :: Storable a => Int -> (Int -> a) -> Vector a-buildVector len f =- fromList $ map f [0 .. (len - 1)]----- | zip for Vectors-zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b)-zipVector = zipVectorWith (,)---- | unzip for Vectors-unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b)-unzipVector = unzipVectorWith id-----------------------------------------------------------------------{-# DEPRECATED join "use vjoin or Data.Vector.concat" #-}-join :: Storable t => [Vector t] -> Vector t-join = vjoin-
+ src/Internal/Algorithms.hs view
@@ -0,0 +1,1164 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+{- |+Module : Internal.Algorithms+Copyright : (c) Alberto Ruiz 2006-14+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++High level generic interface to common matrix computations.++Specific functions for particular base types can also be explicitly+imported from "Numeric.LinearAlgebra.LAPACK".++-}+-----------------------------------------------------------------------------++module Internal.Algorithms (+ module Internal.Algorithms,+ UpLo(..)+) where++#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Conversion+import Internal.LAPACK+import Internal.Numeric+import Data.List(foldl1')+import qualified Data.Array as A+import qualified Data.Vector.Storable as Vector+import Internal.ST+import Internal.Vectorized(range)+import Control.DeepSeq++{- | Generic linear algebra functions for double precision real and complex matrices.++(Single precision data can be converted using 'single' and 'double').++-}+class (Numeric t,+ Convert t,+ Normed Matrix t,+ Normed Vector t,+ Floating t,+ Linear t Vector,+ Linear t Matrix,+ Additive (Vector t),+ Additive (Matrix t),+ RealOf t ~ Double) => Field t where+ svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t)+ thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t)+ sv' :: Matrix t -> Vector Double+ luPacked' :: Matrix t -> (Matrix t, [Int])+ luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t+ mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t)+ linearSolve' :: Matrix t -> Matrix t -> Matrix t+ cholSolve' :: Matrix t -> Matrix t -> Matrix t+ triSolve' :: UpLo -> Matrix t -> Matrix t -> Matrix t+ triDiagSolve' :: Vector t -> Vector t -> Vector t -> Matrix t -> Matrix t+ ldlPacked' :: Matrix t -> (Matrix t, [Int])+ ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t+ linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t+ linearSolveLS' :: Matrix t -> Matrix t -> Matrix t+ eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double))+ geig' :: Matrix t -> Matrix t -> (Vector (Complex Double), Vector t, Matrix (Complex Double))+ eigSH'' :: Matrix t -> (Vector Double, Matrix t)+ eigOnly :: Matrix t -> Vector (Complex Double)+ geigOnly :: Matrix t -> Matrix t -> (Vector (Complex Double), Vector t)+ eigOnlySH :: Matrix t -> Vector Double+ cholSH' :: Matrix t -> Matrix t+ mbCholSH' :: Matrix t -> Maybe (Matrix t)+ qr' :: Matrix t -> (Matrix t, Vector t)+ qrgr' :: Int -> (Matrix t, Vector t) -> Matrix t+ hess' :: Matrix t -> (Matrix t, Matrix t)+ schur' :: Matrix t -> (Matrix t, Matrix t)+++instance Field Double where+ svd' = svdRd+ thinSVD' = thinSVDRd+ sv' = svR+ luPacked' = luR+ luSolve' (l_u,perm) = lusR l_u perm+ linearSolve' = linearSolveR -- (luSolve . luPacked) ??+ mbLinearSolve' = mbLinearSolveR+ cholSolve' = cholSolveR+ triSolve' = triSolveR+ triDiagSolve' = triDiagSolveR+ linearSolveLS' = linearSolveLSR+ linearSolveSVD' = linearSolveSVDR Nothing+ eig' = eigR+ eigSH'' = eigS+ geig' = eigG+ eigOnly = eigOnlyR+ geigOnly = eigOnlyG+ eigOnlySH = eigOnlyS+ cholSH' = cholS+ mbCholSH' = mbCholS+ qr' = qrR+ qrgr' = qrgrR+ hess' = unpackHess hessR+ schur' = schurR+ ldlPacked' = ldlR+ ldlSolve'= uncurry ldlsR++instance Field (Complex Double) where+#ifdef NOZGESDD+ svd' = svdC+ thinSVD' = thinSVDC+#else+ svd' = svdCd+ thinSVD' = thinSVDCd+#endif+ sv' = svC+ luPacked' = luC+ luSolve' (l_u,perm) = lusC l_u perm+ linearSolve' = linearSolveC+ mbLinearSolve' = mbLinearSolveC+ cholSolve' = cholSolveC+ triSolve' = triSolveC+ triDiagSolve' = triDiagSolveC+ linearSolveLS' = linearSolveLSC+ linearSolveSVD' = linearSolveSVDC Nothing+ eig' = eigC+ geig' = eigGC+ eigOnly = eigOnlyC+ geigOnly = eigOnlyGC+ eigSH'' = eigH+ eigOnlySH = eigOnlyH+ cholSH' = cholH+ mbCholSH' = mbCholH+ qr' = qrC+ qrgr' = qrgrC+ hess' = unpackHess hessC+ schur' = schurC+ ldlPacked' = ldlC+ ldlSolve' = uncurry ldlsC++--------------------------------------------------------------++square m = rows m == cols m++vertical m = rows m >= cols m++exactHermitian m = m `equal` ctrans m++--------------------------------------------------------------++{- | Full singular value decomposition.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = svd a++>>> disp 3 u+5x5+-0.101 0.768 0.614 0.028 -0.149+-0.249 0.488 -0.503 0.172 0.646+-0.396 0.208 -0.405 -0.660 -0.449+-0.543 -0.072 -0.140 0.693 -0.447+-0.690 -0.352 0.433 -0.233 0.398++>>> s+[35.18264833189422,1.4769076999800903,1.089145439970417e-15]+it :: Vector Double++>>> disp 3 v+3x3+-0.519 -0.751 0.408+-0.576 -0.046 -0.816+-0.632 0.659 0.408++>>> let d = diagRect 0 s 5 3+>>> disp 3 d+5x3+35.183 0.000 0.000+ 0.000 1.477 0.000+ 0.000 0.000 0.000+ 0.000 0.000 0.000++>>> disp 3 $ u <> d <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+svd = {-# SCC "svd" #-} g . svd'+ where+ g (u,s,v) = (u,s,tr v)++{- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@.++If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> tr v@.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = thinSVD a++>>> disp 3 u+5x3+-0.101 0.768 0.614+-0.249 0.488 -0.503+-0.396 0.208 -0.405+-0.543 -0.072 -0.140+-0.690 -0.352 0.433++>>> s+[35.18264833189422,1.4769076999800903,1.089145439970417e-15]+it :: Vector Double++>>> disp 3 v+3x3+-0.519 -0.751 0.408+-0.576 -0.046 -0.816+-0.632 0.659 0.408++>>> disp 3 $ u <> diag s <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+thinSVD = {-# SCC "thinSVD" #-} g . thinSVD'+ where+ g (u,s,v) = (u,s,tr v)+++-- | Singular values only.+singularValues :: Field t => Matrix t -> Vector Double+singularValues = {-# SCC "singularValues" #-} sv'++-- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values.+--+-- If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> tr v@.+fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t)+fullSVD m = (u,d,v) where+ (u,s,v) = svd m+ d = diagRect 0 s r c+ r = rows m+ c = cols m++{- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors.++@+a = (5><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0+ , 13.0, 14.0, 15.0 ] :: Matrix Double+@++>>> let (u,s,v) = compactSVD a++>>> disp 3 u+5x2+-0.101 0.768+-0.249 0.488+-0.396 0.208+-0.543 -0.072+-0.690 -0.352++>>> s+[35.18264833189422,1.476907699980091]+it :: Vector Double++>>> disp 3 u+5x2+-0.101 0.768+-0.249 0.488+-0.396 0.208+-0.543 -0.072+-0.690 -0.352++>>> disp 3 $ u <> diag s <> tr v+5x3+ 1.000 2.000 3.000+ 4.000 5.000 6.000+ 7.000 8.000 9.000+10.000 11.000 12.000+13.000 14.000 15.000++-}+compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)+compactSVD = compactSVDTol 1++-- | @compactSVDTol r@ is similar to 'compactSVD' (for which @r=1@), but uses tolerance @tol=r*g*eps*(max rows cols)@ to distinguish nonzero singular values, where @g@ is the greatest singular value. If @g<r*eps@, then only one singular value is returned.+compactSVDTol :: Field t => Double -> Matrix t -> (Matrix t, Vector Double, Matrix t)+compactSVDTol r m = (u', subVector 0 d s, v') where+ (u,s,v) = thinSVD m+ d = rankSVD (r*eps) m s `max` 1+ u' = takeColumns d u+ v' = takeColumns d v+++-- | Singular values and all right singular vectors (as columns).+rightSV :: Field t => Matrix t -> (Vector Double, Matrix t)+rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v)+ | otherwise = let (_,s,v) = svd m in (s,v)++-- | Singular values and all left singular vectors (as columns).+leftSV :: Field t => Matrix t -> (Matrix t, Vector Double)+leftSV m | vertical m = let (u,s,_) = svd m in (u,s)+ | otherwise = let (u,s,_) = thinSVD m in (u,s)+++--------------------------------------------------------------++-- | LU decomposition of a matrix in a compact format.+data LU t = LU (Matrix t) [Int] deriving Show++instance (NFData t, Numeric t) => NFData (LU t)+ where+ rnf (LU m _) = rnf m++-- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'.+luPacked :: Field t => Matrix t -> LU t+luPacked x = {-# SCC "luPacked" #-} LU m p+ where+ (m,p) = luPacked' x++-- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'.+luSolve :: Field t => LU t -> Matrix t -> Matrix t+luSolve (LU m p) = {-# SCC "luSolve" #-} luSolve' (m,p)++-- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.+-- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system.+linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolve = {-# SCC "linearSolve" #-} linearSolve'++-- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.+mbLinearSolve :: Field t => Matrix t -> Matrix t -> Maybe (Matrix t)+mbLinearSolve = {-# SCC "linearSolve" #-} mbLinearSolve'++-- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'.+cholSolve+ :: Field t+ => Matrix t -- ^ Cholesky decomposition of the coefficient matrix+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+cholSolve = {-# SCC "cholSolve" #-} cholSolve'++-- | Solve a triangular linear system. If `Upper` is specified then+-- all elements below the diagonal are ignored; if `Lower` is+-- specified then all elements above the diagonal are ignored.+triSolve+ :: Field t+ => UpLo -- ^ `Lower` or `Upper`+ -> Matrix t -- ^ coefficient matrix+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+triSolve = {-# SCC "triSolve" #-} triSolve'++-- | Solve a tridiagonal linear system. Suppose you wish to solve \(Ax = b\) where+--+-- \[+-- A =+-- \begin{bmatrix}+-- 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0+-- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0+-- \end{bmatrix}+-- \quad+-- b =+-- \begin{bmatrix}+-- 1.0 & 1.0 & 1.0+-- \\ 1.0 & -1.0 & 2.0+-- \\ 1.0 & 1.0 & 3.0+-- \\ 1.0 & -1.0 & 4.0+-- \\ 1.0 & 1.0 & 5.0+-- \\ 1.0 & -1.0 & 6.0+-- \\ 1.0 & 1.0 & 7.0+-- \\ 1.0 & -1.0 & 8.0+-- \\ 1.0 & 1.0 & 9.0+-- \end{bmatrix}+-- \]+--+-- then+--+-- @+-- dL = fromList [3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0]+-- d = fromList [1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0]+-- dU = fromList [4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0]+--+-- b = (9><3)+-- [+-- 1.0, 1.0, 1.0,+-- 1.0, -1.0, 2.0,+-- 1.0, 1.0, 3.0,+-- 1.0, -1.0, 4.0,+-- 1.0, 1.0, 5.0,+-- 1.0, -1.0, 6.0,+-- 1.0, 1.0, 7.0,+-- 1.0, -1.0, 8.0,+-- 1.0, 1.0, 9.0+-- ]+--+-- x = triDiagSolve dL d dU b+-- @+--+triDiagSolve+ :: Field t+ => Vector t -- ^ lower diagonal: \(n - 1\) elements+ -> Vector t -- ^ diagonal: \(n\) elements+ -> Vector t -- ^ upper diagonal: \(n - 1\) elements+ -> Matrix t -- ^ right hand sides+ -> Matrix t -- ^ solution+triDiagSolve = {-# SCC "triDiagSolve" #-} triDiagSolve'++-- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value.+linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD'+++-- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'.+linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t+linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS'++--------------------------------------------------------------------------------++-- | LDL decomposition of a complex Hermitian or real symmetric matrix in a compact format.+data LDL t = LDL (Matrix t) [Int] deriving Show++instance (NFData t, Numeric t) => NFData (LDL t)+ where+ rnf (LDL m _) = rnf m++-- | Similar to 'ldlPacked', without checking that the input matrix is hermitian or symmetric. It works with the lower triangular part.+ldlPackedSH :: Field t => Matrix t -> LDL t+ldlPackedSH x = {-# SCC "ldlPacked" #-} LDL m p+ where+ (m,p) = ldlPacked' x++-- | Obtains the LDL decomposition of a matrix in a compact data structure suitable for 'ldlSolve'.+ldlPacked :: Field t => Herm t -> LDL t+ldlPacked (Herm m) = ldlPackedSH m++-- | Solution of a linear system (for several right hand sides) from a precomputed LDL factorization obtained by 'ldlPacked'.+--+-- Note: this can be slower than the general solver based on the LU decomposition.+ldlSolve :: Field t => LDL t -> Matrix t -> Matrix t+ldlSolve (LDL m p) = {-# SCC "ldlSolve" #-} ldlSolve' (m,p)++--------------------------------------------------------------++{- | Eigenvalues (not ordered) and eigenvectors (as columns) of a general square matrix.++If @(s,v) = eig m@ then @m \<> v == v \<> diag s@++@+a = (3><3)+ [ 3, 0, -2+ , 4, 5, -1+ , 3, 1, 0 ] :: Matrix Double+@++>>> let (l, v) = eig a++>>> putStr . dispcf 3 . asRow $ l+1x3+1.925+1.523i 1.925-1.523i 4.151++>>> putStr . dispcf 3 $ v+3x3+-0.455+0.365i -0.455-0.365i 0.181+ 0.603 0.603 -0.978+ 0.033+0.543i 0.033-0.543i -0.104++>>> putStr . dispcf 3 $ complex a <> v+3x3+-1.432+0.010i -1.432-0.010i 0.753+ 1.160+0.918i 1.160-0.918i -4.059+-0.763+1.096i -0.763-1.096i -0.433++>>> putStr . dispcf 3 $ v <> diag l+3x3+-1.432+0.010i -1.432-0.010i 0.753+ 1.160+0.918i 1.160-0.918i -4.059+-0.763+1.096i -0.763-1.096i -0.433++-}+eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double))+eig = {-# SCC "eig" #-} eig'++-- | Generalized eigenvalues (not ordered) and eigenvectors (as columns) of a pair of nonsymmetric matrices.+-- Eigenvalues are represented as pairs of alpha, beta, where eigenvalue = alpha / beta. Alpha is always+-- complex, but betas has the same type as the input matrix.+--+-- If @(alphas, betas, v) = geig a b@, then @a \<> v == b \<> v \<> diag (alphas / betas)@+--+-- Note that beta can be 0 and that has reasonable interpretation.+geig :: Field t => Matrix t -> Matrix t -> (Vector (Complex Double), Vector t, Matrix (Complex Double))+geig = {-# SCC "geig" #-} geig'++-- | Eigenvalues (not ordered) of a general square matrix.+eigenvalues :: Field t => Matrix t -> Vector (Complex Double)+eigenvalues = {-# SCC "eigenvalues" #-} eigOnly++-- | Generalized eigenvalues of a pair of matrices. Represented as pairs of alpha, beta,+-- where eigenvalue is alpha / beta as in 'geig'.+geigenvalues :: Field t => Matrix t -> Matrix t -> (Vector (Complex Double), Vector t)+geigenvalues = {-# SCC "geigenvalues" #-} geigOnly++-- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t)+eigSH' = {-# SCC "eigSH'" #-} eigSH''++-- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+eigenvaluesSH' :: Field t => Matrix t -> Vector Double+eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH++{- | Eigenvalues and eigenvectors (as columns) of a complex hermitian or real symmetric matrix, in descending order.++If @(s,v) = eigSH m@ then @m == v \<> diag s \<> tr v@++@+a = (3><3)+ [ 1.0, 2.0, 3.0+ , 2.0, 4.0, 5.0+ , 3.0, 5.0, 6.0 ]+@++>>> let (l, v) = eigSH a++>>> l+[11.344814282762075,0.17091518882717918,-0.5157294715892575]++>>> disp 3 $ v <> diag l <> tr v+3x3+1.000 2.000 3.000+2.000 4.000 5.000+3.000 5.000 6.000++-}+eigSH :: Field t => Herm t -> (Vector Double, Matrix t)+eigSH (Herm m) = eigSH' m++-- | Eigenvalues (in descending order) of a complex hermitian or real symmetric matrix.+eigenvaluesSH :: Field t => Herm t -> Vector Double+eigenvaluesSH (Herm m) = eigenvaluesSH' m++--------------------------------------------------------------++-- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.)+data QR t = QR (Matrix t) (Vector t)++instance (NFData t, Numeric t) => NFData (QR t)+ where+ rnf (QR m _) = rnf m+++-- | QR factorization.+--+-- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular.+-- Note: the current implementation is very slow for large matrices. 'thinQR' is much faster.+qr :: Field t => Matrix t -> (Matrix t, Matrix t)+qr = {-# SCC "qr" #-} unpackQR . qr'++-- | A version of 'qr' which returns only the @min (rows m) (cols m)@ columns of @q@ and rows of @r@.+thinQR :: Field t => Matrix t -> (Matrix t, Matrix t)+thinQR = {-# SCC "thinQR" #-} thinUnpackQR . qr'++-- | Compute the QR decomposition of a matrix in compact form.+qrRaw :: Field t => Matrix t -> QR t+qrRaw m = QR x v+ where+ (x,v) = qr' m++-- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'.+--+qrgr :: Field t => Int -> QR t -> Matrix t+qrgr n (QR a t)+ | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)"+ | otherwise = qrgr' n (a,t)++-- | RQ factorization.+--+-- If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular.+-- Note: the current implementation is very slow for large matrices. 'thinRQ' is much faster.+rq :: Field t => Matrix t -> (Matrix t, Matrix t)+rq = {-# SCC "rq" #-} rqFromQR qr++-- | A version of 'rq' which returns only the @min (rows m) (cols m)@ columns of @r@ and rows of @q@.+thinRQ :: Field t => Matrix t -> (Matrix t, Matrix t)+thinRQ = {-# SCC "thinQR" #-} rqFromQR thinQR++rqFromQR :: Field t => (Matrix t -> (Matrix t, Matrix t)) -> Matrix t -> (Matrix t, Matrix t)+rqFromQR qr0 m = (r,q) where+ (q',r') = qr0 $ trans $ rev1 m+ r = rev2 (trans r')+ q = rev2 (trans q')+ rev1 = flipud . fliprl+ rev2 = fliprl . flipud++-- | Hessenberg factorization.+--+-- If @(p,h) = hess m@ then @m == p \<> h \<> tr p@, where p is unitary+-- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal).+hess :: Field t => Matrix t -> (Matrix t, Matrix t)+hess = hess'++-- | Schur factorization.+--+-- If @(u,s) = schur m@ then @m == u \<> s \<> tr u@, where u is unitary+-- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is+-- upper triangular in 2x2 blocks.+--+-- \"Anything that the Jordan decomposition can do, the Schur decomposition+-- can do better!\" (Van Loan)+schur :: Field t => Matrix t -> (Matrix t, Matrix t)+schur = schur'+++-- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.+mbCholSH :: Field t => Matrix t -> Maybe (Matrix t)+mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH'++-- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.+cholSH :: Field t => Matrix t -> Matrix t+cholSH = cholSH'++-- | Cholesky factorization of a positive definite hermitian or symmetric matrix.+--+-- If @c = chol m@ then @c@ is upper triangular and @m == tr c \<> c@.+chol :: Field t => Herm t -> Matrix t+chol (Herm m) = {-# SCC "chol" #-} cholSH' m++-- | Similar to 'chol', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.+mbChol :: Field t => Herm t -> Maybe (Matrix t)+mbChol (Herm m) = {-# SCC "mbChol" #-} mbCholSH' m++++-- | Joint computation of inverse and logarithm of determinant of a square matrix.+invlndet :: Field t+ => Matrix t+ -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det))+invlndet m | square m = (im,(ladm,sdm))+ | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix"+ where+ lp@(LU lup perm) = luPacked m+ s = signlp (rows m) perm+ dg = toList $ takeDiag $ lup+ ladm = sum $ map (log.abs) dg+ sdm = s* product (map signum dg)+ im = luSolve lp (ident (rows m))+++-- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'.+det :: Field t => Matrix t -> t+det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup)+ | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix"+ where+ LU lup perm = luPacked m+ s = signlp (rows m) perm++-- | Explicit LU factorization of a general matrix.+--+-- If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular,+-- u is upper triangular, p is a permutation matrix and s is the signature of the permutation.+lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t)+lu = luFact . luPacked++-- | Inverse of a square matrix. See also 'invlndet'.+inv :: Field t => Matrix t -> Matrix t+inv m | square m = m `linearSolve` ident (rows m)+ | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix"+++-- | Pseudoinverse of a general matrix with default tolerance ('pinvTol' 1, similar to GNU-Octave).+pinv :: Field t => Matrix t -> Matrix t+pinv = pinvTol 1++{- | @pinvTol r@ computes the pseudoinverse of a matrix with tolerance @tol=r*g*eps*(max rows cols)@, where g is the greatest singular value.++@+m = (3><3) [ 1, 0, 0+ , 0, 1, 0+ , 0, 0, 1e-10] :: Matrix Double+@++>>> pinv m+1. 0. 0.+0. 1. 0.+0. 0. 10000000000.++>>> pinvTol 1E8 m+1. 0. 0.+0. 1. 0.+0. 0. 1.++-}++pinvTol :: Field t => Double -> Matrix t -> Matrix t+pinvTol t m = v' `mXm` diag s' `mXm` ctrans u' where+ (u,s,v) = thinSVD m+ sl@(g:_) = toList s+ s' = real . fromList . map rec $ sl+ rec x = if x <= g*tol then x else 1/x+ tol = (fromIntegral (max r c) * g * t * eps)+ r = rows m+ c = cols m+ d = dim s+ u' = takeColumns d u+ v' = takeColumns d v+++-- | Numeric rank of a matrix from the SVD decomposition.+rankSVD :: Element t+ => Double -- ^ numeric zero (e.g. 1*'eps')+ -> Matrix t -- ^ input matrix m+ -> Vector Double -- ^ 'sv' of m+ -> Int -- ^ rank of m+rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s)++-- | Numeric rank of a matrix from its singular values.+ranksv :: Double -- ^ numeric zero (e.g. 1*'eps')+ -> Int -- ^ maximum dimension of the matrix+ -> [Double] -- ^ singular values+ -> Int -- ^ rank of m+ranksv teps maxdim s = k where+ g = maximum s+ tol = fromIntegral maxdim * g * teps+ s' = filter (>tol) s+ k = if g > teps then length s' else 0++-- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave).+eps :: Double+eps = 2.22044604925031e-16+++-- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1+peps :: RealFloat x => x+peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x)++-----------------------------------------------------------------------++-- | The nullspace of a matrix from its precomputed SVD decomposition.+nullspaceSVD :: Field t+ => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),+ -- or Right \"theoretical\" matrix rank.+ -> Matrix t -- ^ input matrix m+ -> (Vector Double, Matrix t) -- ^ 'rightSV' of m+ -> Matrix t -- ^ nullspace+nullspaceSVD hint a (s,v) = vs where+ tol = case hint of+ Left t -> t+ _ -> eps+ k = case hint of+ Right t -> t+ _ -> rankSVD tol a s+ vs = dropColumns k v+++-- | The nullspace of a matrix. See also 'nullspaceSVD'.+nullspacePrec :: Field t+ => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps')+ -> Matrix t -- ^ input matrix+ -> [Vector t] -- ^ list of unitary vectors spanning the nullspace+nullspacePrec t m = toColumns $ nullspaceSVD (Left (t*eps)) m (rightSV m)++-- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision.+nullVector :: Field t => Matrix t -> Vector t+nullVector = last . nullspacePrec 1++-- | The range space a matrix from its precomputed SVD decomposition.+orthSVD :: Field t+ => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),+ -- or Right \"theoretical\" matrix rank.+ -> Matrix t -- ^ input matrix m+ -> (Matrix t, Vector Double) -- ^ 'leftSV' of m+ -> Matrix t -- ^ orth+orthSVD hint a (v,s) = vs where+ tol = case hint of+ Left t -> t+ _ -> eps+ k = case hint of+ Right t -> t+ _ -> rankSVD tol a s+ vs = takeColumns k v+++orth :: Field t => Matrix t -> [Vector t]+-- ^ Return an orthonormal basis of the range space of a matrix+orth m = take r $ toColumns u+ where+ (u,s,_) = compactSVD m+ r = ranksv eps (max (rows m) (cols m)) (toList s)++------------------------------------------------------------------------++-- many thanks, quickcheck!++haussholder :: (Field a) => a -> Vector a -> Matrix a+haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w))+ where w = asColumn v+++zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs)+ where xs = toList v++zt 0 v = v+zt k v = vjoin [subVector 0 (dim v - k) v, konst' 0 k]+++unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)+unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r)+ where cs = toColumns pq+ m = rows pq+ n = cols pq+ mn = min m n+ r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs+ vs = zipWith zh [1..mn] cs+ hs = zipWith haussholder (toList tau) vs+ q = foldl1' mXm hs++thinUnpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)+thinUnpackQR (pq, tau) = (q, r)+ where mn = uncurry min $ size pq+ q = qrgr mn $ QR pq tau+ r = fromRows $ zipWith (\i v -> Vector.replicate i 0 Vector.++ Vector.drop i v) [0..mn-1] (toRows pq)++unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t)+unpackHess hf m+ | rows m == 1 = ((1><1)[1],m)+ | otherwise = (uH . hf) m++uH (pq, tau) = (p,h)+ where cs = toColumns pq+ m = rows pq+ n = cols pq+ mn = min m n+ h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs+ vs = zipWith zh [2..mn] cs+ hs = zipWith haussholder (toList tau) vs+ p = foldl1' mXm hs++--------------------------------------------------------------------------++-- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values.+rcond :: Field t => Matrix t -> Double+rcond m = last s / head s+ where s = toList (singularValues m)++-- | Number of linearly independent rows or columns. See also 'ranksv'+rank :: Field t => Matrix t -> Int+rank m = rankSVD eps m (singularValues m)++{-+expm' m = case diagonalize (complex m) of+ Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v+ Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices"+ where exp = vectorMapC Exp+-}++diagonalize m = if rank v == n+ then Just (l,v)+ else Nothing+ where n = rows m+ (l,v) = if exactHermitian m+ then let (l',v') = eigSH (trustSym m) in (real l', v')+ else eig m++-- | Generic matrix functions for diagonalizable matrices. For instance:+--+-- @logm = matFunc log@+--+matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+matFunc f m = case diagonalize m of+ Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v+ Nothing -> error "Sorry, matFunc requires a diagonalizable matrix"++--------------------------------------------------------------++golubeps :: Integer -> Integer -> Double+golubeps p q = a * fromIntegral b / fromIntegral c where+ a = 2^^(3-p-q)+ b = fact p * fact q+ c = fact (p+q) * fact (p+q+1)+ fact n = product [1..n]++epslist :: [(Int,Double)]+epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]]++geps delta = head [ k | (k,g) <- epslist, g<delta]+++{- | Matrix exponential. It uses a direct translation of Algorithm 11.3.1 in Golub & Van Loan,+ based on a scaled Pade approximation.+-}+expm :: Field t => Matrix t -> Matrix t+expm = expGolub++expGolub :: Field t => Matrix t -> Matrix t+expGolub m = iterate msq f !! j+ where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m+ a = m */ fromIntegral ((2::Int)^j)+ q = geps eps -- 7 steps+ eye = ident (rows m)+ work (k,c,x,n,d) = (k',c',x',n',d')+ where k' = k+1+ c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k)+ x' = a <> x+ n' = n |+| (c' .* x')+ d' = d |+| (((-1)^k * c') .* x')+ (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q+ f = linearSolve df nf+ msq x = x <> x++ (<>) = multiply+ v */ x = scale (recip x) v+ (.*) = scale+ (|+|) = add++--------------------------------------------------------------++{- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia.+It only works with invertible matrices that have a real solution.++@m = (2><2) [4,9+ ,0,4] :: Matrix Double@++>>> sqrtm m+(2><2)+ [ 2.0, 2.25+ , 0.0, 2.0 ]++For diagonalizable matrices you can try 'matFunc' @sqrt@:++>>> matFunc sqrt ((2><2) [1,0,0,-1])+(2><2)+ [ 1.0 :+ 0.0, 0.0 :+ 0.0+ , 0.0 :+ 0.0, 0.0 :+ 1.0 ]++-}+sqrtm :: Field t => Matrix t -> Matrix t+sqrtm = sqrtmInv++sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x))+ where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a+ | otherwise = fixedPoint (b:rest)+ fixedPoint _ = error "fixedpoint with impossible inputs"+ f (y,z) = (0.5 .* (y |+| inv z),+ 0.5 .* (inv y |+| z))+ (.*) = scale+ (|+|) = add+ (|-|) = sub++------------------------------------------------------------------++signlp r vals = foldl f 1 (zip [0..r-1] vals)+ where f s (a,b) | a /= b = -s+ | otherwise = s++fixPerm r vals = (fromColumns $ A.elems res, sign)+ where+ v = [0..r-1]+ t = toColumns (ident r)+ (res,sign) = foldl swap (A.listArray (0,r-1) t, 1) (zip v vals)+ swap (arr,s) (a,b)+ | a /= b = (arr A.// [(a, arr A.! b),(b,arr A.! a)],-s)+ | otherwise = (arr,s)++fixPerm' :: [Int] -> Vector I+fixPerm' s = res $ mutable f s0+ where+ s0 = reshape 1 (range (length s))+ res = flatten . fst+ swap m i j = rowOper (SWAP i j AllCols) m+ f :: (Num t, Element t) => (Int, Int) -> STMatrix s t -> ST s () -- needed because of TypeFamilies+ f _ p = sequence_ $ zipWith (swap p) [0..] s++triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]]+ where el p q = if q-p>=h then v else 1 - v++-- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'.+luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t)+luFact (LU l_u perm)+ | r <= c = (l ,u ,p, s)+ | otherwise = (l',u',p, s)+ where+ r = rows l_u+ c = cols l_u+ tu = triang r c 0 1+ tl = triang r c 0 0+ l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst' 1 r) r r+ u = l_u |*| tu+ (p,s) = fixPerm r perm+ l' = (l_u |*| tl) |+| diagRect 0 (konst' 1 c) r c+ u' = takeRows c (l_u |*| tu)+ (|+|) = add+ (|*|) = mul++---------------------------------------------------------------------------++data NormType = Infinity | PNorm1 | PNorm2 | Frobenius++class (RealFloat (RealOf t)) => Normed c t where+ pnorm :: NormType -> c t -> RealOf t++instance Normed Vector Double where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = norm2++instance Normed Vector (Complex Double) where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2++instance Normed Vector Float where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2++instance Normed Vector (Complex Float) where+ pnorm PNorm1 = norm1+ pnorm PNorm2 = norm2+ pnorm Infinity = normInf+ pnorm Frobenius = pnorm PNorm2+++instance Normed Matrix Double where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = (@>0) . singularValues+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix (Complex Double) where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = (@>0) . singularValues+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix Float where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = realToFrac . (@>0) . singularValues . double+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++instance Normed Matrix (Complex Float) where+ pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns+ pnorm PNorm2 = realToFrac . (@>0) . singularValues . double+ pnorm Infinity = pnorm PNorm1 . trans+ pnorm Frobenius = pnorm PNorm2 . flatten++-- | Approximate number of common digits in the maximum element.+relativeError' :: (Normed c t, Container c t) => c t -> c t -> Int+relativeError' x y = dig (norm (x `sub` y) / norm x)+ where norm = pnorm Infinity+ dig r = round $ -logBase 10 (realToFrac r :: Double)+++relativeError :: Num a => (a -> Double) -> a -> a -> Double+relativeError norm a b = r+ where+ na = norm a+ nb = norm b+ nab = norm (a-b)+ mx = max na nb+ mn = min na nb+ r = if mn < peps+ then mx+ else nab/mx+++----------------------------------------------------------------------++-- | Generalized symmetric positive definite eigensystem Av = lBv,+-- for A and B symmetric, B positive definite.+geigSH :: Field t+ => Herm t -- ^ A+ -> Herm t -- ^ B+ -> (Vector Double, Matrix t)+geigSH (Herm a) (Herm b) = geigSH' a b++geigSH' :: Field t+ => Matrix t -- ^ A+ -> Matrix t -- ^ B+ -> (Vector Double, Matrix t)+geigSH' a b = (l,v')+ where+ u = cholSH b+ iu = inv u+ c = ctrans iu <> a <> iu+ (l,v) = eigSH' c+ v' = iu <> v+ (<>) = mXm++--------------------------------------------------------------------------------++-- | A matrix that, by construction, it is known to be complex Hermitian or real symmetric.+--+-- It can be created using 'sym', 'mTm', or 'trustSym', and the matrix can be extracted using 'unSym'.+newtype Herm t = Herm (Matrix t) deriving Show++instance (NFData t, Numeric t) => NFData (Herm t)+ where+ rnf (Herm m) = rnf m++-- | Extract the general matrix from a 'Herm' structure, forgetting its symmetric or Hermitian property.+unSym :: Herm t -> Matrix t+unSym (Herm x) = x++-- | Compute the complex Hermitian or real symmetric part of a square matrix (@(x + tr x)/2@).+sym :: Field t => Matrix t -> Herm t+sym x = Herm (scale 0.5 (tr x `add` x))++-- | Compute the contraction @tr x <> x@ of a general matrix.+mTm :: Numeric t => Matrix t -> Herm t+mTm x = Herm (tr x `mXm` x)++instance Field t => Linear t Herm where+ scale x (Herm m) = Herm (scale x m)++instance Field t => Additive (Herm t) where+ add (Herm a) (Herm b) = Herm (a `add` b)++-- | At your own risk, declare that a matrix is complex Hermitian or real symmetric+-- for usage in 'chol', 'eigSH', etc. Only a triangular part of the matrix will be used.+trustSym :: Matrix t -> Herm t+trustSym x = (Herm x)
+ src/Internal/C/lapack-aux.c view
@@ -0,0 +1,2014 @@+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <math.h>+#include <time.h>+#include <inttypes.h>+#include <complex.h>++typedef double complex TCD;+typedef float complex TCF;++#undef complex++#include "lapack-aux.h"++#define MACRO(B) do {B} while (0)+#define ERROR(CODE) MACRO(return CODE;)+#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})++#define MIN(A,B) ((A)<(B)?(A):(B))+#define MAX(A,B) ((A)>(B)?(A):(B))++// #define DBGL++#ifdef DBGL+#define DEBUGMSG(M) printf("\nLAPACK "M"\n");+#else+#define DEBUGMSG(M)+#endif++#define OK return 0;++// #ifdef DBGL+// #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL);+// #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;);+// #else+// #define DEBUGMSG(M)+// #define OK return 0;+// #endif+++#define INFOMAT(M) printf("%dx%d %d:%d\n",M##r,M##c,M##Xr,M##Xc);++#define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \+ for(q=0;q<M##r*M##c;q++) printf("%.1f ",M##p[q]); printf("\n");}++#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)+#define MARK(RES,CODE) MACRO(if(RES) { ret = CODE; })+#define CONVERGED(RES,CODE) MACRO(if(RES > 0) { ret = CODE; } else if(RES < 0) { ret = RES; })+#define UNWIND(RES,CODE,LABEL) MACRO(if(RES) { ret = CODE; goto LABEL; })++#define BAD_SIZE 2000+#define BAD_CODE 2001+#define MEM 2002+#define BAD_FILE 2003+#define SINGULAR 2004+#define NOCONVER 2005+#define NODEFPOS 2006+#define NOSPRTD 2007++////////////////////////////////////////////////////////////////////////////////+void asm_finit() {+#ifdef i386++// asm("finit");++ static unsigned char buf[108];+ asm("FSAVE %0":"=m" (buf));++ #if FPUDEBUG+ if(buf[8]!=255 || buf[9]!=255) { // print warning in red+ printf("%c[;31mWarning: FPU TAG = %x %x\%c[0m\n",0x1B,buf[8],buf[9],0x1B);+ }+ #endif++ #if NANDEBUG+ asm("FRSTOR %0":"=m" (buf));+ #endif++#endif+}++#if NANDEBUG++#define CHECKNANR(M,msg) \+{ int k; \+for(k=0; k<(M##r * M##c); k++) { \+ if(M##p[k] != M##p[k]) { \+ printf(msg); \+ TRACEMAT(M) \+ /*exit(1);*/ \+ } \+} \+}++#define CHECKNANC(M,msg) \+{ int k; \+for(k=0; k<(M##r * M##c); k++) { \+ if( M##p[k].r != M##p[k].r \+ || M##p[k].i != M##p[k].i) { \+ printf(msg); \+ /*exit(1);*/ \+ } \+} \+}++#else+#define CHECKNANC(M,msg)+#define CHECKNANR(M,msg)+#endif+++////////////////////////////////////////////////////////////////////////////////+//////////////////// real svd ///////////////////////////////////////////////////++int dgesvd_(char *jobu, char *jobvt, integer *m, integer *n,+ doublereal *a, integer *lda, doublereal *s, doublereal *u, integer *+ ldu, doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,+ integer *info);++int svd_l_R(ODMAT(a),ODMAT(u), DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);+ char* jobu = "A";+ if (up==NULL) {+ jobu = "N";+ } else {+ if (uc==q) {+ jobu = "S";+ }+ }+ REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);+ char* jobvt = "A";+ integer ldvt = n;+ if (vp==NULL) {+ jobvt = "N";+ } else {+ if (vr==q) {+ jobvt = "S";+ ldvt = q;+ }+ }+ DEBUGMSG("svd_l_R");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ work, &lwork,+ &res);++ MARK(res, res);+ free(work);+ return ret;+}++// (alternative version)++int dgesdd_(char *jobz, integer *m, integer *n, doublereal *+ a, integer *lda, doublereal *s, doublereal *u, integer *ldu,+ doublereal *vt, integer *ldvt, doublereal *work, integer *lwork,+ integer *iwork, integer *info);++int svd_l_Rdd(ODMAT(a),ODMAT(u), DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES((up == NULL && vp == NULL)+ || (ur==m && vc==n+ && ((uc == q && vr == q)+ || (uc == m && vc==n))),BAD_SIZE);+ char* jobz = "A";+ integer ldvt = n;+ if (up==NULL) {+ jobz = "N";+ } else {+ if (uc==q && vr == q) {+ jobz = "S";+ ldvt = q;+ }+ }+ DEBUGMSG("svd_l_Rdd");+ integer* iwk = (integer*) malloc(8*q*sizeof(integer));+ UNWIND(!iwk,MEM,cleanup0);+ integer lwk = -1;+ integer res;+ // ask for optimal lwk+ double ans;+ dgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,iwk,&res);+ UNWIND(res,res,cleanup1);++ lwk = ans;+ double * workv = (double*)malloc(lwk*sizeof(double));+ UNWIND(!workv,MEM,cleanup1);++ dgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,workv,&lwk,iwk,&res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(workv);+cleanup1:+ free(iwk);+cleanup0:+ return ret;+}++//////////////////// complex svd ////////////////////////////////////++int zgesvd_(char *jobu, char *jobvt, integer *m, integer *n,+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer *info);++int svd_l_C(OCMAT(a),OCMAT(u), DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer q = MIN(m,n);+ REQUIRES(sn==q,BAD_SIZE);+ REQUIRES(up==NULL || (ur==m && (uc==m || uc==q)),BAD_SIZE);+ REQUIRES(vp==NULL || (vc==n && (vr==n || vr==q)),BAD_SIZE);++ char* jobu = "A";+ if (up==NULL) {+ jobu = "N";+ } else {+ if (uc==q) {+ jobu = "S";+ }+ }+ char* jobvt = "A";+ integer ldvt = n;+ if (vp==NULL) {+ jobvt = "N";+ } else {+ if (vr==q) {+ jobvt = "S";+ ldvt = q;+ }+ }DEBUGMSG("svd_l_C");++ double *rwork = (double*) malloc(5*q*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ &ans, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zgesvd_ (jobu,jobvt,+ &m,&n,ap,&m,+ sp,+ up,&m,+ vp,&ldvt,+ work, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++int zgesdd_ (char *jobz, integer *m, integer *n,+ doublecomplex *a, integer *lda, doublereal *s, doublecomplex *u,+ integer *ldu, doublecomplex *vt, integer *ldvt, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer* iwork, integer *info);++int svd_l_Cdd(OCMAT(a),OCMAT(u), DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer mx = MAX(m,n);+ integer mn = MIN(m,n);+ REQUIRES(sn==mn,BAD_SIZE);+ REQUIRES((up == NULL && vp == NULL)+ || (ur==m && vc==n+ && ((uc == mn && vr == mn)+ || (uc == m && vc==n))),BAD_SIZE);+ char* jobz = "A";+ integer ldvt = n;+ if (up==NULL) {+ jobz = "N";+ } else {+ if (uc==mn && vr == mn) {+ jobz = "S";+ ldvt = mn;+ }+ }+ DEBUGMSG("svd_l_Cdd");+ integer* iwk = (integer*) malloc(8*mn*sizeof(integer));+ UNWIND(!iwk,MEM,cleanup0);++ // Docs: http://www.netlib.org/lapack/explore-html/d8/d54/zgesdd_8f_source.html+ // RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))+ // Let mx = max(M,N) and mn = min(M,N).+ // If JOBZ = 'N', LRWORK >= 5*mn (LAPACK <= 3.6 needs 7*mn);+ // else if mx >> mn, LRWORK >= 5*mn*mn + 5*mn;+ // else LRWORK >= max( 5*mn*mn + 5*mn,+ // 2*mx*mn + 2*mn*mn + mn ).+ int lrwk;+ if (*jobz == 'N') {+ lrwk = 7*mn;+ } else {+ lrwk = MAX(5*mn*mn + 7*mn, 2*mx*mn + 2*mn*mn + mn);+ }+ double *rwk = (double*)malloc(MAX(1, lrwk)*sizeof(double));;+ UNWIND(!rwk,MEM,cleanup1);++ integer lwk = -1;+ integer res;+ // ask for optimal lwk+ doublecomplex ans;+ zgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,&ans,&lwk,rwk,iwk,&res);+ UNWIND(res,res,cleanup2);++ lwk = ans.r;+ doublecomplex * workv = (doublecomplex*)malloc(lwk*sizeof(doublecomplex));+ UNWIND(!workv,MEM,cleanup2);++ zgesdd_ (jobz,&m,&n,ap,&m,sp,up,&m,vp,&ldvt,workv,&lwk,rwk,iwk,&res);+ UNWIND(res,res,cleanup3);++cleanup3:+ free(workv);+cleanup2:+ free(rwk);+cleanup1:+ free(iwk);+cleanup0:+ return ret;+}++//////////////////// general complex eigensystem ////////////++int zgeev_(char *jobvl, char *jobvr, integer *n,+ doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl,+ integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work,+ integer *lwork, doublereal *rwork, integer *info);++int eig_l_C(OCMAT(a), OCMAT(u), CVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac==n && sn==n, BAD_SIZE);+ REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);+ char jobvl = up==NULL?'N':'V';+ REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);+ char jobvr = vp==NULL?'N':'V';+ DEBUGMSG("eig_l_C");++ double *rwork = (double*) malloc(2*n*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ sp,+ up,&n,+ vp,&n,+ &ans, &lwork,+ rwork,+ &res);++ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ sp,+ up,&n,+ vp,&n,+ work, &lwork,+ rwork,+ &res);++ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++++//////////////////// general real eigensystem ////////////++int dgeev_(char *jobvl, char *jobvr, integer *n, doublereal *+ a, integer *lda, doublereal *wr, doublereal *wi, doublereal *vl,+ integer *ldvl, doublereal *vr, integer *ldvr, doublereal *work,+ integer *lwork, integer *info);++int eig_l_R(ODMAT(a),ODMAT(u), CVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac==n && sn==n, BAD_SIZE);+ REQUIRES(up==NULL || (ur==n && uc==n), BAD_SIZE);+ char jobvl = up==NULL?'N':'V';+ REQUIRES(vp==NULL || (vr==n && vc==n), BAD_SIZE);+ char jobvr = vp==NULL?'N':'V';+ DEBUGMSG("eig_l_R");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ (double*)sp, (double*)sp+n,+ up,&n,+ vp,&n,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);+ dgeev_ (&jobvl,&jobvr,+ &n,ap,&n,+ (double*)sp, (double*)sp+n,+ up,&n,+ vp,&n,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// generalized real eigensystem ////////////++int dggev_(char *jobvl, char *jobvr, integer *n,+ doublereal *a, integer *lda, doublereal *b, integer *ldb,+ doublereal *alphar, doublereal *alphai, doublereal *beta,+ doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,+ doublereal *work,+ integer *lwork, integer *info);++int eig_l_G(ODMAT(a), ODMAT(b), CVEC(alpha), DVEC(beta), ODMAT(vl), ODMAT(vr)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac == n && br == n && bc == n && alphan == n && betan == n, BAD_SIZE);+ REQUIRES(vlp==NULL || (vlr==n && vlc==n), BAD_SIZE);+ char jobvl = vlp==NULL?'N':'V';+ REQUIRES(vrp==NULL || (vrr==n && vrc==n), BAD_SIZE);+ char jobvr = vrp==NULL?'N':'V';+ DEBUGMSG("eig_l_G");+ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ double ans;+ dggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ (double*)alphap, (double*)alphap+n, betap,+ vlp, &n, vrp, &n,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ (double*)alphap, (double*)alphap+n, betap,+ vlp, &n, vrp, &n,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// generalized complex eigensystem ////////////++int zggev_(char *jobvl, char *jobvr, integer *n,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ doublecomplex *alphar, doublecomplex *beta,+ doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,+ doublecomplex *work, integer *lwork,+ doublereal *rwork, integer *info);++int eig_l_GC(OCMAT(a), OCMAT(b), CVEC(alpha), CVEC(beta), OCMAT(vl), OCMAT(vr)) {+ integer ret = 0;+ integer n = ar;+ REQUIRES(ac == n && br == n && bc == n && alphan == n && betan == n, BAD_SIZE);+ REQUIRES(vlp==NULL || (vlr==n && vlc==n), BAD_SIZE);+ char jobvl = vlp==NULL?'N':'V';+ REQUIRES(vrp==NULL || (vrr==n && vrc==n), BAD_SIZE);+ char jobvr = vrp==NULL?'N':'V';+ DEBUGMSG("eig_l_GC");+ double *rwork = (double*) malloc(8*n*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ alphap, betap,+ vlp, &n, vrp, &n,+ &ans, &lwork,+ rwork, &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zggev_ (&jobvl,&jobvr,+ &n,+ ap,&n,bp,&n,+ alphap, betap,+ vlp, &n, vrp, &n,+ work, &lwork,+ rwork, &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++//////////////////// symmetric real eigensystem ////////////++int dsyev_(char *jobz, char *uplo, integer *n, doublereal *a,+ integer *lda, doublereal *w, doublereal *work, integer *lwork,+ integer *info);++int eig_l_S(int wantV,DVEC(s),ODMAT(v)) {+ integer ret = 0;+ integer n = sn;+ REQUIRES(vr==n && vc==n, BAD_SIZE);+ char jobz = wantV?'V':'N';+ DEBUGMSG("eig_l_S");+ integer lwork = -1;+ char uplo = 'U';+ integer res;+ // ask for optimal lwork+ double ans;+ dsyev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ &ans, &lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dsyev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ work, &lwork,+ &res);+ MARK(res,res);++ free(work);+ return ret;+}++//////////////////// hermitian complex eigensystem ////////////++int zheev_(char *jobz, char *uplo, integer *n, doublecomplex+ *a, integer *lda, doublereal *w, doublecomplex *work, integer *lwork,+ doublereal *rwork, integer *info);++int eig_l_H(int wantV,DVEC(s),OCMAT(v)) {+ integer ret = 0;+ integer n = sn;++ REQUIRES(vr==n && vc==n, BAD_SIZE);+ char jobz = wantV?'V':'N';+ DEBUGMSG("eig_l_H");+ double *rwork = (double*) malloc((3*n-2)*sizeof(double));+ UNWIND(!rwork,MEM,cleanup0);++ integer lwork = -1;+ char uplo = 'U';+ integer res;+ // ask for optimal lwork+ doublecomplex ans;+ zheev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ &ans, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zheev_ (&jobz,&uplo,+ &n,vp,&n,+ sp,+ work, &lwork,+ rwork,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(work);+cleanup1:+ free(rwork);+cleanup0:+ return ret;+}++//////////////////// general real linear system ////////////++int dgesv_(integer *n, integer *nrhs, doublereal *a, integer+ *lda, integer *ipiv, doublereal *b, integer *ldb, integer *info);++int linearSolveR_l(ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer n = ar;+ integer nhrs = bc;++ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("linearSolveR_l");+ integer * ipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!ipiv,MEM);++ integer res;+ dgesv_ (&n,&nhrs,+ ap, &n,+ ipiv,+ bp, &n,+ &res);+ CONVERGED(res,SINGULAR);++ free(ipiv);+ return ret;+}++//////////////////// general complex linear system ////////////++int zgesv_(integer *n, integer *nrhs, doublecomplex *a,+ integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer *+ info);++int linearSolveC_l(OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer n = ar;+ integer nhrs = bc;++ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("linearSolveC_l");+ integer * ipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!ipiv,MEM);++ integer res;+ zgesv_ (&n,&nhrs,+ ap, &n,+ ipiv,+ bp, &n,+ &res);+ CONVERGED(res,SINGULAR);++ free(ipiv);+ return ret;+}++//////// symmetric positive definite real linear system using Cholesky ////////////++int dpotrs_(char *uplo, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *+ info);++int cholSolveR_l(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("cholSolveR_l");+ integer res;+ dpotrs_ ("U",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// Hermitian positive definite real linear system using Cholesky ////////////++int zpotrs_(char *uplo, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ integer *info);++int cholSolveC_l(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("cholSolveC_l");+ integer res;+ zpotrs_ ("U",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// triangular real linear system ////////////++int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, integer *+ info);++int triSolveR_l_u(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveR_l_u");+ integer res;+ dtrtrs_ ("U",+ "N",+ "N",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++int triSolveR_l_l(KODMAT(a),ODMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveR_l_l");+ integer res;+ dtrtrs_ ("L",+ "N",+ "N",+ &n,&nhrs,+ (double*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// triangular complex linear system ////////////++int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ integer *info);++int triSolveC_l_u(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveC_l_u");+ integer res;+ ztrtrs_ ("U",+ "N",+ "N",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++int triSolveC_l_l(KOCMAT(a),OCMAT(b)) {+ integer n = ar;+ integer lda = aXc;+ integer nhrs = bc;+ REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE);+ DEBUGMSG("triSolveC_l_u");+ integer res;+ ztrtrs_ ("L",+ "N",+ "N",+ &n,&nhrs,+ (doublecomplex*)ap, &lda,+ bp, &n,+ &res);+ CHECK(res,res);+ OK+}++//////// tridiagonal real linear system ////////////++int dgttrf_(integer *n,+ doublereal *dl, doublereal *d, doublereal *du, doublereal *du2,+ integer *ipiv,+ integer *info);++int dgttrs_(char *trans, integer *n, integer *nrhs,+ doublereal *dl, doublereal *d, doublereal *du, doublereal *du2,+ integer *ipiv, doublereal *b, integer *ldb,+ integer *info);++int triDiagSolveR_l(DVEC(dl), DVEC(d), DVEC(du), ODMAT(b)) {+ integer ret = 0;+ integer n = dn;+ integer nhrs = bc;+ REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE);+ DEBUGMSG("triDiagSolveR_l");+ integer res;+ integer* ipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!ipiv,MEM,cleanup0);++ double* du2 = (double*)malloc((n - 2)*sizeof(double));+ UNWIND(!du2,MEM,cleanup1);++ dgttrf_ (&n,+ dlp, dp, dup, du2,+ ipiv,+ &res);+ UNWIND(res,res,cleanup2);++ dgttrs_ ("N",+ &n,&nhrs,+ dlp, dp, dup, du2,+ ipiv, bp, &n,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(du2);+cleanup1:+ free(ipiv);+cleanup0:+ return ret;+}++//////// tridiagonal complex linear system ////////////++int zgttrf_(integer *n,+ doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2,+ integer *ipiv,+ integer *info);++int zgttrs_(char *trans, integer *n, integer *nrhs,+ doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2,+ integer *ipiv, doublecomplex *b, integer *ldb,+ integer *info);++int triDiagSolveC_l(CVEC(dl), CVEC(d), CVEC(du), OCMAT(b)) {+ integer ret = 0;+ integer n = dn;+ integer nhrs = bc;+ REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE);+ DEBUGMSG("triDiagSolveC_l");+ integer res;+ integer* ipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!ipiv,MEM,cleanup0);++ doublecomplex* du2 = (doublecomplex*)malloc((n - 2)*sizeof(doublecomplex));+ UNWIND(!du2,MEM,cleanup1);++ zgttrf_ (&n,+ dlp, dp, dup, du2,+ ipiv,+ &res);+ UNWIND(res,res,cleanup2);++ zgttrs_ ("N",+ &n,&nhrs,+ dlp, dp, dup, du2,+ ipiv, bp, &n,+ &res);+ UNWIND(res,res,cleanup2);++cleanup2:+ free(du2);+cleanup1:+ free(ipiv);+cleanup0:+ return ret;+}++//////////////////// least squares real linear system ////////////++int dgels_(char *trans, integer *m, integer *n, integer *+ nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb,+ doublereal *work, integer *lwork, integer *info);++int linearSolveLSR_l(ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveLSR_l");+ integer res;+ integer lwork = -1;+ double ans;+ dgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ &ans,&lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ CHECK(!work,MEM);++ dgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ work,&lwork,+ &res);+ CONVERGED(res,SINGULAR);++ free(work);+ return ret;+}++//////////////////// least squares complex linear system ////////////++int zgels_(char *trans, integer *m, integer *n, integer *+ nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,+ doublecomplex *work, integer *lwork, integer *info);++int linearSolveLSC_l(OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveLSC_l");+ integer res;+ integer lwork = -1;+ doublecomplex ans;+ zgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ &ans,&lwork,+ &res);+ CHECK(res,res);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!work,MEM);++ zgels_ ("N",&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ work,&lwork,+ &res);+ CONVERGED(res,SINGULAR);++ free(work);+ return ret;+}++//////////////////// least squares real linear system using SVD ////////////++int dgelss_(integer *m, integer *n, integer *nrhs,+ doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *+ s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork,+ integer *info);++int linearSolveSVDR_l(double rcond,ODMAT(a),ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveSVDR_l");++ double * S = (double*)malloc(MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup0);++ integer res;+ integer lwork = -1;+ integer rank;+ double ans;+ dgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ &ans,&lwork,+ &res);+ UNWIND(res,res,cleanup1);++ lwork = ceil(ans);+ double * work = (double*)malloc(lwork*sizeof(double));+ UNWIND(!work,MEM,cleanup1);++ dgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ work,&lwork,+ &res);++ CONVERGED(res,NOCONVER);++ free(work);+cleanup1:+ free(S);+cleanup0:+ return ret;++}++//////////////////// least squares complex linear system using SVD ////////////++int zgelss_(integer *m, integer *n, integer *nhrs,+ doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s,+ doublereal *rcond, integer* rank,+ doublecomplex *work, integer* lwork, doublereal* rwork,+ integer *info);++int linearSolveSVDC_l(double rcond, OCMAT(a),OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer nrhs = bc;+ integer ldb = bXc;+ REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE);+ DEBUGMSG("linearSolveSVDC_l");++ double*S = (double*)malloc(MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup0);++ double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double));+ UNWIND(!S,MEM,cleanup1);++ integer res;+ integer lwork = -1;+ integer rank;+ doublecomplex ans;+ zgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ &ans,&lwork,+ RWORK,+ &res);+ UNWIND(res,res,cleanup2);++ lwork = ceil(ans.r);+ doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup2);++ zgelss_ (&m,&n,&nrhs,+ ap,&m,+ bp,&ldb,+ S,+ &rcond,&rank,+ work,&lwork,+ RWORK,+ &res);+ CONVERGED(res,NOCONVER);++ free(work);+cleanup2:+ free(RWORK);+cleanup1:+ free(S);+cleanup0:+ return ret;++}++//////////////////// Cholesky factorization /////////////////////////++int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info);++int chol_l_H(OCMAT(l)) {+ integer n = lr;+ REQUIRES(n>=1 && lc == n,BAD_SIZE);+ DEBUGMSG("chol_l_H");+ char uplo = 'U';+ integer res;+ zpotrf_ (&uplo,&n,lp,&n,&res);+ CHECK(res>0,NODEFPOS);+ CHECK(res,res);+ doublecomplex zero = {0.,0.};+ int r,c;+ for (r=0; r<lr; r++) {+ for(c=0; c<r; c++) {+ AT(l,r,c) = zero;+ }+ }+ OK+}+++int dpotrf_(char *uplo, integer *n, doublereal *a, integer * lda, integer *info);++int chol_l_S(ODMAT(l)) {+ integer n = lr;+ REQUIRES(n>=1 && lc == n,BAD_SIZE);+ DEBUGMSG("chol_l_S");+ char uplo = 'U';+ integer res;+ dpotrf_ (&uplo,&n,lp,&n,&res);+ CHECK(res>0,NODEFPOS);+ CHECK(res,res);+ int r,c;+ for (r=0; r<lr; r++) {+ for(c=0; c<r; c++) {+ AT(l,r,c) = 0.;+ }+ }+ OK+}++//////////////////// QR factorization /////////////////////////++int dgeqr2_(integer *m, integer *n, doublereal *a, integer *+ lda, doublereal *tau, doublereal *work, integer *info);++int qr_l_R(DVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE);+ DEBUGMSG("qr_l_R");+ double *WORK = (double*)malloc(n*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int zgeqr2_(integer *m, integer *n, doublecomplex *a,+ integer *lda, doublecomplex *tau, doublecomplex *work, integer *info);++int qr_l_C(CVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE);+ DEBUGMSG("qr_l_C");++ doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int dorgqr_(integer *m, integer *n, integer *k, doublereal *+ a, integer *lda, doublereal *tau, doublereal *work, integer *lwork,+ integer *info);++int c_dorgqr(KDVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = MIN(rc,rr);+ integer k = taun;+ DEBUGMSG("c_dorgqr");+ integer lwork = 8*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ dorgqr_ (&m,&n,&k,rp,&m,(double*)taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++int zungqr_(integer *m, integer *n, integer *k,+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *+ work, integer *lwork, integer *info);++int c_zungqr(KCVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = MIN(rc,rr);+ integer k = taun;+ DEBUGMSG("z_ungqr");+ integer lwork = 8*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ zungqr_ (&m,&n,&k,rp,&m,(doublecomplex*)taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}+++//////////////////// Hessenberg factorization /////////////////////////++int dgehrd_(integer *n, integer *ilo, integer *ihi,+ doublereal *a, integer *lda, doublereal *tau, doublereal *work,+ integer *lwork, integer *info);++int hess_l_R(DVEC(tau), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE);+ DEBUGMSG("hess_l_R");+ integer lwork = 5*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ CHECK(!WORK,MEM);++ integer res;+ integer one = 1;+ dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}+++int zgehrd_(integer *n, integer *ilo, integer *ihi,+ doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *+ work, integer *lwork, integer *info);++int hess_l_C(CVEC(tau), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE);+ DEBUGMSG("hess_l_C");+ integer lwork = 5*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ CHECK(!WORK,MEM);++ integer res;+ integer one = 1;+ zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res);+ MARK(res,res);++ free(WORK);+ return ret;+}++//////////////////// Schur factorization /////////////////////////++int dgees_(char *jobvs, char *sort, L_fp select, integer *n,+ doublereal *a, integer *lda, integer *sdim, doublereal *wr,+ doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work,+ integer *lwork, logical *bwork, integer *info);++int schur_l_R(ODMAT(u), ODMAT(s)) {+ integer ret = 0;+ integer m = sr;+ integer n = sc;+ REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE);+ DEBUGMSG("schur_l_R");+ integer lwork = 6*n; // FIXME+ double *WORK = (double*)malloc(lwork*sizeof(double));+ UNWIND(!WORK,MEM,cleanup0);+ double *WR = (double*)malloc(n*sizeof(double));+ UNWIND(!WORK,MEM,cleanup1);+ double *WI = (double*)malloc(n*sizeof(double));+ UNWIND(!WORK,MEM,cleanup2);+ // WR and WI not really required in this call+ logical *BWORK = (logical*)malloc(n*sizeof(logical));+ UNWIND(!BWORK,MEM,cleanup3);+ integer res;+ integer sdim;+ dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res);+ CONVERGED(res,NOCONVER);++ free(BWORK);+cleanup3:+ free(WI);+cleanup2:+ free(WR);+cleanup1:+ free(WORK);+cleanup0:+ return ret;+}+++int zgees_(char *jobvs, char *sort, L_fp select, integer *n,+ doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w,+ doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork,+ doublereal *rwork, logical *bwork, integer *info);++int schur_l_C(OCMAT(u), OCMAT(s)) {+ integer ret = 0;+ integer m = sr;+ integer n = sc;+ REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE);+ DEBUGMSG("schur_l_C");+ integer lwork = 6*n; // FIXME+ doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!WORK,MEM,cleanup0);++ doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex));+ UNWIND(!W,MEM,cleanup1);++ // W not really required in this call+ logical *BWORK = (logical*)malloc(n*sizeof(logical));+ UNWIND(!BWORK,MEM,cleanup2);++ double *RWORK = (double*)malloc(n*sizeof(double));+ UNWIND(!RWORK,MEM,cleanup3);+ integer res;+ integer sdim;+ zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W,+ up,&n,+ WORK,&lwork,RWORK,BWORK,&res);+ CONVERGED(res,NOCONVER);++ free(RWORK);+cleanup3:+ free(BWORK);+cleanup2:+ free(W);+cleanup1:+ free(WORK);+cleanup0:+ return ret;+}++//////////////////// LU factorization /////////////////////////++int dgetrf_(integer *m, integer *n, doublereal *a, integer *+ lda, integer *ipiv, integer *info);++int lu_l_R(DVEC(ipiv), ODMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);+ REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);+ DEBUGMSG("lu_l_R");+ integer* auxipiv = (integer*)malloc(mn*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ dgetrf_ (&m,&n,rp,&m,auxipiv,&res);+ if(res>0) {+ res = 0; // FIXME+ }+ UNWIND(res,res,cleanup1);++ for (int k=0; k<mn; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++int zgetrf_(integer *m, integer *n, doublecomplex *a,+ integer *lda, integer *ipiv, integer *info);++int lu_l_C(DVEC(ipiv), OCMAT(r)) {+ integer ret = 0;+ integer m = rr;+ integer n = rc;+ integer mn = MIN(m,n);++ REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE);+ DEBUGMSG("lu_l_C");+ integer* auxipiv = (integer*)malloc(mn*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ zgetrf_ (&m,&n,rp,&m,auxipiv,&res);+ if(res>0) {+ res = 0; // FIXME+ }+ UNWIND(res,res,cleanup1);++ for (int k=0; k<mn; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++//////////////////// LU substitution /////////////////////////++int dgetrs_(char *trans, integer *n, integer *nrhs,+ doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer *+ ldb, integer *info);++int luS_l_R(KODMAT(a), KDVEC(ipiv), ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ dgetrs_ ("N",&n,&nrhs,(/*no const (!?)*/ double*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++int zgetrs_(char *trans, integer *n, integer *nrhs,+ doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b,+ integer *ldb, integer *info);++int luS_l_C(KOCMAT(a), KDVEC(ipiv), OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ zgetrs_ ("N",&n,&nrhs,(doublecomplex*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++//////////////////// LDL factorization /////////////////////////++int dsytrf_(char *uplo, integer *n, doublereal *a, integer *lda, integer *ipiv,+ doublereal *work, integer *lwork, integer *info);++int ldl_R(DVEC(ipiv), ODMAT(r)) {+ integer ret = 0;+ integer n = rr;++ REQUIRES(n>=1 && rc==n && ipivn == n, BAD_SIZE);+ DEBUGMSG("ldl_R");++ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ integer lda = rXc;+ integer lwork = -1;+ doublereal ans;+ dsytrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res);+ lwork = ceil(ans);+ doublereal* work = (doublereal*)malloc(lwork*sizeof(doublereal));+ UNWIND(!work,MEM,cleanup1);++ dsytrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res);+ UNWIND(res,res,cleanup2);++ int k;+ for (k=0; k<n; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup2:+ free(work);+cleanup1:+ free(auxipiv);+cleanup0:+ return ret;+}+++int zhetrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *ipiv,+ doublecomplex *work, integer *lwork, integer *info);++int ldl_C(DVEC(ipiv), OCMAT(r)) {+ integer ret = 0;+ integer n = rr;++ REQUIRES(n>=1 && rc==n && ipivn == n, BAD_SIZE);+ DEBUGMSG("ldl_R");+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ UNWIND(!auxipiv,MEM,cleanup0);++ integer res;+ integer lda = rXc;+ integer lwork = -1;+ doublecomplex ans;+ zhetrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res);+ lwork = ceil(ans.r);+ doublecomplex* work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex));+ UNWIND(!work,MEM,cleanup1);++ zhetrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res);+ UNWIND(res,res,cleanup2);+ int k;+ for (k=0; k<n; k++) {+ ipivp[k] = auxipiv[k];+ }++cleanup2:+ free(work);+cleanup1:+ free(auxipiv);+cleanup0:+ return ret;++}++//////////////////// LDL solve /////////////////////////++int dsytrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda,+ integer *ipiv, doublereal *b, integer *ldb, integer *info);++int ldl_S_R(KODMAT(a), KDVEC(ipiv), ODMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ dsytrs_ ("L",&n,&nrhs,(/*no const (!?)*/ double*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++int zhetrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda,+ integer *ipiv, doublecomplex *b, integer *ldb, integer *info);++int ldl_S_C(KOCMAT(a), KDVEC(ipiv), OCMAT(b)) {+ integer ret = 0;+ integer m = ar;+ integer n = ac;+ integer lda = aXc;+ integer mrhs = br;+ integer nrhs = bc;++ REQUIRES(m==n && m==mrhs && m==ipivn,BAD_SIZE);+ integer* auxipiv = (integer*)malloc(n*sizeof(integer));+ CHECK(!auxipiv,MEM);++ for (int k=0; k<n; k++) {+ auxipiv[k] = (integer)ipivp[k];+ }+ integer res;+ zhetrs_ ("L",&n,&nrhs,(doublecomplex*)ap,&lda,auxipiv,bp,&mrhs,&res);+ MARK(res,res);++ free(auxipiv);+ return ret;+}+++//////////////////// Matrix Product /////////////////////////++void dgemm_(char *, char *, integer *, integer *, integer *,+ double *, const double *, integer *, const double *,+ integer *, double *, double *, integer *);++int multiplyR(int ta, int tb, KODMAT(a),KODMAT(b),ODMAT(r)) {+ DEBUGMSG("dgemm_");+ CHECKNANR(a,"NaN multR Input\n")+ CHECKNANR(b,"NaN multR Input\n")+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ double alpha = 1;+ double beta = 0;+ dgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);+ CHECKNANR(r,"NaN multR Output\n")+ OK+}++void zgemm_(char *, char *, integer *, integer *, integer *,+ doublecomplex *, const doublecomplex *, integer *, const doublecomplex *,+ integer *, doublecomplex *, doublecomplex *, integer *);++int multiplyC(int ta, int tb, KOCMAT(a),KOCMAT(b),OCMAT(r)) {+ DEBUGMSG("zgemm_");+ CHECKNANC(a,"NaN multC Input\n")+ CHECKNANC(b,"NaN multC Input\n")+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ doublecomplex alpha = {1,0};+ doublecomplex beta = {0,0};+ zgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,+ ap,&lda,+ bp,&ldb,&beta,+ rp,&ldc);+ CHECKNANC(r,"NaN multC Output\n")+ OK+}++void sgemm_(char *, char *, integer *, integer *, integer *,+ float *, const float *, integer *, const float *,+ integer *, float *, float *, integer *);++int multiplyF(int ta, int tb, KOFMAT(a),KOFMAT(b),OFMAT(r)) {+ DEBUGMSG("sgemm_");+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ float alpha = 1;+ float beta = 0;+ sgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,ap,&lda,bp,&ldb,&beta,rp,&ldc);+ OK+}++void cgemm_(char *, char *, integer *, integer *, integer *,+ complex *, const complex *, integer *, const complex *,+ integer *, complex *, complex *, integer *);++int multiplyQ(int ta, int tb, KOQMAT(a),KOQMAT(b),OQMAT(r)) {+ DEBUGMSG("cgemm_");+ integer m = ta?ac:ar;+ integer n = tb?br:bc;+ integer k = ta?ar:ac;+ integer lda = aXc;+ integer ldb = bXc;+ integer ldc = rXc;+ complex alpha = {1,0};+ complex beta = {0,0};+ cgemm_(ta?"T":"N",tb?"T":"N",&m,&n,&k,&alpha,+ ap,&lda,+ bp,&ldb,&beta,+ rp,&ldc);+ OK+}+++#define MULT_IMP_VER(OP) \+ { TRAV(r,i,j) { \+ int k; \+ AT(r,i,j) = 0; \+ for (k=0;k<ac;k++) { \+ OP \+ } \+ } \+ }++#define MULT_IMP(M) { \+ if (m==1) { \+ MULT_IMP_VER( AT(r,i,j) += AT(a,i,k) * AT(b,k,j); ) \+ } else { \+ MULT_IMP_VER( AT(r,i,j) = M(AT(r,i,j) + M(AT(a,i,k) * AT(b,k,j), m) , m) ; ) \+ } OK }++int multiplyI(int m, KOIMAT(a), KOIMAT(b), OIMAT(r)) MULT_IMP(mod)+int multiplyL(int64_t m, KOLMAT(a), KOLMAT(b), OLMAT(r)) MULT_IMP(mod_l)++/////////////////////////////// inplace row ops ////////////////////////////////++#define AXPY_IMP { \+ int j; \+ for(j=j1; j<=j2; j++) { \+ AT(r,i2,j) += a*AT(r,i1,j); \+ } OK }++#define AXPY_MOD_IMP(M) { \+ int j; \+ for(j=j1; j<=j2; j++) { \+ AT(r,i2,j) = M(AT(r,i2,j) + M(a*AT(r,i1,j), m) , m); \+ } OK }+++#define SCAL_IMP { \+ int i,j; \+ for(i=i1; i<=i2; i++) { \+ for(j=j1; j<=j2; j++) { \+ AT(r,i,j) = a*AT(r,i,j); \+ } \+ } OK }++#define SCAL_MOD_IMP(M) { \+ int i,j; \+ for(i=i1; i<=i2; i++) { \+ for(j=j1; j<=j2; j++) { \+ AT(r,i,j) = M(a*AT(r,i,j) , m); \+ } \+ } OK }+++#define SWAP_IMP(T) { \+ T aux; \+ int k; \+ if (i1 != i2) { \+ for (k=j1; k<=j2; k++) { \+ aux = AT(r,i1,k); \+ AT(r,i1,k) = AT(r,i2,k); \+ AT(r,i2,k) = aux; \+ } \+ } OK }+++#define ROWOP_IMP(T) { \+ T a = *pa; \+ switch(code) { \+ case 0: AXPY_IMP \+ case 1: SCAL_IMP \+ case 2: SWAP_IMP(T) \+ default: ERROR(BAD_CODE); \+ } \+}++#define ROWOP_MOD_IMP(T,M) { \+ T a = *pa; \+ switch(code) { \+ case 0: AXPY_MOD_IMP(M) \+ case 1: SCAL_MOD_IMP(M) \+ case 2: SWAP_IMP(T) \+ default: ERROR(BAD_CODE); \+ } \+}+++#define ROWOP(T) int rowop_##T(int code, T* pa, int i1, int i2, int j1, int j2, MATG(T,r)) ROWOP_IMP(T)++#define ROWOP_MOD(T,M) int rowop_mod_##T(T m, int code, T* pa, int i1, int i2, int j1, int j2, MATG(T,r)) ROWOP_MOD_IMP(T,M)++ROWOP(double)+ROWOP(float)+ROWOP(TCD)+ROWOP(TCF)+ROWOP(int32_t)+ROWOP(int64_t)+ROWOP_MOD(int32_t,mod)+ROWOP_MOD(int64_t,mod_l)++/////////////////////////////// inplace GEMM ////////////////////////////////++#define GEMM(T) int gemm_##T(VECG(T,c),MATG(T,a),MATG(T,b),MATG(T,r)) { \+ T a = cp[0], b = cp[1]; \+ T t; \+ int k; \+ { TRAV(r,i,j) { \+ t = 0; \+ for(k=0; k<ac; k++) { \+ t += AT(a,i,k) * AT(b,k,j); \+ } \+ AT(r,i,j) = b*AT(r,i,j) + a*t; \+ } \+ } OK }+++GEMM(double)+GEMM(float)+GEMM(TCD)+GEMM(TCF)+GEMM(int32_t)+GEMM(int64_t)++#define GEMM_MOD(T,M) int gemm_mod_##T(T m, VECG(T,c),MATG(T,a),MATG(T,b),MATG(T,r)) { \+ T a = cp[0], b = cp[1]; \+ int k; \+ T t; \+ { TRAV(r,i,j) { \+ t = 0; \+ for(k=0; k<ac; k++) { \+ t = M(t+M(AT(a,i,k) * AT(b,k,j))); \+ } \+ AT(r,i,j) = M(M(b*AT(r,i,j)) + M(a*t)); \+ } \+ } OK }+++#define MOD32(X) mod(X,m)+#define MOD64(X) mod_l(X,m)++GEMM_MOD(int32_t,MOD32)+GEMM_MOD(int64_t,MOD64)++////////////////// sparse matrix-product ///////////////////////////////////////+++int smXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {+ int r, c;+ for (r = 0; r < rowsn - 1; r++) {+ rp[r] = 0;+ for (c = rowsp[r]; c < rowsp[r+1]; c++) {+ rp[r] += valsp[c-1] * xp[colsp[c-1]-1];+ }+ }+ OK+}++int smTXv(KDVEC(vals),KIVEC(cols),KIVEC(rows),KDVEC(x),DVEC(r)) {+ int r,c;+ for (c = 0; c < rn; c++) {+ rp[c] = 0;+ }+ for (r = 0; r < rowsn - 1; r++) {+ for (c = rowsp[r]; c < rowsp[r+1]; c++) {+ rp[colsp[c-1]-1] += valsp[c-1] * xp[r];+ }+ }+ OK+}+++//////////////////////// extract /////////////////////////////////++#define EXTRACT_IMP { \+ int i,j,si,sj,ni,nj; \+ ni = modei ? in : ip[1]-ip[0]+1; \+ nj = modej ? jn : jp[1]-jp[0]+1; \+ \+ for (i=0; i<ni; i++) { \+ si = modei ? ip[i] : i+ip[0]; \+ \+ for (j=0; j<nj; j++) { \+ sj = modej ? jp[j] : j+jp[0]; \+ \+ AT(r,i,j) = AT(m,si,sj); \+ } \+ } OK }++#define EXTRACT(T) int extract##T(int modei, int modej, KIVEC(i), KIVEC(j), KO##T##MAT(m), O##T##MAT(r)) EXTRACT_IMP++EXTRACT(D)+EXTRACT(F)+EXTRACT(C)+EXTRACT(Q)+EXTRACT(I)+EXTRACT(L)++//////////////////////// setRect /////////////////////////////////++#define SETRECT(T) \+int setRect##T(int i, int j, KO##T##MAT(m), O##T##MAT(r)) { \+ { TRAV(m,a,b) { \+ int x = a+i, y = b+j; \+ if(x>=0 && x<rr && y>=0 && y<rc) { \+ AT(r,x,y) = AT(m,a,b); \+ } \+ } \+ } OK }++SETRECT(D)+SETRECT(F)+SETRECT(C)+SETRECT(Q)+SETRECT(I)+SETRECT(L)++//////////////////////// remap /////////////////////////////////++#define REMAP_IMP \+ REQUIRES(ir==jr && ic==jc && ir==rr && ic==rc ,BAD_SIZE); \+ { TRAV(r,a,b) { AT(r,a,b) = AT(m,AT(i,a,b),AT(j,a,b)); } \+ } \+ OK++int remapD(KOIMAT(i), KOIMAT(j), KODMAT(m), ODMAT(r)) {+ REMAP_IMP+}++int remapF(KOIMAT(i), KOIMAT(j), KOFMAT(m), OFMAT(r)) {+ REMAP_IMP+}++int remapI(KOIMAT(i), KOIMAT(j), KOIMAT(m), OIMAT(r)) {+ REMAP_IMP+}++int remapL(KOIMAT(i), KOIMAT(j), KOLMAT(m), OLMAT(r)) {+ REMAP_IMP+}++int remapC(KOIMAT(i), KOIMAT(j), KOCMAT(m), OCMAT(r)) {+ REMAP_IMP+}++int remapQ(KOIMAT(i), KOIMAT(j), KOQMAT(m), OQMAT(r)) {+ REMAP_IMP+}++////////////////////////////////////////////////////////////////////////////////++int saveMatrix(char * file, char * format, KODMAT(a)){+ FILE * fp;+ fp = fopen (file, "w");+ int r, c;+ for (r=0;r<ar; r++) {+ for (c=0; c<ac; c++) {+ fprintf(fp,format,AT(a,r,c));+ if (c<ac-1) {+ fprintf(fp," ");+ } else {+ fprintf(fp,"\n");+ }+ }+ }+ fclose(fp);+ OK+}+
+ src/Internal/C/lapack-aux.h view
@@ -0,0 +1,111 @@+/*+ * We have copied the definitions in f2c.h required+ * to compile clapack.h, modified to support both+ * 32 and 64 bit++ http://opengrok.creo.hu/dragonfly/xref/src/contrib/gcc-3.4/libf2c/readme.netlib+ http://www.ibm.com/developerworks/library/l-port64.html+ */++#ifdef _LP64+typedef int integer;+typedef unsigned int uinteger;+typedef int logical;+typedef long longint; /* system-dependent */+typedef unsigned long ulongint; /* system-dependent */+#else+typedef long int integer;+typedef unsigned long int uinteger;+typedef long int logical;+typedef long long longint; /* system-dependent */+typedef unsigned long long ulongint; /* system-dependent */+#endif++typedef char *address;+typedef short int shortint;+typedef float real;+typedef double doublereal;+typedef struct { real r, i; } complex;+typedef struct { doublereal r, i; } doublecomplex;+typedef short int shortlogical;+typedef char logical1;+typedef char integer1;++typedef logical (*L_fp)();+typedef short ftnlen;++/********************************************************/++#define IVEC(A) int A##n, int*A##p+#define LVEC(A) int A##n, int64_t*A##p+#define FVEC(A) int A##n, float*A##p+#define DVEC(A) int A##n, double*A##p+#define QVEC(A) int A##n, complex*A##p+#define CVEC(A) int A##n, doublecomplex*A##p+#define PVEC(A) int A##n, void* A##p, int A##s++#define IMAT(A) int A##r, int A##c, int* A##p+#define LMAT(A) int A##r, int A##c, int64_t* A##p+#define FMAT(A) int A##r, int A##c, float* A##p+#define DMAT(A) int A##r, int A##c, double* A##p+#define QMAT(A) int A##r, int A##c, complex* A##p+#define CMAT(A) int A##r, int A##c, doublecomplex* A##p+#define PMAT(A) int A##r, int A##c, void* A##p, int A##s++#define KIVEC(A) int A##n, const int*A##p+#define KLVEC(A) int A##n, const int64_t*A##p+#define KFVEC(A) int A##n, const float*A##p+#define KDVEC(A) int A##n, const double*A##p+#define KQVEC(A) int A##n, const complex*A##p+#define KCVEC(A) int A##n, const doublecomplex*A##p+#define KPVEC(A) int A##n, const void* A##p, int A##s++#define KIMAT(A) int A##r, int A##c, const int* A##p+#define KLMAT(A) int A##r, int A##c, const int64_t* A##p+#define KFMAT(A) int A##r, int A##c, const float* A##p+#define KDMAT(A) int A##r, int A##c, const double* A##p+#define KQMAT(A) int A##r, int A##c, const complex* A##p+#define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p+#define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s++#define VECG(T,A) int A##n, T* A##p+#define MATG(T,A) int A##r, int A##c, int A##Xr, int A##Xc, T* A##p++#define OIMAT(A) MATG(int,A)+#define OLMAT(A) MATG(int64_t,A)+#define OFMAT(A) MATG(float,A)+#define ODMAT(A) MATG(double,A)+#define OQMAT(A) MATG(complex,A)+#define OCMAT(A) MATG(doublecomplex,A)++#define KOIMAT(A) MATG(const int,A)+#define KOLMAT(A) MATG(const int64_t,A)+#define KOFMAT(A) MATG(const float,A)+#define KODMAT(A) MATG(const double,A)+#define KOQMAT(A) MATG(const complex,A)+#define KOCMAT(A) MATG(const doublecomplex,A)++#define AT(m,i,j) (m##p[(i)*m##Xr + (j)*m##Xc])+#define TRAV(m,i,j) int i,j; for (i=0;i<m##r;i++) for (j=0;j<m##c;j++)++/********************************************************/++static inline+int mod (int a, int b) {+ int m = a % b;+ if (b>0) {+ return m >=0 ? m : m+b;+ } else {+ return m <=0 ? m : m+b;+ }+}++static inline+int64_t mod_l (int64_t a, int64_t b) {+ int64_t m = a % b;+ if (b>0) {+ return m >=0 ? m : m+b;+ } else {+ return m <=0 ? m : m+b;+ }+}
+ src/Internal/C/vector-aux.c view
@@ -0,0 +1,1599 @@+#include <complex.h>+#include <inttypes.h>++typedef double complex TCD;+typedef float complex TCF;++#undef complex++#include "lapack-aux.h"++#define V(x) x##n,x##p++#include <string.h>+#include <math.h>+#include <stdio.h>+#include <stdlib.h>+#include <stdint.h>++#define MACRO(B) do {B} while (0)+#define ERROR(CODE) MACRO(return CODE;)+#define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);})+#define OK return 0;++#define MIN(A,B) ((A)<(B)?(A):(B))+#define MAX(A,B) ((A)>(B)?(A):(B))++#ifdef DBG+#define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M);+#else+#define DEBUGMSG(M)+#endif++#define CHECK(RES,CODE) MACRO(if(RES) return CODE;)++#define BAD_SIZE 2000+#define BAD_CODE 2001+#define MEM 2002+#define BAD_FILE 2003+++int sumF(KFVEC(x),FVEC(r)) {+ DEBUGMSG("sumF");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ float res = 0;+ for (i = 0; i < xn; i++) res += xp[i];+ rp[0] = res;+ OK+}++int sumR(KDVEC(x),DVEC(r)) {+ DEBUGMSG("sumR");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ double res = 0;+ for (i = 0; i < xn; i++) res += xp[i];+ rp[0] = res;+ OK+}++int sumI(int m, KIVEC(x),IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 0;+ if (m==1) {+ for (i = 0; i < xn; i++) res += xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res + xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int sumL(int64_t m, KLVEC(x),LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 0;+ if (m==1) {+ for (i = 0; i < xn; i++) res += xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res + xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int sumQ(KQVEC(x),QVEC(r)) {+ DEBUGMSG("sumQ");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ complex res;+ res.r = 0;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ res.r += xp[i].r;+ res.i += xp[i].i;+ }+ rp[0] = res;+ OK+}++int sumC(KCVEC(x),CVEC(r)) {+ DEBUGMSG("sumC");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ doublecomplex res;+ res.r = 0;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ res.r += xp[i].r;+ res.i += xp[i].i;+ }+ rp[0] = res;+ OK+}+++int prodF(KFVEC(x),FVEC(r)) {+ DEBUGMSG("prodF");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ float res = 1;+ for (i = 0; i < xn; i++) res *= xp[i];+ rp[0] = res;+ OK+}++int prodR(KDVEC(x),DVEC(r)) {+ DEBUGMSG("prodR");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ double res = 1;+ for (i = 0; i < xn; i++) res *= xp[i];+ rp[0] = res;+ OK+}++int prodI(int m, KIVEC(x),IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 1;+ if (m==1) {+ for (i = 0; i < xn; i++) res *= xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res * xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int prodL(int64_t m, KLVEC(x),LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ int res = 1;+ if (m==1) {+ for (i = 0; i < xn; i++) res *= xp[i];+ } else {+ for (i = 0; i < xn; i++) res = (res * xp[i]) % m;+ }+ rp[0] = res;+ OK+}++int prodQ(KQVEC(x),QVEC(r)) {+ DEBUGMSG("prodQ");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ complex res;+ float temp;+ res.r = 1;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ temp = res.r * xp[i].r - res.i * xp[i].i;+ res.i = res.r * xp[i].i + res.i * xp[i].r;+ res.r = temp;+ }+ rp[0] = res;+ OK+}++int prodC(KCVEC(x),CVEC(r)) {+ DEBUGMSG("prodC");+ REQUIRES(rn==1,BAD_SIZE);+ int i;+ doublecomplex res;+ double temp;+ res.r = 1;+ res.i = 0;+ for (i = 0; i < xn; i++) {+ temp = res.r * xp[i].r - res.i * xp[i].i;+ res.i = res.r * xp[i].i + res.i * xp[i].r;+ res.r = temp;+ }+ rp[0] = res;+ OK+}+++double dnrm2_(integer*, const double*, integer*);+double dasum_(integer*, const double*, integer*);++double vector_max(KDVEC(x)) {+ double r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++double vector_min(KDVEC(x)) {+ double r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index(KDVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index(KDVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}++int toScalarR(int code, KDVEC(x), DVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarR");+ double res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = dnrm2_(&n,xp,&one); break; }+ case 1: { res = dasum_(&n,xp,&one); break; }+ case 2: { res = vector_max_index(V(x)); break; }+ case 3: { res = vector_max(V(x)); break; }+ case 4: { res = vector_min_index(V(x)); break; }+ case 5: { res = vector_min(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++float snrm2_(integer*, const float*, integer*);+float sasum_(integer*, const float*, integer*);++float vector_max_f(KFVEC(x)) {+ float r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++float vector_min_f(KFVEC(x)) {+ float r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_f(KFVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_f(KFVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarF(int code, KFVEC(x), FVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarF");+ float res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = snrm2_(&n,xp,&one); break; }+ case 1: { res = sasum_(&n,xp,&one); break; }+ case 2: { res = vector_max_index_f(V(x)); break; }+ case 3: { res = vector_max_f(V(x)); break; }+ case 4: { res = vector_min_index_f(V(x)); break; }+ case 5: { res = vector_min_f(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}++int vector_max_i(KIVEC(x)) {+ int r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_min_i(KIVEC(x)) {+ int r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_i(KIVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_i(KIVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarI(int code, KIVEC(x), IVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int res;+ switch(code) {+ case 2: { res = vector_max_index_i(V(x)); break; }+ case 3: { res = vector_max_i(V(x)); break; }+ case 4: { res = vector_min_index_i(V(x)); break; }+ case 5: { res = vector_min_i(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++int64_t vector_max_l(KLVEC(x)) {+ int64_t r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]>r) {+ r = xp[k];+ }+ }+ return r;+}++int64_t vector_min_l(KLVEC(x)) {+ int64_t r = xp[0];+ int k;+ for (k = 1; k<xn; k++) {+ if(xp[k]<r) {+ r = xp[k];+ }+ }+ return r;+}++int vector_max_index_l(KLVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]>xp[r]) {+ r = k;+ }+ }+ return r;+}++int vector_min_index_l(KLVEC(x)) {+ int k, r = 0;+ for (k = 1; k<xn; k++) {+ if(xp[k]<xp[r]) {+ r = k;+ }+ }+ return r;+}+++int toScalarL(int code, KLVEC(x), LVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ int64_t res;+ switch(code) {+ case 2: { res = vector_max_index_l(V(x)); break; }+ case 3: { res = vector_max_l(V(x)); break; }+ case 4: { res = vector_min_index_l(V(x)); break; }+ case 5: { res = vector_min_l(V(x)); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++double dznrm2_(integer*, const doublecomplex*, integer*);+double dzasum_(integer*, const doublecomplex*, integer*);++int toScalarC(int code, KCVEC(x), DVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarC");+ double res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = dznrm2_(&n,xp,&one); break; }+ case 1: { res = dzasum_(&n,xp,&one); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++double scnrm2_(integer*, const complex*, integer*);+double scasum_(integer*, const complex*, integer*);++int toScalarQ(int code, KQVEC(x), FVEC(r)) {+ REQUIRES(rn==1,BAD_SIZE);+ DEBUGMSG("toScalarQ");+ float res;+ integer one = 1;+ integer n = xn;+ switch(code) {+ case 0: { res = scnrm2_(&n,xp,&one); break; }+ case 1: { res = scasum_(&n,xp,&one); break; }+ default: ERROR(BAD_CODE);+ }+ rp[0] = res;+ OK+}+++inline double sign(double x) {+ if(x>0) {+ return +1.0;+ } else if (x<0) {+ return -1.0;+ } else {+ return 0.0;+ }+}++inline float float_sign(float x) {+ if(x>0) {+ return +1.0;+ } else if (x<0) {+ return -1.0;+ } else {+ return 0.0;+ }+}+++#define OP(C,F) case C: { for(k=0;k<xn;k++) rp[k] = F(xp[k]); OK }+#define OPV(C,E) case C: { for(k=0;k<xn;k++) rp[k] = E; OK }+int mapR(int code, KDVEC(x), DVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapR");+ switch (code) {+ OP(0,sin)+ OP(1,cos)+ OP(2,tan)+ OP(3,fabs)+ OP(4,asin)+ OP(5,acos)+ OP(6,atan)+ OP(7,sinh)+ OP(8,cosh)+ OP(9,tanh)+ OP(10,asinh)+ OP(11,acosh)+ OP(12,atanh)+ OP(13,exp)+ OP(14,log)+ OP(15,sign)+ OP(16,sqrt)+ default: ERROR(BAD_CODE);+ }+}++int mapF(int code, KFVEC(x), FVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapF");+ switch (code) {+ OP(0,sin)+ OP(1,cos)+ OP(2,tan)+ OP(3,fabs)+ OP(4,asin)+ OP(5,acos)+ OP(6,atan)+ OP(7,sinh)+ OP(8,cosh)+ OP(9,tanh)+ OP(10,asinh)+ OP(11,acosh)+ OP(12,atanh)+ OP(13,exp)+ OP(14,log)+ OP(15,sign)+ OP(16,sqrt)+ default: ERROR(BAD_CODE);+ }+}+++int mapI(int code, KIVEC(x), IVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ switch (code) {+ OP(3,abs)+ OP(15,sign)+ default: ERROR(BAD_CODE);+ }+}+++int mapL(int code, KLVEC(x), LVEC(r)) {+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ switch (code) {+ OP(3,abs)+ OP(15,sign)+ default: ERROR(BAD_CODE);+ }+}++++inline double abs_complex(doublecomplex z) {+ return sqrt(z.r*z.r + z.i*z.i);+}++inline doublecomplex complex_abs_complex(doublecomplex z) {+ doublecomplex r;+ r.r = abs_complex(z);+ r.i = 0;+ return r;+}++inline doublecomplex complex_signum_complex(doublecomplex z) {+ doublecomplex r;+ double mag;+ if (z.r == 0 && z.i == 0) {+ r.r = 0;+ r.i = 0;+ } else {+ mag = abs_complex(z);+ r.r = z.r/mag;+ r.i = z.i/mag;+ }+ return r;+}++#define OPb(C,F) case C: { for(k=0;k<xn;k++) r2p[k] = F(x2p[k]); OK }+int mapC(int code, KCVEC(x), CVEC(r)) {+ TCD* x2p = (TCD*)xp;+ TCD* r2p = (TCD*)rp;+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapC");+ switch (code) {+ OPb(0,csin)+ OPb(1,ccos)+ OPb(2,ctan)+ OP(3,complex_abs_complex)+ OPb(4,casin)+ OPb(5,cacos)+ OPb(6,catan)+ OPb(7,csinh)+ OPb(8,ccosh)+ OPb(9,ctanh)+ OPb(10,casinh)+ OPb(11,cacosh)+ OPb(12,catanh)+ OPb(13,cexp)+ OPb(14,clog)+ OP(15,complex_signum_complex)+ OPb(16,csqrt)+ default: ERROR(BAD_CODE);+ }+}++++inline complex complex_f_math_fun(doublecomplex (*cf)(doublecomplex), complex a)+{+ doublecomplex c;+ doublecomplex r;++ complex float_r;++ c.r = a.r;+ c.i = a.i;++ r = (*cf)(c);++ float_r.r = r.r;+ float_r.i = r.i;++ return float_r;+}+++#define OPC(C,F) case C: { for(k=0;k<xn;k++) rp[k] = complex_f_math_fun(&F,xp[k]); OK }+int mapQ(int code, KQVEC(x), QVEC(r)) {+ TCF* x2p = (TCF*)xp;+ TCF* r2p = (TCF*)rp;+ int k;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapQ");+ switch (code) {+ OPb(0,csinf)+ OPb(1,ccosf)+ OPb(2,ctanf)+ OPC(3,complex_abs_complex)+ OPb(4,casinf)+ OPb(5,cacosf)+ OPb(6,catanf)+ OPb(7,csinhf)+ OPb(8,ccoshf)+ OPb(9,ctanhf)+ OPb(10,casinhf)+ OPb(11,cacoshf)+ OPb(12,catanhf)+ OPb(13,cexpf)+ OPb(14,clogf)+ OPC(15,complex_signum_complex)+ OPb(16,csqrtf)+ default: ERROR(BAD_CODE);+ }+}+++int mapValR(int code, double* pval, KDVEC(x), DVEC(r)) {+ int k;+ double val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValR");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(4,pow(val,xp[k]))+ OPV(5,pow(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValF(int code, float* pval, KFVEC(x), FVEC(r)) {+ int k;+ float val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValF");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(4,pow(val,xp[k]))+ OPV(5,pow(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValI(int code, int* pval, KIVEC(x), IVEC(r)) {+ int k;+ int val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValI");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(6,mod(val,xp[k]))+ OPV(7,mod(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++int mapValL(int code, int64_t* pval, KLVEC(x), LVEC(r)) {+ int k;+ int64_t val = *pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValL");+ switch (code) {+ OPV(0,val*xp[k])+ OPV(1,val/xp[k])+ OPV(2,val+xp[k])+ OPV(3,val-xp[k])+ OPV(6,mod_l(val,xp[k]))+ OPV(7,mod_l(xp[k],val))+ default: ERROR(BAD_CODE);+ }+}++++inline doublecomplex complex_add(doublecomplex a, doublecomplex b) {+ doublecomplex r;+ r.r = a.r+b.r;+ r.i = a.i+b.i;+ return r;+}++#define OPVb(C,E) case C: { for(k=0;k<xn;k++) r2p[k] = E; OK }+int mapValC(int code, doublecomplex* pval, KCVEC(x), CVEC(r)) {+ TCD* x2p = (TCD*)xp;+ TCD* r2p = (TCD*)rp;+ int k;+ TCD val = * (TCD*)pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValC");+ switch (code) {+ OPVb(0,val*x2p[k])+ OPVb(1,val/x2p[k])+ OPVb(2,val+x2p[k])+ OPVb(3,val-x2p[k])+ OPVb(4,cpow(val,x2p[k]))+ OPVb(5,cpow(x2p[k],val))+ default: ERROR(BAD_CODE);+ }+}+++int mapValQ(int code, complex* pval, KQVEC(x), QVEC(r)) {+ TCF* x2p = (TCF*)xp;+ TCF* r2p = (TCF*)rp;+ int k;+ TCF val = *(TCF*)pval;+ REQUIRES(xn == rn,BAD_SIZE);+ DEBUGMSG("mapValQ");+ switch (code) {+ OPVb(0,val*x2p[k])+ OPVb(1,val/x2p[k])+ OPVb(2,val+x2p[k])+ OPVb(3,val-x2p[k])+ OPVb(4,cpow(val,x2p[k]))+ OPVb(5,cpow(x2p[k],val))+ default: ERROR(BAD_CODE);+ }+}++++#define OPZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = E(ap[k],bp[k]); OK }+#define OPZV(C,msg,E) case C: {DEBUGMSG(msg) res = E(V(r),V(b)); CHECK(res,res); OK }+#define OPZO(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = ap[k] O bp[k]; OK }++int zipR(int code, KDVEC(a), KDVEC(b), DVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipR Add",+)+ OPZO(1,"zipR Sub",-)+ OPZO(2,"zipR Mul",*)+ OPZO(3,"zipR Div",/)+ OPZE(4,"zipR Pow", pow)+ OPZE(5,"zipR ATan2",atan2)+ default: ERROR(BAD_CODE);+ }+}++int zipF(int code, KFVEC(a), KFVEC(b), FVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipR Add",+)+ OPZO(1,"zipR Sub",-)+ OPZO(2,"zipR Mul",*)+ OPZO(3,"zipR Div",/)+ OPZE(4,"zipR Pow", pow)+ OPZE(5,"zipR ATan2",atan2)+ default: ERROR(BAD_CODE);+ }+}+++int zipI(int code, KIVEC(a), KIVEC(b), IVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipI Add",+)+ OPZO(1,"zipI Sub",-)+ OPZO(2,"zipI Mul",*)+ OPZO(3,"zipI Div",/)+ OPZO(6,"zipI Mod",%)+ default: ERROR(BAD_CODE);+ }+}+++int zipL(int code, KLVEC(a), KLVEC(b), LVEC(r)) {+REQUIRES(an == bn && an == rn, BAD_SIZE);+ int k;+ switch(code) {+ OPZO(0,"zipI Add",+)+ OPZO(1,"zipI Sub",-)+ OPZO(2,"zipI Mul",*)+ OPZO(3,"zipI Div",/)+ OPZO(6,"zipI Mod",%)+ default: ERROR(BAD_CODE);+ }+}+++#define OPZOb(C,msg,O) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = a2p[k] O b2p[k]; OK }+#define OPZEb(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) r2p[k] = E(a2p[k],b2p[k]); OK }+int zipC(int code, KCVEC(a), KCVEC(b), CVEC(r)) {+ REQUIRES(an == bn && an == rn, BAD_SIZE);+ TCD* a2p = (TCD*)ap;+ TCD* b2p = (TCD*)bp;+ TCD* r2p = (TCD*)rp;+ int k;+ switch(code) {+ OPZOb(0,"zipC Add",+)+ OPZOb(1,"zipC Sub",-)+ OPZOb(2,"zipC Mul",*)+ OPZOb(3,"zipC Div",/)+ OPZEb(4,"zipC Pow",cpow)+ default: ERROR(BAD_CODE);+ }+}++++++#define OPCZE(C,msg,E) case C: {DEBUGMSG(msg) for(k=0;k<an;k++) rp[k] = complex_f_math_op(&E,ap[k],bp[k]); OK }++int zipQ(int code, KQVEC(a), KQVEC(b), QVEC(r)) {+ REQUIRES(an == bn && an == rn, BAD_SIZE);+ TCF* a2p = (TCF*)ap;+ TCF* b2p = (TCF*)bp;+ TCF* r2p = (TCF*)rp;++ int k;+ switch(code) {+ OPZOb(0,"zipC Add",+)+ OPZOb(1,"zipC Sub",-)+ OPZOb(2,"zipC Mul",*)+ OPZOb(3,"zipC Div",/)+ OPZEb(4,"zipC Pow",cpowf)+ default: ERROR(BAD_CODE);+ }+}++////////////////////////////////////////////////////////////////////////////////++int vectorScan(char * file, int* n, double**pp){+ FILE * fp;+ fp = fopen (file, "r");+ if(!fp) {+ ERROR(BAD_FILE);+ }+ int nbuf = 100*100;+ double * p = (double*)malloc(nbuf*sizeof(double));+ int k=0;+ double d;+ int ok;+ for (;;) {+ ok = fscanf(fp,"%lf",&d);+ if (ok<1) {+ break;+ }+ if (k==nbuf) {+ nbuf = nbuf * 2;+ p = (double*)realloc(p,nbuf*sizeof(double));+ // printf("R\n");+ }+ p[k++] = d;+ }+ *n = k;+ *pp = p;+ fclose(fp);+ OK+}++////////////////////////////////////////////////////////////////////////////////++#if defined (__APPLE__) || (__FreeBSD__) || defined(NO_RANDOM_R) || defined(_WIN32) || defined(WIN32)+/* Windows use thread-safe random+ See: http://stackoverflow.com/questions/143108/is-windows-rand-s-thread-safe+*/+#if defined (__APPLE__) || (__FreeBSD__) || defined(NO_RANDOM_R)++/* For FreeBSD, Mac OS X, and other libcs (like `musl`) that do not provide+ random_r(), or if the use of random_r() is explicitly disabled, thread safety+ cannot be guaranteed.+ As per current understanding, this should at worst lead to less "random"+ numbers being generated, in particular+ * if another thread somebody calls lcong48() at the same time as nrand48()+ is called+ * in addition to that, for glibc with NO_RANDOM_R enabled when ndrand48()+ is called for the first time by multiple threads in parallel due to the+ initialisation function placed within it+ See: http://www.evanjones.ca/random-thread-safe.html++ For FreeBSD and Mac OS X, nrand48() is much better than random().+ See: http://www.evanjones.ca/random-thread-safe.html++ TODO: As mentioned in the linked article, this could be fixed:+ "the best solution for truly portable applications is to include+ your own random number generator implementation,+ and not rely on the system's C library".+*/+#pragma message "randomVector is not thread-safe in OSX and FreeBSD or with NO_RANDOM_R; this likely leads to less random numbers at worst; see http://www.evanjones.ca/random-thread-safe.html"++inline double urandom() {+ /* the probalility of matching will be theoretically p^3(in fact, it is not)+ p is matching probalility of random().+ using the test there, only 3 matches, using random(), 13783 matches+ */+ unsigned short state[3];+ state[0] = random();+ state[1] = random();+ state[2] = random();++ const long max_random = 2147483647; // 2**31 - 1+ return (double)nrand48(state) / (double)max_random;+}++#else++#define _CRT_RAND_S+inline double urandom() {+ unsigned int number;+ errno_t err;+ err = rand_s(&number);+ if (err!=0) {+ printf("something wrong\n");+ return -1;+ }+ return (double)number / (double)UINT_MAX;+}++#endif++double gaussrand(int *phase, double *pV1, double *pV2, double *pS)+{+ double V1=*pV1, V2=*pV2, S=*pS;+ double X;++ if(*phase == 0) {+ do {+ double U1 = urandom();+ double U2 = urandom();++ V1 = 2 * U1 - 1;+ V2 = 2 * U2 - 1;+ S = V1 * V1 + V2 * V2;+ } while(S >= 1 || S == 0);++ X = V1 * sqrt(-2 * log(S) / S);+ } else+ X = V2 * sqrt(-2 * log(S) / S);++ *phase = 1 - *phase;+ *pV1=V1; *pV2=V2; *pS=S;++ return X;++}++#if defined(_WIN32) || defined(WIN32)++int random_vector(unsigned int seed, int code, DVEC(r)) {+ int phase = 0;+ double V1,V2,S;++ srand(seed);++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom();+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#else++int random_vector(unsigned int seed, int code, DVEC(r)) {+ int phase = 0;+ double V1,V2,S;++ srandom(seed);++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom();+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#endif++#else++inline double urandom(struct random_data * buffer) {+ int32_t res;+ random_r(buffer,&res);+ return (double)res/RAND_MAX;+}+++// http://c-faq.com/lib/gaussian.html+double gaussrand(struct random_data *buffer,+ int *phase, double *pV1, double *pV2, double *pS)+{+ double V1=*pV1, V2=*pV2, S=*pS;+ double X;++ if(*phase == 0) {+ do {+ double U1 = urandom(buffer);+ double U2 = urandom(buffer);++ V1 = 2 * U1 - 1;+ V2 = 2 * U2 - 1;+ S = V1 * V1 + V2 * V2;+ } while(S >= 1 || S == 0);++ X = V1 * sqrt(-2 * log(S) / S);+ } else+ X = V2 * sqrt(-2 * log(S) / S);++ *phase = 1 - *phase;+ *pV1=V1; *pV2=V2; *pS=S;++ return X;++}++int random_vector(unsigned int seed, int code, DVEC(r)) {+ struct random_data buffer;+ char random_state[128];+ memset(&buffer, 0, sizeof(struct random_data));+ memset(random_state, 0, sizeof(random_state));++ initstate_r(seed,random_state,sizeof(random_state),&buffer);+ // setstate_r(random_state,&buffer);+ // srandom_r(seed,&buffer);++ int phase = 0;+ double V1,V2,S;++ int k;+ switch (code) {+ case 0: { // uniform+ for (k=0; k<rn; k++) {+ rp[k] = urandom(&buffer);+ }+ OK+ }+ case 1: { // gaussian+ for (k=0; k<rn; k++) {+ rp[k] = gaussrand(&buffer,&phase,&V1,&V2,&S);+ }+ OK+ }++ default: ERROR(BAD_CODE);+ }+}++#endif++////////////////////////////////////////////////////////////////////////////////++int+compare_doubles (const void *a, const void *b) {+ return *(double*)a > *(double*)b;+}++int sort_valuesD(KDVEC(v),DVEC(r)) {+ memcpy(rp,vp,vn*sizeof(double));+ qsort(rp,rn,sizeof(double),compare_doubles);+ OK+}++int+compare_floats (const void *a, const void *b) {+ return *(float*)a > *(float*)b;+}++int sort_valuesF(KFVEC(v),FVEC(r)) {+ memcpy(rp,vp,vn*sizeof(float));+ qsort(rp,rn,sizeof(float),compare_floats);+ OK+}++int+compare_ints(const void *a, const void *b) {+ return *(int*)a > *(int*)b;+}++int sort_valuesI(KIVEC(v),IVEC(r)) {+ memcpy(rp,vp,vn*sizeof(int));+ qsort(rp,rn,sizeof(int),compare_ints);+ OK+}++int+compare_longs(const void *a, const void *b) {+ return *(int64_t*)a > *(int64_t*)b;+}++int sort_valuesL(KLVEC(v),LVEC(r)) {+ memcpy(rp,vp,vn*sizeof(int64_t));+ qsort(rp,rn,sizeof(int64_t),compare_ints);+ OK+}+++////////////////////////////////////////+++#define SORTIDX_IMP(T,C) \+ T* x = (T*)malloc(sizeof(T)*vn); \+ int k; \+ for (k=0;k<vn;k++) { \+ x[k].pos = k; \+ x[k].val = vp[k]; \+ } \+ \+ qsort(x,vn,sizeof(T),C); \+ \+ for (k=0;k<vn;k++) { \+ rp[k] = x[k].pos; \+ } \+ free(x); \+ OK+++typedef struct DI { int pos; double val;} DI;++int compare_doubles_i (const void *a, const void *b) {+ return ((DI*)a)->val > ((DI*)b)->val;+}++int sort_indexD(KDVEC(v),IVEC(r)) {+ SORTIDX_IMP(DI,compare_doubles_i)+}+++typedef struct FI { int pos; float val;} FI;++int compare_floats_i (const void *a, const void *b) {+ return ((FI*)a)->val > ((FI*)b)->val;+}++int sort_indexF(KFVEC(v),IVEC(r)) {+ SORTIDX_IMP(FI,compare_floats_i)+}+++typedef struct II { int pos; int val;} II;++int compare_ints_i (const void *a, const void *b) {+ return ((II*)a)->val > ((II*)b)->val;+}++int sort_indexI(KIVEC(v),IVEC(r)) {+ SORTIDX_IMP(II,compare_ints_i)+}+++typedef struct LI { int pos; int64_t val;} LI;++int compare_longs_i (const void *a, const void *b) {+ return ((II*)a)->val > ((II*)b)->val;+}++int sort_indexL(KLVEC(v),LVEC(r)) {+ SORTIDX_IMP(II,compare_longs_i)+}+++////////////////////////////////////////////////////////////////////////////////++int round_vector(KDVEC(v),DVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}++////////////////////////////////////////////////////////////////////////////////++int round_vector_i(KDVEC(v),IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}+++int mod_vector(int m, KIVEC(v), IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = mod(vp[k],m);+ }+ OK+}++int div_vector(int m, KIVEC(v), IVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = vp[k] / m;+ }+ OK+}++int range_vector(IVEC(r)) {+ int k;+ for(k=0; k<rn; k++) {+ rp[k] = k;+ }+ OK+}++///////////////////////////+++int round_vector_l(KDVEC(v),LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = round(vp[k]);+ }+ OK+}+++int mod_vector_l(int64_t m, KLVEC(v), LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = mod_l(vp[k],m);+ }+ OK+}++int div_vector_l(int64_t m, KLVEC(v), LVEC(r)) {+ int k;+ for(k=0; k<vn; k++) {+ rp[k] = vp[k] / m;+ }+ OK+}++int range_vector_l(LVEC(r)) {+ int k;+ for(k=0; k<rn; k++) {+ rp[k] = k;+ }+ OK+}++++//////////////////// constant /////////////////////////++int constantF(float * pval, FVEC(r)) {+ DEBUGMSG("constantF")+ int k;+ double val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantR(double * pval, DVEC(r)) {+ DEBUGMSG("constantR")+ int k;+ double val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantQ(complex* pval, QVEC(r)) {+ DEBUGMSG("constantQ")+ int k;+ complex val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++int constantC(doublecomplex* pval, CVEC(r)) {+ DEBUGMSG("constantC")+ int k;+ doublecomplex val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++++int constantI(int * pval, IVEC(r)) {+ DEBUGMSG("constantI")+ int k;+ int val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}++++int constantL(int64_t * pval, LVEC(r)) {+ DEBUGMSG("constantL")+ int k;+ int64_t val = *pval;+ for(k=0;k<rn;k++) {+ rp[k]=val;+ }+ OK+}+++//////////////////// type conversions /////////////////////////++#define CONVERT_IMP { \+ int k; \+ for(k=0;k<xn;k++) { \+ yp[k]=xp[k]; \+ } \+ OK }++int float2double(FVEC(x),DVEC(y)) CONVERT_IMP++int float2int(KFVEC(x),IVEC(y)) CONVERT_IMP++int double2float(DVEC(x),FVEC(y)) CONVERT_IMP++int double2int(KDVEC(x),IVEC(y)) CONVERT_IMP++int double2long(KDVEC(x),LVEC(y)) CONVERT_IMP++int int2float(KIVEC(x),FVEC(y)) CONVERT_IMP++int int2double(KIVEC(x),DVEC(y)) CONVERT_IMP++int int2long(KIVEC(x),LVEC(y)) CONVERT_IMP++int long2int(KLVEC(x),IVEC(y)) CONVERT_IMP++int long2double(KLVEC(x),DVEC(y)) CONVERT_IMP+++//////////////////// conjugate /////////////////////////++int conjugateQ(KQVEC(x),QVEC(t)) {+ REQUIRES(xn==tn,BAD_SIZE);+ DEBUGMSG("conjugateQ");+ int k;+ for(k=0;k<xn;k++) {+ tp[k].r = xp[k].r;+ tp[k].i = -xp[k].i;+ }+ OK+}++int conjugateC(KCVEC(x),CVEC(t)) {+ REQUIRES(xn==tn,BAD_SIZE);+ DEBUGMSG("conjugateC");+ int k;+ for(k=0;k<xn;k++) {+ tp[k].r = xp[k].r;+ tp[k].i = -xp[k].i;+ }+ OK+}++//////////////////// step /////////////////////////++#define STEP_IMP \+ int k; \+ for(k=0;k<xn;k++) { \+ yp[k]=xp[k]>0; \+ } \+ OK++int stepF(KFVEC(x),FVEC(y)) {+ STEP_IMP+}++int stepD(KDVEC(x),DVEC(y)) {+ STEP_IMP+}++int stepI(KIVEC(x),IVEC(y)) {+ STEP_IMP+}++int stepL(KLVEC(x),LVEC(y)) {+ STEP_IMP+}+++//////////////////// cond /////////////////////////++#define COMPARE_IMP \+ REQUIRES(xn==yn && xn==rn ,BAD_SIZE); \+ int k; \+ for(k=0;k<xn;k++) { \+ rp[k] = xp[k]<yp[k]?-1:(xp[k]>yp[k]?1:0); \+ } \+ OK+++int compareF(KFVEC(x),KFVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareD(KDVEC(x),KDVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareI(KIVEC(x),KIVEC(y),IVEC(r)) {+ COMPARE_IMP+}++int compareL(KLVEC(x),KLVEC(y),IVEC(r)) {+ COMPARE_IMP+}++++#define CHOOSE_IMP \+ REQUIRES(condn==ltn && ltn==eqn && ltn==gtn && ltn==rn ,BAD_SIZE); \+ int k; \+ for(k=0;k<condn;k++) { \+ rp[k] = condp[k]<0?ltp[k]:(condp[k]>0?gtp[k]:eqp[k]); \+ } \+ OK++int chooseF(KIVEC(cond),KFVEC(lt),KFVEC(eq),KFVEC(gt),FVEC(r)) {+ CHOOSE_IMP+}++int chooseD(KIVEC(cond),KDVEC(lt),KDVEC(eq),KDVEC(gt),DVEC(r)) {+ CHOOSE_IMP+}++int chooseI(KIVEC(cond),KIVEC(lt),KIVEC(eq),KIVEC(gt),IVEC(r)) {+ CHOOSE_IMP+}++int chooseL(KIVEC(cond),KLVEC(lt),KLVEC(eq),KLVEC(gt),LVEC(r)) {+ CHOOSE_IMP+}+++int chooseC(KIVEC(cond),KCVEC(lt),KCVEC(eq),KCVEC(gt),CVEC(r)) {+ CHOOSE_IMP+}++int chooseQ(KIVEC(cond),KQVEC(lt),KQVEC(eq),KQVEC(gt),QVEC(r)) {+ CHOOSE_IMP+}++//////////////////// reorder /////////////////////////++#define REORDER_IMP \+ REQUIRES(kn == stridesn && stridesn == dimsn ,BAD_SIZE); \+ int i,j,l; \+ for (i=1,j=0,l=0;l<kn;++l) { \+ kp[l] = 0; \+ i *= dimsp[l]; \+ j += (dimsp[l]-1) * stridesp[l]; \+ } \+ REQUIRES(i <= vn && j < rn ,BAD_SIZE); \+ for (i=0,j=0;;i++) { \+ rp[i] = vp[j]; \+ for(l=kn-1;;l--) { \+ ++kp[l]; \+ if (kp[l] < dimsp[l]) { \+ j += stridesp[l]; \+ break; \+ } else { \+ if (l == 0) { \+ return 0; \+ } \+ kp[l] = 0; \+ j -= (dimsp[l]-1) * stridesp[l]; \+ } \+ } \+ }++int reorderF(IVEC(k), KIVEC(strides),KIVEC(dims),KFVEC(v),FVEC(r)) {+ REORDER_IMP+}++int reorderD(IVEC(k), KIVEC(strides),KIVEC(dims),KDVEC(v),DVEC(r)) {+ REORDER_IMP+}++int reorderI(IVEC(k), KIVEC(strides),KIVEC(dims),KIVEC(v),IVEC(r)) {+ REORDER_IMP+}++int reorderL(IVEC(k), KIVEC(strides),KIVEC(dims),KLVEC(v),LVEC(r)) {+ REORDER_IMP+}++int reorderC(IVEC(k), KIVEC(strides),KIVEC(dims),KCVEC(v),CVEC(r)) {+ REORDER_IMP+}++int reorderQ(IVEC(k), KIVEC(strides),KIVEC(dims),KQVEC(v),QVEC(r)) {+ REORDER_IMP+}
+ src/Internal/CG.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Internal.CG(+ cgSolve, cgSolve',+ CGState(..), R, V+) where++import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Element+import Internal.IO+import Internal.Container+import Internal.Sparse+import Numeric.Vector()+import Internal.Algorithms(linearSolveLS, linearSolve, relativeError, pnorm, NormType(..))+import Control.Arrow((***))++{-+import Util.Misc(debug, debugMat)++(//) :: Show a => a -> String -> a+infix 0 // -- , ///+a // b = debug b id a++(///) :: V -> String -> V+infix 0 ///+v /// b = debugMat b 2 asRow v+-}++type V = Vector R++data CGState = CGState+ { cgp :: Vector R -- ^ conjugate gradient+ , cgr :: Vector R -- ^ residual+ , cgr2 :: R -- ^ squared norm of residual+ , cgx :: Vector R -- ^ current solution+ , cgdx :: R -- ^ normalized size of correction+ }++cg :: Bool -> (V -> V) -> (V -> V) -> CGState -> CGState+cg sym at a (CGState p r r2 x _) = CGState p' r' r'2 x' rdx+ where+ ap1 = a p+ ap | sym = ap1+ | otherwise = at ap1+ pap | sym = p <.> ap1+ | otherwise = norm2 ap1 ** 2+ alpha = r2 / pap+ dx = scale alpha p+ x' = x + dx+ r' = r - scale alpha ap+ r'2 = r' <.> r'+ beta = r'2 / r2+ p' = r' + scale beta p++ rdx = norm2 dx / max 1 (norm2 x)++conjugrad+ :: Bool -> GMatrix -> V -> V -> R -> R -> [CGState]+conjugrad sym a b = solveG sym (tr a !#>) (a !#>) (cg sym) b++solveG+ :: Bool+ -> (V -> V) -> (V -> V)+ -> ((V -> V) -> (V -> V) -> CGState -> CGState)+ -> V+ -> V+ -> R -> R+ -> [CGState]+solveG sym mat ma meth rawb x0' ϵb ϵx+ = takeUntil ok . iterate (meth mat ma) $ CGState p0 r0 r20 x0 1+ where+ a = if sym then ma else mat . ma+ b = if sym then rawb else mat rawb+ x0 = if x0' == 0 then konst 0 (dim b) else x0'+ r0 = b - a x0+ r20 = r0 <.> r0+ p0 = r0+ nb2 = b <.> b+ ok CGState {..}+ = cgr2 <nb2*ϵb**2+ || cgdx < ϵx+++takeUntil :: (a -> Bool) -> [a] -> [a]+takeUntil q xs = a++ take 1 b+ where+ (a,b) = break q xs++-- | Solve a sparse linear system using the conjugate gradient method with default parameters.+cgSolve+ :: Bool -- ^ is symmetric+ -> GMatrix -- ^ coefficient matrix+ -> Vector R -- ^ right-hand side+ -> Vector R -- ^ solution+cgSolve sym a b = cgx $ last $ cgSolve' sym 1E-4 1E-3 n a b 0+ where+ n = max 10 (round $ sqrt (fromIntegral (dim b) :: Double))++-- | Solve a sparse linear system using the conjugate gradient method with default parameters.+cgSolve'+ :: Bool -- ^ symmetric+ -> R -- ^ relative tolerance for the residual (e.g. 1E-4)+ -> R -- ^ relative tolerance for δx (e.g. 1E-3)+ -> Int -- ^ maximum number of iterations+ -> GMatrix -- ^ coefficient matrix+ -> Vector R -- ^ initial solution+ -> Vector R -- ^ right-hand side+ -> [CGState] -- ^ solution+cgSolve' sym er es n a b x = take n $ conjugrad sym a b x er es+++--------------------------------------------------------------------------------++instance Testable GMatrix+ where+ checkT _ = (ok,info)+ where+ sma = convo2 20 3+ x1 = vect [1..20]+ x2 = vect [1..40]+ sm = mkSparse sma+ dm = toDense sma++ s1 = sm !#> x1+ d1 = dm #> x1++ s2 = tr sm !#> x2+ d2 = tr dm #> x2++ sdia = mkDiagR 40 20 (vect [1..10])+ s3 = sdia !#> x1+ s4 = tr sdia !#> x2+ ddia = diagRect 0 (vect [1..10]) 40 20+ d3 = ddia #> x1+ d4 = tr ddia #> x2++ v = testb 40+ s5 = cgSolve False sm v+ d5 = denseSolve dm v++ symassoc = [((0,0),1.0),((1,1),2.0),((0,1),0.5),((1,0),0.5)]+ b = vect [3,4]+ d6 = flatten $ linearSolve (toDense symassoc) (asColumn b)+ s6 = cgSolve True (mkSparse symassoc) b++ info = do+ print sm+ disp (toDense sma)+ print s1; print d1+ print s2; print d2+ print s3; print d3+ print s4; print d4+ print s5; print d5+ print $ relativeError (pnorm Infinity) s5 d5+ print s6; print d6+ print $ relativeError (pnorm Infinity) s6 d6++ ok = s1==d1+ && s2==d2+ && s3==d3+ && s4==d4+ && relativeError (pnorm Infinity) s5 d5 < 1E-10+ && relativeError (pnorm Infinity) s6 d6 < 1E-10++ disp = putStr . dispf 2++ vect = fromList :: [Double] -> Vector Double++ convomat :: Int -> Int -> AssocMatrix+ convomat n k = [ ((i,j `mod` n),1) | i<-[0..n-1], j <- [i..i+k-1]]++ convo2 :: Int -> Int -> AssocMatrix+ convo2 n k = m1 ++ m2+ where+ m1 = convomat n k+ m2 = map (((+n) *** id) *** id) m1++ testb n = vect $ take n $ cycle ([0..10]++[9,8..1])++ denseSolve a = flatten . linearSolveLS a . asColumn++ -- mkDiag v = mkDiagR (dim v) (dim v) v+
+ src/Internal/Chain.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.Chain+-- Copyright : (c) Vivian McPhail 2010+-- License : BSD3+--+-- Maintainer : Vivian McPhail <haskell.vivian.mcphail <at> gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- optimisation of association order for chains of matrix multiplication+--+-----------------------------------------------------------------------------++{-# LANGUAGE FlexibleContexts #-}++module Internal.Chain (+ optimiseMult,+ ) where++import Data.Maybe++import Internal.Matrix+import Internal.Numeric++import qualified Data.Array.IArray as A++-----------------------------------------------------------------------------+{- | + Provide optimal association order for a chain of matrix multiplications + and apply the multiplications.++ The algorithm is the well-known O(n\^3) dynamic programming algorithm+ that builds a pyramid of optimal associations.++> m1, m2, m3, m4 :: Matrix Double+> m1 = (10><15) [1..]+> m2 = (15><20) [1..]+> m3 = (20><5) [1..]+> m4 = (5><10) [1..]++> >>> optimiseMult [m1,m2,m3,m4]++will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@++The naive left-to-right multiplication would take @4500@ scalar multiplications+whereas the optimised version performs @2750@ scalar multiplications. The complexity+in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions,+5 lookups, 2 updates) + a constant (= three table allocations)+-}+optimiseMult :: Product t => [Matrix t] -> Matrix t+optimiseMult = chain++-----------------------------------------------------------------------------++type Matrices a = A.Array Int (Matrix a)+type Sizes = A.Array Int (Int,Int)+type Cost = A.Array Int (A.Array Int (Maybe Int))+type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))++update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a)+update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])]++newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int))+newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]+ where subArray i = A.listArray (1,i) (repeat Nothing)++newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))+newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]+ where subArray i = A.listArray (1,i) (repeat Nothing)++matricesToSizes :: [Matrix a] -> Sizes+matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms++chain :: Product a => [Matrix a] -> Matrix a+chain [] = error "chain: zero matrices to multiply"+chain [m] = m+chain [ml,mr] = ml `multiply` mr+chain ms = let ln = length ms+ ma = A.listArray (1,ln) ms+ mz = matricesToSizes ms+ i = chain_cost mz+ in chain_paren (ln,ln) i ma++chain_cost :: Sizes -> Indexes+chain_cost mz = let (_,u) = A.bounds mz+ cost = newWorkSpaceCost u+ ixes = newWorkSpaceIndexes u+ (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u)+ in i++chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)+chain_cost' sci@(mz,cost,ixes) (r,c) + | c == 1 = let cost' = update cost (r,c) (Just 0)+ ixes' = update ixes (r,c) (Just ((r,c),(r,c)))+ in (mz,cost',ixes')+ | otherwise = minimum_cost sci (r,c)++minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)+minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu)++smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes)+smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) =+ let op_cost = fromJust ((cost A.! lr) A.! lc)+ + fromJust ((cost A.! rr) A.! rc)+ + fst (mz A.! (lr-lc+1))+ * snd (mz A.! lc)+ * snd (mz A.! rr)+ cost' = (cost A.! r) A.! c+ in case cost' of+ Nothing -> let cost'' = update cost (r,c) (Just op_cost)+ ixes'' = update ixes (r,c) (Just ix)+ in (mz,cost'',ixes'')+ Just ct -> if op_cost < ct then+ let cost'' = update cost (r,c) (Just op_cost)+ ixes'' = update ixes (r,c) (Just ix)+ in (mz,cost'',ixes'')+ else (mz,cost,ixes)+ ++fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)]+ in map (partner (r,c)) fs'++partner (r,c) (a,b) = ((r-b, c-b), (a,b))++order 0 = []+order n = order (n-1) ++ zip (repeat n) [1..n]++chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a+chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c+ in if lr == rr && lc == rc then (ma A.! lr)+ else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) ++--------------------------------------------------------------------------++{- TESTS++-- optimal association is ((m1*(m2*m3))*m4)+m1, m2, m3, m4 :: Matrix Double+m1 = (10><15) [1..]+m2 = (15><20) [1..]+m3 = (20><5) [1..]+m4 = (5><10) [1..]++-}+
+ src/Internal/Container.hs view
@@ -0,0 +1,302 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.Container+-- Copyright : (c) Alberto Ruiz 2010-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Basic numeric operations on 'Vector' and 'Matrix', including conversion routines.+--+-- The 'Container' class is used to define optimized generic functions which work+-- on 'Vector' and 'Matrix' with real or complex elements.+--+-- Some of these functions are also available in the instances of the standard+-- numeric Haskell classes provided by "Numeric.LinearAlgebra".+--+-----------------------------------------------------------------------------++module Internal.Container where++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Numeric+import Internal.Algorithms(Field,linearSolveSVD,Herm,mTm)+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+------------------------------------------------------------------++{- | Creates a real vector containing a range of values:++>>> linspace 5 (-3,7::Double)+[-3.0,-0.5,2.0,4.5,7.0]+it :: Vector Double++>>> linspace 5 (8,3:+2) :: Vector (Complex Double)+[8.0 :+ 0.0,6.75 :+ 0.5,5.5 :+ 1.0,4.25 :+ 1.5,3.0 :+ 2.0]+it :: Vector (Complex Double)++Logarithmic spacing can be defined as follows:++@logspace n (a,b) = 10 ** linspace n (a,b)@+-}+linspace :: (Fractional e, Container Vector e) => Int -> (e, e) -> Vector e+linspace 0 _ = fromList[]+linspace 1 (a,b) = fromList[(a+b)/2]+linspace n (a,b) = addConstant a $ scale s $ fromList $ map fromIntegral [0 .. n-1]+ where s = (b-a)/fromIntegral (n-1)++--------------------------------------------------------------------------------++infixr 8 <.>+{- | An infix synonym for 'dot'++>>> vector [1,2,3,4] <.> vector [-2,0,1,1]+5.0++>>> let 𝑖 = 0:+1 :: C+>>> fromList [1+𝑖,1] <.> fromList [1,1+𝑖]+2.0 :+ 0.0++-}++(<.>) :: Numeric t => Vector t -> Vector t -> t+(<.>) = dot++++++{- | dense matrix-vector product++>>> let m = (2><3) [1..]+>>> m+(2><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0 ]++>>> let v = vector [10,20,30]++>>> m #> v+[140.0,320.0]+it :: Vector Numeric.LinearAlgebra.Data.R++-}+infixr 8 #>+(#>) :: Numeric t => Matrix t -> Vector t -> Vector t+(#>) = mXv++-- | dense matrix-vector product+app :: Numeric t => Matrix t -> Vector t -> Vector t+app = (#>)++infixl 8 <#+-- | dense vector-matrix product+(<#) :: Numeric t => Vector t -> Matrix t -> Vector t+(<#) = vXm++--------------------------------------------------------------------------------++class Mul a b c | a b -> c where+ infixl 7 <>+ -- | Matrix-matrix, matrix-vector, and vector-matrix products.+ (<>) :: Product t => a t -> b t -> c t++instance Mul Matrix Matrix Matrix where+ (<>) = mXm++instance Mul Matrix Vector Vector where+ (<>) m v = flatten $ m <> asColumn v++instance Mul Vector Matrix Vector where+ (<>) v m = flatten $ asRow v <> m++--------------------------------------------------------------------------------++{- | Least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD)++@+a = (3><2)+ [ 1.0, 2.0+ , 2.0, 4.0+ , 2.0, -1.0 ]+@++@+v = vector [13.0,27.0,1.0]+@++>>> let x = a <\> v+>>> x+[3.0799999999999996,5.159999999999999]+it :: Vector Numeric.LinearAlgebra.Data.R++>>> a #> x+[13.399999999999999,26.799999999999997,0.9999999999999991]+it :: Vector Numeric.LinearAlgebra.Data.R++It also admits multiple right-hand sides stored as columns in a matrix.++-}+infixl 7 <\>+(<\>) :: (LSDiv c, Field t) => Matrix t -> c t -> c t+(<\>) = linSolve++class LSDiv c+ where+ linSolve :: Field t => Matrix t -> c t -> c t++instance LSDiv Vector+ where+ linSolve m v = flatten (linearSolveSVD m (reshape 1 v))++instance LSDiv Matrix+ where+ linSolve = linearSolveSVD++--------------------------------------------------------------------------------+++class Build d f c e | d -> c, c -> d, f -> e, f -> d, f -> c, c e -> f, d e -> f+ where+ -- |+ -- >>> build 5 (**2) :: Vector Double+ -- [0.0,1.0,4.0,9.0,16.0]+ -- it :: Vector Double+ --+ -- Hilbert matrix of order N:+ --+ -- >>> let hilb n = build (n,n) (\i j -> 1/(i+j+1)) :: Matrix Double+ -- >>> putStr . dispf 2 $ hilb 3+ -- 3x3+ -- 1.00 0.50 0.33+ -- 0.50 0.33 0.25+ -- 0.33 0.25 0.20+ --+ build :: d -> f -> c e++instance Container Vector e => Build Int (e -> e) Vector e+ where+ build = build'++instance (Num e, Container Vector e) => Build (Int,Int) (e -> e -> e) Matrix e+ where+ build = build'++--------------------------------------------------------------------------------++-- @dot u v = 'udot' ('conj' u) v@+dot :: (Numeric t) => Vector t -> Vector t -> t+dot u v = udot (conj u) v++--------------------------------------------------------------------------------++optimiseMult :: Monoid (Matrix t) => [Matrix t] -> Matrix t+optimiseMult = mconcat++--------------------------------------------------------------------------------+++{- | Compute mean vector and covariance matrix of the rows of a matrix.++>>> meanCov $ gaussianSample 666 1000 (fromList[4,5]) (trustSym $ diagl [2,3])+([3.9933155655086696,5.061409102770331],Herm (2><2)+ [ 1.9963242906624408, -4.227815571404954e-2+ , -4.227815571404954e-2, 3.2003833097832857 ])+it :: (Vector Double, Herm Double)+-}+meanCov :: Matrix Double -> (Vector Double, Herm Double)+meanCov x = (med,cov) where+ r = rows x+ k = 1 / fromIntegral r+ med = konst k r `vXm` x+ meds = konst 1 r `outer` med+ xc = x `sub` meds+ cov = scale (recip (fromIntegral (r-1))) (mTm xc)++--------------------------------------------------------------------------------++sortVector :: (Ord t, Element t) => Vector t -> Vector t+sortVector = sortV++{- |++>>> m <- randn 4 10+>>> disp 2 m+4x10+-0.31 0.41 0.43 -0.19 -0.17 -0.23 -0.17 -1.04 -0.07 -1.24+ 0.26 0.19 0.14 0.83 -1.54 -0.09 0.37 -0.63 0.71 -0.50+-0.11 -0.10 -1.29 -1.40 -1.04 -0.89 -0.68 0.35 -1.46 1.86+ 1.04 -0.29 0.19 -0.75 -2.20 -0.01 1.06 0.11 -2.09 -1.58++>>> disp 2 $ m ?? (All, Pos $ sortIndex (m!1))+4x10+-0.17 -1.04 -1.24 -0.23 0.43 0.41 -0.31 -0.17 -0.07 -0.19+-1.54 -0.63 -0.50 -0.09 0.14 0.19 0.26 0.37 0.71 0.83+-1.04 0.35 1.86 -0.89 -1.29 -0.10 -0.11 -0.68 -1.46 -1.40+-2.20 0.11 -1.58 -0.01 0.19 -0.29 1.04 1.06 -2.09 -0.75++-}+sortIndex :: (Ord t, Element t) => Vector t -> Vector I+sortIndex = sortI++ccompare :: (Ord t, Container c t) => c t -> c t -> c I+ccompare = ccompare'++cselect :: (Container c t) => c I -> c t -> c t -> c t -> c t+cselect = cselect'++{- | Extract elements from positions given in matrices of rows and columns.++>>> r+(3><3)+ [ 1, 1, 1+ , 1, 2, 2+ , 1, 2, 3 ]+>>> c+(3><3)+ [ 0, 1, 5+ , 2, 2, 1+ , 4, 4, 1 ]+>>> m+(4><6)+ [ 0, 1, 2, 3, 4, 5+ , 6, 7, 8, 9, 10, 11+ , 12, 13, 14, 15, 16, 17+ , 18, 19, 20, 21, 22, 23 ]++>>> remap r c m+(3><3)+ [ 6, 7, 11+ , 8, 14, 13+ , 10, 16, 19 ]++The indexes are autoconformable.++>>> c'+(3><1)+ [ 1+ , 2+ , 4 ]+>>> remap r c' m+(3><3)+ [ 7, 7, 7+ , 8, 14, 14+ , 10, 16, 22 ]++-}+remap :: Element t => Matrix I -> Matrix I -> Matrix t -> Matrix t+remap i j m+ | minElement i >= 0 && maxElement i < fromIntegral (rows m) &&+ minElement j >= 0 && maxElement j < fromIntegral (cols m) = remapM i' j' m+ | otherwise = error $ "out of range index in remap"+ where+ [i',j'] = conformMs [i,j]
+ src/Internal/Conversion.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Conversion+-- Copyright : (c) Alberto Ruiz 2010+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Conversion routines+--+-----------------------------------------------------------------------------+++module Internal.Conversion (+ Complexable(..), RealElement,+ module Data.Complex+) where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Data.Complex+import Control.Arrow((***))++-------------------------------------------------------------------++-- | Supported single-double precision type pairs+class (Element s, Element d) => Precision s d | s -> d, d -> s where+ double2FloatG :: Vector d -> Vector s+ float2DoubleG :: Vector s -> Vector d++instance Precision Float Double where+ double2FloatG = double2FloatV+ float2DoubleG = float2DoubleV++instance Precision (Complex Float) (Complex Double) where+ double2FloatG = asComplex . double2FloatV . asReal+ float2DoubleG = asComplex . float2DoubleV . asReal++instance Precision I Z where+ double2FloatG = long2intV+ float2DoubleG = int2longV+++-- | Supported real types+class (Element t, Element (Complex t), RealFloat t)+ => RealElement t++instance RealElement Double+instance RealElement Float+++-- | Structures that may contain complex numbers+class Complexable c where+ toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e)+ fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e)+ comp' :: (RealElement e) => c e -> c (Complex e)+ single' :: Precision a b => c b -> c a+ double' :: Precision a b => c a -> c b+++instance Complexable Vector where+ toComplex' = toComplexV+ fromComplex' = fromComplexV+ comp' v = toComplex' (v,constantD 0 (dim v))+ single' = double2FloatG+ double' = float2DoubleG+++-- | creates a complex vector from vectors with real and imaginary parts+toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a)+toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i]++-- | the inverse of 'toComplex'+fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a)+fromComplexV z = (r,i) where+ [r,i] = toColumns $ reshape 2 $ asReal z+++instance Complexable Matrix where+ toComplex' = uncurry $ liftMatrix2 $ curry toComplex'+ fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z+ where c = cols z+ comp' = liftMatrix comp'+ single' = liftMatrix single'+ double' = liftMatrix double'+
+ src/Internal/Convolution.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+-----------------------------------------------------------------------------+{- |+Module : Internal.Convolution+Copyright : (c) Alberto Ruiz 2012+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++-}+-----------------------------------------------------------------------------+{-# OPTIONS_HADDOCK hide #-}++module Internal.Convolution(+ corr, conv, corrMin,+ corr2, conv2, separable+) where++import qualified Data.Vector.Storable as SV+import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Element+import Internal.Conversion+import Internal.Container+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif+++vectSS :: Element t => Int -> Vector t -> Matrix t+vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]+++corr+ :: (Container Vector t, Product t)+ => Vector t -- ^ kernel+ -> Vector t -- ^ source+ -> Vector t+{- ^ correlation++>>> corr (fromList[1,2,3]) (fromList [1..10])+[14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]+it :: (Enum t, Product t, Container Vector t) => Vector t++-}+corr ker v+ | dim ker == 0 = konst 0 (dim v)+ | dim ker <= dim v = vectSS (dim ker) v <> ker+ | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"+++conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t+{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)++>>> conv (fromList[1,1]) (fromList [-1,1])+[-1.0,0.0,1.0]+it :: (Product t, Container Vector t) => Vector t++-}+conv ker v+ | dim ker == 0 = konst 0 (dim v)+ | otherwise = corr ker' v'+ where+ ker' = SV.reverse ker+ v' = vjoin [z,v,z]+ z = konst 0 (dim ker -1)++corrMin :: (Container Vector t, RealElement t, Product t)+ => Vector t+ -> Vector t+ -> Vector t+-- ^ similar to 'corr', using 'min' instead of (*)+corrMin ker v+ | dim ker == 0 = error "corrMin: empty kernel"+ | otherwise = minEvery ss (asRow ker) <> ones+ where+ minEvery a b = cond a b a a b+ ss = vectSS (dim ker) v+ ones = konst 1 (dim ker)++++matSS :: Element t => Int -> Matrix t -> [Matrix t]+matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]+ where+ v = flatten m+ c = cols m+ r = rows m+ n = dr*c+++{- | 2D correlation (without padding)++>>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double)+8x8+3 2 1 0 0 0 0 0+2 3 2 1 0 0 0 0+1 2 3 2 1 0 0 0+0 1 2 3 2 1 0 0+0 0 1 2 3 2 1 0+0 0 0 1 2 3 2 1+0 0 0 0 1 2 3 2+0 0 0 0 0 1 2 3++-}+corr2 :: Product a => Matrix a -> Matrix a -> Matrix a+corr2 ker mat = dims+ . concatMap (map (udot ker' . flatten) . matSS c . trans)+ . matSS r $ mat+ where+ r = rows ker+ c = cols ker+ ker' = flatten (trans ker)+ rr = rows mat - r + 1+ rc = cols mat - c + 1+ dims | rr > 0 && rc > 0 = (rr >< rc)+ | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"+ sz m = show (rows m)++"x"++show (cols m)+-- TODO check empty kernel++{- | 2D convolution++>>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double)+12x12+1 1 1 0 0 0 0 0 0 0 0 0+1 2 2 1 0 0 0 0 0 0 0 0+1 2 3 2 1 0 0 0 0 0 0 0+0 1 2 3 2 1 0 0 0 0 0 0+0 0 1 2 3 2 1 0 0 0 0 0+0 0 0 1 2 3 2 1 0 0 0 0+0 0 0 0 1 2 3 2 1 0 0 0+0 0 0 0 0 1 2 3 2 1 0 0+0 0 0 0 0 0 1 2 3 2 1 0+0 0 0 0 0 0 0 1 2 3 2 1+0 0 0 0 0 0 0 0 1 2 2 1+0 0 0 0 0 0 0 0 0 1 1 1++-}+conv2+ :: (Num (Matrix a), Product a, Container Vector a)+ => Matrix a -- ^ kernel+ -> Matrix a -> Matrix a+conv2 k m+ | empty = konst 0 (rows m + r -1, cols m + c -1)+ | otherwise = corr2 (fliprl . flipud $ k) padded+ where+ padded = fromBlocks [[z,0,0]+ ,[0,m,0]+ ,[0,0,z]]+ r = rows k+ c = cols k+ z = konst 0 (r-1,c-1)+ empty = r == 0 || c == 0+++separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t+-- ^ matrix computation implemented as separated vector operations by rows and columns.+separable f = fromColumns . map f . toColumns . fromRows . map f . toRows+
+ src/Internal/Devel.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- Module : Internal.Devel+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--++module Internal.Devel where+++import Control.Monad ( when )+import Foreign.C.Types ( CInt )+--import Foreign.Storable.Complex ()+import Foreign.Ptr(Ptr)+import Control.Exception (SomeException, SomeAsyncException (..))+import qualified Control.Exception as Exception+import Internal.Vector(Vector,avec)+import Foreign.Storable(Storable)++-- | postfix function application (@flip ($)@)+(//) :: x -> (x -> y) -> y+infixl 0 //+(//) = flip ($)+++-- GSL error codes are <= 1024+-- | error codes for the auxiliary functions required by the wrappers+errorCode :: CInt -> String+errorCode 2000 = "bad size"+errorCode 2001 = "bad function code"+errorCode 2002 = "memory problem"+errorCode 2003 = "bad file"+errorCode 2004 = "singular"+errorCode 2005 = "didn't converge"+errorCode 2006 = "the input matrix is not positive definite"+errorCode 2007 = "not yet supported in this OS"+errorCode n = "code "++show n+++-- | clear the fpu+foreign import ccall unsafe "asm_finit" finit :: IO ()++-- | check the error code+check :: String -> IO CInt -> IO ()+check msg f = do+-- finit+ err <- f+ when (err/=0) $ error (msg++": "++errorCode err)+ return ()+++-- | postfix error code check+infixl 0 #|+(#|) :: IO CInt -> String -> IO ()+(#|) = flip check++-- | Error capture and conversion to Maybe+mbCatch :: IO x -> IO (Maybe x)+mbCatch act =+ hush <$>+ Exception.tryJust+ (\e -> if isSyncException e then Just e else Nothing)+ act++ where+ hush :: Either a b -> Maybe b+ hush = either (const Nothing) Just++ isSyncException :: SomeException -> Bool+ isSyncException e =+ case Exception.fromException e of+ Just (SomeAsyncException _) -> False+ Nothing -> True++--------------------------------------------------------------------------------++type CM b r = CInt -> CInt -> Ptr b -> r+type CV b r = CInt -> Ptr b -> r+type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r++type CIdxs r = CV CInt r+type Ok = IO CInt++infixr 5 :>, ::>, ..>+type (:>) t r = CV t r+type (::>) t r = OM t r+type (..>) t r = CM t r++class TransArray c+ where+ type Trans c b+ type TransRaw c b+ apply :: c -> (b -> IO r) -> (Trans c b) -> IO r+ applyRaw :: c -> (b -> IO r) -> (TransRaw c b) -> IO r+ infixl 1 `apply`, `applyRaw`++instance Storable t => TransArray (Vector t)+ where+ type Trans (Vector t) b = CInt -> Ptr t -> b+ type TransRaw (Vector t) b = CInt -> Ptr t -> b+ apply = avec+ {-# INLINE apply #-}+ applyRaw = avec+ {-# INLINE applyRaw #-}
+ src/Internal/Element.hs view
@@ -0,0 +1,617 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Packed.Matrix+-- Copyright : (c) Alberto Ruiz 2007-10+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- A Matrix representation suitable for numerical computations using LAPACK and GSL.+--+-- This module provides basic functions for manipulation of structure.++-----------------------------------------------------------------------------++module Internal.Element where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import qualified Internal.ST as ST+import Data.Array+import Text.Printf+import Data.List(transpose,intersperse)+import Data.List.Split(chunksOf)+import Foreign.Storable(Storable)+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(liftM)+import Foreign.C.Types(CInt)++-------------------------------------------------------------------+++import Data.Binary++instance (Binary a, Element a) => Binary (Matrix a) where+ put m = do+ put (cols m)+ put (flatten m)+ get = do+ c <- get+ v <- get+ return (reshape c v)+++-------------------------------------------------------------------++instance (Show a, Element a) => (Show (Matrix a)) where+ show m | rows m == 0 || cols m == 0 = sizes m ++" []"+ show m = (sizes m++) . dsp . map (map show) . toLists $ m++sizes :: Matrix t -> [Char]+sizes m = "("++show (rows m)++"><"++show (cols m)++")\n"++dsp :: [[[Char]]] -> [Char]+dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp+ where+ mt = transpose as+ longs = map (maximum . map length) mt+ mtp = zipWith (\a b -> map (pad a) b) longs mt+ pad n str = replicate (n - length str) ' ' ++ str+ unwords' = concat . intersperse ", "++------------------------------------------------------------------++instance (Element a, Read a) => Read (Matrix a) where+ readsPrec _ s = [((rs><cs) . read $ listnums, rest)]+ where (thing,rest) = breakAt ']' s+ (dims,listnums) = breakAt ')' thing+ cs = read . init . fst. breakAt ')' . snd . breakAt '<' $ dims+ rs = read . snd . breakAt '(' .init . fst . breakAt '>' $ dims+++breakAt :: Eq a => a -> [a] -> ([a], [a])+breakAt c l = (a++[c],tail b) where+ (a,b) = break (==c) l++--------------------------------------------------------------------------------+-- | Specification of indexes for the operator '??'.+data Extractor+ = All+ | Range Int Int Int+ | Pos (Vector I)+ | PosCyc (Vector I)+ | Take Int+ | TakeLast Int+ | Drop Int+ | DropLast Int+ deriving Show++ppext :: Extractor -> [Char]+ppext All = ":"+ppext (Range a 1 c) = printf "%d:%d" a c+ppext (Range a b c) = printf "%d:%d:%d" a b c+ppext (Pos v) = show (toList v)+ppext (PosCyc v) = "Cyclic"++show (toList v)+ppext (Take n) = printf "Take %d" n+ppext (Drop n) = printf "Drop %d" n+ppext (TakeLast n) = printf "TakeLast %d" n+ppext (DropLast n) = printf "DropLast %d" n++{- | General matrix slicing.++>>> m+(4><5)+ [ 0, 1, 2, 3, 4+ , 5, 6, 7, 8, 9+ , 10, 11, 12, 13, 14+ , 15, 16, 17, 18, 19 ]++>>> m ?? (Take 3, DropLast 2)+(3><3)+ [ 0, 1, 2+ , 5, 6, 7+ , 10, 11, 12 ]++>>> m ?? (Pos (idxs[2,1]), All)+(2><5)+ [ 10, 11, 12, 13, 14+ , 5, 6, 7, 8, 9 ]++>>> m ?? (PosCyc (idxs[-7,80]), Range 4 (-2) 0)+(2><3)+ [ 9, 7, 5+ , 4, 2, 0 ]++-}+infixl 9 ??+(??) :: Element t => Matrix t -> (Extractor,Extractor) -> Matrix t++minEl :: Vector CInt -> CInt+minEl = toScalarI Min+maxEl :: Vector CInt -> CInt+maxEl = toScalarI Max+cmodi :: Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt+cmodi = vectorMapValI ModVS++extractError :: Matrix t1 -> (Extractor, Extractor) -> t+extractError m (e1,e2)= error $ printf "can't extract (%s,%s) from matrix %dx%d" (ppext e1::String) (ppext e2::String) (rows m) (cols m)++m ?? (Range a s b,e) | s /= 1 = m ?? (Pos (idxs [a,a+s .. b]), e)+m ?? (e,Range a s b) | s /= 1 = m ?? (e, Pos (idxs [a,a+s .. b]))++m ?? e@(Range a _ b,_) | a < 0 || b >= rows m = extractError m e+m ?? e@(_,Range a _ b) | a < 0 || b >= cols m = extractError m e++m ?? e@(Pos vs,_) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (rows m)) = extractError m e+m ?? e@(_,Pos vs) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (cols m)) = extractError m e++m ?? (All,All) = m++m ?? (Range a _ b,e) | a > b = m ?? (Take 0,e)+m ?? (e,Range a _ b) | a > b = m ?? (e,Take 0)++m ?? (Take n,e)+ | n <= 0 = (0><cols m) [] ?? (All,e)+ | n >= rows m = m ?? (All,e)++m ?? (e,Take n)+ | n <= 0 = (rows m><0) [] ?? (e,All)+ | n >= cols m = m ?? (e,All)++m ?? (Drop n,e)+ | n <= 0 = m ?? (All,e)+ | n >= rows m = (0><cols m) [] ?? (All,e)++m ?? (e,Drop n)+ | n <= 0 = m ?? (e,All)+ | n >= cols m = (rows m><0) [] ?? (e,All)++m ?? (TakeLast n, e) = m ?? (Drop (rows m - n), e)+m ?? (e, TakeLast n) = m ?? (e, Drop (cols m - n))++m ?? (DropLast n, e) = m ?? (Take (rows m - n), e)+m ?? (e, DropLast n) = m ?? (e, Take (cols m - n))++m ?? (er,ec) = unsafePerformIO $ extractR (orderOf m) m moder rs modec cs+ where+ (moder,rs) = mkExt (rows m) er+ (modec,cs) = mkExt (cols m) ec+ ran a b = (0, idxs [a,b])+ pos ks = (1, ks)+ mkExt _ (Pos ks) = pos ks+ mkExt n (PosCyc ks)+ | n == 0 = mkExt n (Take 0)+ | otherwise = pos (cmodi (fi n) ks)+ mkExt _ (Range mn _ mx) = ran mn mx+ mkExt _ (Take k) = ran 0 (k-1)+ mkExt n (Drop k) = ran k (n-1)+ mkExt n _ = ran 0 (n-1) -- All++--------------------------------------------------------------------------------++-- | obtains the common value of a property of a list+common :: (Eq a) => (b->a) -> [b] -> Maybe a+common f = commonval . map f+ where+ commonval :: (Eq a) => [a] -> Maybe a+ commonval [] = Nothing+ commonval [a] = Just a+ commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing+++-- | creates a matrix from a vertical list of matrices+joinVert :: Element t => [Matrix t] -> Matrix t+joinVert [] = emptyM 0 0+joinVert ms = case common cols ms of+ Nothing -> error "(impossible) joinVert on matrices with different number of columns"+ Just c -> matrixFromVector RowMajor (sum (map rows ms)) c $ vjoin (map flatten ms)++-- | creates a matrix from a horizontal list of matrices+joinHoriz :: Element t => [Matrix t] -> Matrix t+joinHoriz ms = trans. joinVert . map trans $ ms++{- | Create a matrix from blocks given as a list of lists of matrices.++Single row-column components are automatically expanded to match the+corresponding common row and column:++@+disp = putStr . dispf 2+@++>>> disp $ fromBlocks [[ident 5, 7, row[10,20]], [3, diagl[1,2,3], 0]]+8x10+1 0 0 0 0 7 7 7 10 20+0 1 0 0 0 7 7 7 10 20+0 0 1 0 0 7 7 7 10 20+0 0 0 1 0 7 7 7 10 20+0 0 0 0 1 7 7 7 10 20+3 3 3 3 3 1 0 0 0 0+3 3 3 3 3 0 2 0 0 0+3 3 3 3 3 0 0 3 0 0++-}+fromBlocks :: Element t => [[Matrix t]] -> Matrix t+fromBlocks = fromBlocksRaw . adaptBlocks++fromBlocksRaw :: Element t => [[Matrix t]] -> Matrix t+fromBlocksRaw mms = joinVert . map joinHoriz $ mms++adaptBlocks :: Element t => [[Matrix t]] -> [[Matrix t]]+adaptBlocks ms = ms' where+ bc = case common length ms of+ Just c -> c+ Nothing -> error "fromBlocks requires rectangular [[Matrix]]"+ rs = map (compatdim . map rows) ms+ cs = map (compatdim . map cols) (transpose ms)+ szs = sequence [rs,cs]+ ms' = chunksOf bc $ zipWith g szs (concat ms)++ g [Just nr,Just nc] m+ | nr == r && nc == c = m+ | r == 1 && c == 1 = matrixFromVector RowMajor nr nc (constantD x (nr*nc))+ | r == 1 = fromRows (replicate nr (flatten m))+ | otherwise = fromColumns (replicate nc (flatten m))+ where+ r = rows m+ c = cols m+ x = m@@>(0,0)+ g _ _ = error "inconsistent dimensions in fromBlocks"+++--------------------------------------------------------------------------------++{- | create a block diagonal matrix++>>> disp 2 $ diagBlock [konst 1 (2,2), konst 2 (3,5), col [5,7]]+7x8+1 1 0 0 0 0 0 0+1 1 0 0 0 0 0 0+0 0 2 2 2 2 2 0+0 0 2 2 2 2 2 0+0 0 2 2 2 2 2 0+0 0 0 0 0 0 0 5+0 0 0 0 0 0 0 7++>>> diagBlock [(0><4)[], konst 2 (2,3)] :: Matrix Double+(2><7)+ [ 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0+ , 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 ]++-}+diagBlock :: (Element t, Num t) => [Matrix t] -> Matrix t+diagBlock ms = fromBlocks $ zipWith f ms [0..]+ where+ f m k = take n $ replicate k z ++ m : repeat z+ n = length ms+ z = (1><1) [0]++--------------------------------------------------------------------------------+++-- | Reverse rows+flipud :: Element t => Matrix t -> Matrix t+flipud m = extractRows [r-1,r-2 .. 0] $ m+ where+ r = rows m++-- | Reverse columns+fliprl :: Element t => Matrix t -> Matrix t+fliprl m = extractColumns [c-1,c-2 .. 0] $ m+ where+ c = cols m++------------------------------------------------------------++{- | creates a rectangular diagonal matrix:++>>> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double+(4><5)+ [ 10.0, 7.0, 7.0, 7.0, 7.0+ , 7.0, 20.0, 7.0, 7.0, 7.0+ , 7.0, 7.0, 30.0, 7.0, 7.0+ , 7.0, 7.0, 7.0, 7.0, 7.0 ]++-}+diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t+diagRect z v r c = ST.runSTMatrix $ do+ m <- ST.newMatrix z r c+ let d = min r c `min` (dim v)+ mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1]+ return m++-- | extracts the diagonal from a rectangular matrix+takeDiag :: (Element t) => Matrix t -> Vector t+takeDiag m = fromList [flatten m @> (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]]++------------------------------------------------------------++{- | Create a matrix from a list of elements++>>> (2><3) [2, 4, 7+2*iC, -3, 11, 0]+(2><3)+ [ 2.0 :+ 0.0, 4.0 :+ 0.0, 7.0 :+ 2.0+ , (-3.0) :+ (-0.0), 11.0 :+ 0.0, 0.0 :+ 0.0 ]++The input list is explicitly truncated, so that it can+safely be used with lists that are too long (like infinite lists).++>>> (2><3)[1..]+(2><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0 ]++This is the format produced by the instances of Show (Matrix a), which+can also be used for input.++-}+(><) :: (Storable a) => Int -> Int -> [a] -> Matrix a+r >< c = f where+ f l | dim v == r*c = matrixFromVector RowMajor r c v+ | otherwise = error $ "inconsistent list size = "+ ++show (dim v) ++" in ("++show r++"><"++show c++")"+ where v = fromList $ take (r*c) l++----------------------------------------------------------------++takeRows :: Element t => Int -> Matrix t -> Matrix t+takeRows n mt = subMatrix (0,0) (n, cols mt) mt++-- | Creates a matrix with the last n rows of another matrix+takeLastRows :: Element t => Int -> Matrix t -> Matrix t+takeLastRows n mt = subMatrix (rows mt - n, 0) (n, cols mt) mt++dropRows :: Element t => Int -> Matrix t -> Matrix t+dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt++-- | Creates a copy of a matrix without the last n rows+dropLastRows :: Element t => Int -> Matrix t -> Matrix t+dropLastRows n mt = subMatrix (0,0) (rows mt - n, cols mt) mt++takeColumns :: Element t => Int -> Matrix t -> Matrix t+takeColumns n mt = subMatrix (0,0) (rows mt, n) mt++-- |Creates a matrix with the last n columns of another matrix+takeLastColumns :: Element t => Int -> Matrix t -> Matrix t+takeLastColumns n mt = subMatrix (0, cols mt - n) (rows mt, n) mt++dropColumns :: Element t => Int -> Matrix t -> Matrix t+dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt++-- | Creates a copy of a matrix without the last n columns+dropLastColumns :: Element t => Int -> Matrix t -> Matrix t+dropLastColumns n mt = subMatrix (0,0) (rows mt, cols mt - n) mt++----------------------------------------------------------------++{- | Creates a 'Matrix' from a list of lists (considered as rows).++>>> fromLists [[1,2],[3,4],[5,6]]+(3><2)+ [ 1.0, 2.0+ , 3.0, 4.0+ , 5.0, 6.0 ]++-}+fromLists :: Element t => [[t]] -> Matrix t+fromLists = fromRows . map fromList++-- | creates a 1-row matrix from a vector+--+-- >>> asRow (fromList [1..5])+-- (1><5)+-- [ 1.0, 2.0, 3.0, 4.0, 5.0 ]+--+asRow :: Storable a => Vector a -> Matrix a+asRow = trans . asColumn++-- | creates a 1-column matrix from a vector+--+-- >>> asColumn (fromList [1..5])+-- (5><1)+-- [ 1.0+-- , 2.0+-- , 3.0+-- , 4.0+-- , 5.0 ]+--+asColumn :: Storable a => Vector a -> Matrix a+asColumn v = reshape 1 v++++{- | creates a Matrix of the specified size using the supplied function to+ to map the row\/column position to the value at that row\/column position.++@> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c)+(3><4)+ [ 0.0, 0.0, 0.0, 0.0, 0.0+ , 0.0, 1.0, 2.0, 3.0, 4.0+ , 0.0, 2.0, 4.0, 6.0, 8.0]@++Hilbert matrix of order N:++@hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@++-}+buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a+buildMatrix rc cc f =+ fromLists $ map (map f)+ $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)]++-----------------------------------------------------++fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e+fromArray2D m = (r><c) (elems m)+ where ((r0,c0),(r1,c1)) = bounds m+ r = r1-r0+1+ c = c1-c0+1+++-- | rearranges the rows of a matrix according to the order given in a list of integers.+extractRows :: Element t => [Int] -> Matrix t -> Matrix t+extractRows l m = m ?? (Pos (idxs l), All)++-- | rearranges the rows of a matrix according to the order given in a list of integers.+extractColumns :: Element t => [Int] -> Matrix t -> Matrix t+extractColumns l m = m ?? (All, Pos (idxs l))+++{- | creates matrix by repetition of a matrix a given number of rows and columns++>>> repmat (ident 2) 2 3+(4><6)+ [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0+ , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0+ , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0+ , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ]++-}+repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t+repmat m r c+ | r == 0 || c == 0 = emptyM (r*rows m) (c*cols m)+ | otherwise = fromBlocks $ replicate r $ replicate c $ m++-- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix.+liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t+liftMatrix2Auto f m1 m2+ | compat' m1 m2 = lM f m1 m2+ | ok = lM f m1' m2'+ | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2+ where+ (r1,c1) = size m1+ (r2,c2) = size m2+ r = max r1 r2+ c = max c1 c2+ r0 = min r1 r2+ c0 = min c1 c2+ ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2+ m1' = conformMTo (r,c) m1+ m2' = conformMTo (r,c) m2++-- FIXME do not flatten if equal order+lM :: (Storable t, Element t1, Element t2)+ => (Vector t1 -> Vector t2 -> Vector t)+ -> Matrix t1 -> Matrix t2 -> Matrix t+lM f m1 m2 = matrixFromVector+ RowMajor+ (max' (rows m1) (rows m2))+ (max' (cols m1) (cols m2))+ (f (flatten m1) (flatten m2))+ where+ max' 1 b = b+ max' a 1 = a+ max' a b = max a b++compat' :: Matrix a -> Matrix b -> Bool+compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2+ where+ s1 = size m1+ s2 = size m2++------------------------------------------------------------++toBlockRows :: Element t => [Int] -> Matrix t -> [Matrix t]+toBlockRows [r] m+ | r == rows m = [m]+toBlockRows rs m+ | cols m > 0 = map (reshape (cols m)) (takesV szs (flatten m))+ | otherwise = map g rs+ where+ szs = map (* cols m) rs+ g k = (k><0)[]++toBlockCols :: Element t => [Int] -> Matrix t -> [Matrix t]+toBlockCols [c] m | c == cols m = [m]+toBlockCols cs m = map trans . toBlockRows cs . trans $ m++-- | Partition a matrix into blocks with the given numbers of rows and columns.+-- The remaining rows and columns are discarded.+toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]]+toBlocks rs cs m+ | ok = map (toBlockCols cs) . toBlockRows rs $ m+ | otherwise = error $ "toBlocks: bad partition: "++show rs++" "++show cs+ ++ " "++shSize m+ where+ ok = sum rs <= rows m && sum cs <= cols m && all (>=0) rs && all (>=0) cs++-- | Fully partition a matrix into blocks of the same size. If the dimensions are not+-- a multiple of the given size the last blocks will be smaller.+toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]]+toBlocksEvery r c m+ | r < 1 || c < 1 = error $ "toBlocksEvery expects block sizes > 0, given "++show r++" and "++ show c+ | otherwise = toBlocks rs cs m+ where+ (qr,rr) = rows m `divMod` r+ (qc,rc) = cols m `divMod` c+ rs = replicate qr r ++ if rr > 0 then [rr] else []+ cs = replicate qc c ++ if rc > 0 then [rc] else []++-------------------------------------------------------------------++-- Given a column number and a function taking matrix indexes, returns+-- a function which takes vector indexes (that can be used on the+-- flattened matrix).+mk :: Int -> ((Int, Int) -> t) -> (Int -> t)+mk c g = \k -> g (divMod k c)++{- |++>>> mapMatrixWithIndexM_ (\(i,j) v -> printf "m[%d,%d] = %.f\n" i j v :: IO()) ((2><3)[1 :: Double ..])+m[0,0] = 1+m[0,1] = 2+m[0,2] = 3+m[1,0] = 4+m[1,1] = 5+m[1,2] = 6++-}+mapMatrixWithIndexM_+ :: (Element a, Num a, Monad m) =>+ ((Int, Int) -> a -> m ()) -> Matrix a -> m ()+mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m+ where+ c = cols m++{- |++>>> mapMatrixWithIndexM (\(i,j) v -> Just $ 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)+Just (3><3)+ [ 100.0, 1.0, 2.0+ , 10.0, 111.0, 12.0+ , 20.0, 21.0, 122.0 ]++-}+mapMatrixWithIndexM+ :: (Element a, Storable b, Monad m) =>+ ((Int, Int) -> a -> m b) -> Matrix a -> m (Matrix b)+mapMatrixWithIndexM g m = liftM (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m+ where+ c = cols m++{- |++>>> mapMatrixWithIndex (\(i,j) v -> 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double)+(3><3)+ [ 100.0, 1.0, 2.0+ , 10.0, 111.0, 12.0+ , 20.0, 21.0, 122.0 ]++ -}+mapMatrixWithIndex+ :: (Element a, Storable b) =>+ ((Int, Int) -> a -> b) -> Matrix a -> Matrix b+mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m+ where+ c = cols m++mapMatrix :: (Element a, Element b) => (a -> b) -> Matrix a -> Matrix b+mapMatrix f = liftMatrix (mapVector f)
+ src/Internal/IO.hs view
@@ -0,0 +1,183 @@+-----------------------------------------------------------------------------+-- |+-- Module : Internal.IO+-- Copyright : (c) Alberto Ruiz 2010+-- License : BSD3+--+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Display, formatting and IO functions for numeric 'Vector' and 'Matrix'+--+-----------------------------------------------------------------------------++module Internal.IO (+ dispf, disps, dispcf, vecdisp, latexFormat, format,+ loadMatrix, loadMatrix', saveMatrix+) where++import Internal.Devel+import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Text.Printf(printf, PrintfArg, PrintfType)+import Data.List(intersperse,transpose)+import Data.Complex+++-- | Formatting tool+table :: String -> [[String]] -> String+table sep as = unlines . map unwords' $ transpose mtp+ where+ mt = transpose as+ longs = map (maximum . map length) mt+ mtp = zipWith (\a b -> map (pad a) b) longs mt+ pad n str = replicate (n - length str) ' ' ++ str+ unwords' = concat . intersperse sep++++{- | Creates a string from a matrix given a separator and a function to show each entry. Using+this function the user can easily define any desired display function:++@import Text.Printf(printf)@++@disp = putStr . format \" \" (printf \"%.2f\")@++-}+format :: (Element t) => String -> (t -> String) -> Matrix t -> String+format sep f m = table sep . map (map f) . toLists $ m++{- | Show a matrix with \"autoscaling\" and a given number of decimal places.++>>> putStr . disps 2 $ 120 * (3><4) [1..]+3x4 E3+ 0.12 0.24 0.36 0.48+ 0.60 0.72 0.84 0.96+ 1.08 1.20 1.32 1.44++-}+disps :: Int -> Matrix Double -> String+disps d x = sdims x ++ " " ++ formatScaled d x++{- | Show a matrix with a given number of decimal places.++>>> dispf 2 (1/3 + ident 3)+"3x3\n1.33 0.33 0.33\n0.33 1.33 0.33\n0.33 0.33 1.33\n"++>>> putStr . dispf 2 $ (3><4)[1,1.5..]+3x4+1.00 1.50 2.00 2.50+3.00 3.50 4.00 4.50+5.00 5.50 6.00 6.50++>>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1)+0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00++-}+dispf :: Int -> Matrix Double -> String+dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x++sdims :: Matrix t -> [Char]+sdims x = show (rows x) ++ "x" ++ show (cols x)++formatFixed :: (Show a, Text.Printf.PrintfArg t, Element t)+ => a -> Matrix t -> String+formatFixed d x = format " " (printf ("%."++show d++"f")) $ x++isInt :: Matrix Double -> Bool+isInt = all lookslikeInt . toList . flatten++formatScaled :: (Text.Printf.PrintfArg b, RealFrac b, Floating b, Num t, Element b, Show t)+ => t -> Matrix b -> [Char]+formatScaled dec t = "E"++show o++"\n" ++ ss+ where ss = format " " (printf fmt. g) t+ g x | o >= 0 = x/10^(o::Int)+ | otherwise = x*10^(-o)+ o | rows t == 0 || cols t == 0 = 0+ | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t+ fmt = '%':show (dec+3) ++ '.':show dec ++"f"++{- | Show a vector using a function for showing matrices.++>>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1)+10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00++-}+vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String+vecdisp f v+ = ((show (dim v) ++ " |> ") ++) . (++"\n")+ . unwords . lines . tail . dropWhile (not . (`elem` " \n"))+ . f . trans . reshape 1+ $ v++{- | Tool to display matrices with latex syntax.++>>> latexFormat "bmatrix" (dispf 2 $ ident 2)+"\\begin{bmatrix}\n1 & 0\n\\\\\n0 & 1\n\\end{bmatrix}"++-}+latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc.+ -> String -- ^ Formatted matrix, with elements separated by spaces and newlines+ -> String+latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}"+ where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines++-- | Pretty print a complex number with at most n decimal digits.+showComplex :: Int -> Complex Double -> String+showComplex d (a:+b)+ | isZero a && isZero b = "0"+ | isZero b = sa+ | isZero a && isOne b = s2++"i"+ | isZero a = sb++"i"+ | isOne b = sa++s3++"i"+ | otherwise = sa++s1++sb++"i"+ where+ sa = shcr d a+ sb = shcr d b+ s1 = if b<0 then "" else "+"+ s2 = if b<0 then "-" else ""+ s3 = if b<0 then "-" else "+"++shcr :: (Show a, Show t1, Text.Printf.PrintfType t, Text.Printf.PrintfArg t1, RealFrac t1)+ => a -> t1 -> t+shcr d a | lookslikeInt a = printf "%.0f" a+ | otherwise = printf ("%."++show d++"f") a++lookslikeInt :: (Show a, RealFrac a) => a -> Bool+lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx+ where shx = show x++isZero :: Show a => a -> Bool+isZero x = show x `elem` ["0.0","-0.0"]+isOne :: Show a => a -> Bool+isOne x = show x `elem` ["1.0","-1.0"]++-- | Pretty print a complex matrix with at most n decimal digits.+dispcf :: Int -> Matrix (Complex Double) -> String+dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m++--------------------------------------------------------------------++apparentCols :: FilePath -> IO Int+apparentCols s = f . dropWhile null . map words . lines <$> readFile s+ where+ f [] = 0+ f (x:_) = length x+++-- | load a matrix from an ASCII file formatted as a 2D table.+loadMatrix :: FilePath -> IO (Matrix Double)+loadMatrix f = do+ v <- vectorScan f+ c <- apparentCols f+ if (dim v `mod` c /= 0)+ then+ error $ printf "loadMatrix: %d elements and %d columns in file %s"+ (dim v) c f+ else+ return (reshape c v)++loadMatrix' :: FilePath -> IO (Maybe (Matrix Double))+loadMatrix' name = mbCatch (loadMatrix name)+
+ src/Internal/LAPACK.hs view
@@ -0,0 +1,758 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.LinearAlgebra.LAPACK+-- Copyright : (c) Alberto Ruiz 2006-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Functional interface to selected LAPACK functions (<http://www.netlib.org/lapack>).+--+-----------------------------------------------------------------------------+++module Internal.LAPACK where++import Data.Bifunctor (first)++import Internal.Devel+import Internal.Vector+import Internal.Matrix hiding ((#), (#!))+import Internal.Conversion+import Internal.Element+import Foreign.Ptr(nullPtr)+import Foreign.C.Types+import Control.Monad(when)+import System.IO.Unsafe(unsafePerformIO)++-----------------------------------------------------------------------------------++infixr 1 #+a # b = apply a b+{-# INLINE (#) #-}++a #! b = a # b # id+{-# INLINE (#!) #-}++-----------------------------------------------------------------------------------++type TMMM t = t ::> t ::> t ::> Ok++type F = Float+type Q = Complex Float++foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM R+foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TMMM C+foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TMMM F+foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TMMM Q+foreign import ccall unsafe "multiplyI" c_multiplyI :: I -> TMMM I+foreign import ccall unsafe "multiplyL" c_multiplyL :: Z -> TMMM Z++isT (rowOrder -> False) = 0+isT _ = 1++tt x@(rowOrder -> False) = x+tt x = trans x++multiplyAux f st a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "+++ show (rows a,cols a) ++ " x " ++ show (rows b, cols b)+ s <- createMatrix ColumnMajor (rows a) (cols b)+ ((tt a) # (tt b) #! s) (f (isT a) (isT b)) #| st+ return s++-- | Matrix product based on BLAS's /dgemm/.+multiplyR :: Matrix Double -> Matrix Double -> Matrix Double+multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b++-- | Matrix product based on BLAS's /zgemm/.+multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+multiplyC a b = multiplyAux zgemmc "zgemmc" a b++-- | Matrix product based on BLAS's /sgemm/.+multiplyF :: Matrix Float -> Matrix Float -> Matrix Float+multiplyF a b = multiplyAux sgemmc "sgemmc" a b++-- | Matrix product based on BLAS's /cgemm/.+multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float)+multiplyQ a b = multiplyAux cgemmc "cgemmc" a b++multiplyI :: I -> Matrix CInt -> Matrix CInt -> Matrix CInt+multiplyI m a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $+ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b+ s <- createMatrix ColumnMajor (rows a) (cols b)+ (a # b #! s) (c_multiplyI m) #|"c_multiplyI"+ return s++multiplyL :: Z -> Matrix Z -> Matrix Z -> Matrix Z+multiplyL m a b = unsafePerformIO $ do+ when (cols a /= rows b) $ error $+ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b+ s <- createMatrix ColumnMajor (rows a) (cols b)+ (a # b #! s) (c_multiplyL m) #|"c_multiplyL"+ return s++-----------------------------------------------------------------------------++type TSVD t = t ::> t ::> R :> t ::> Ok++foreign import ccall unsafe "svd_l_R" dgesvd :: TSVD R+foreign import ccall unsafe "svd_l_C" zgesvd :: TSVD C+foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TSVD R+foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TSVD C++-- | Full SVD of a real matrix using LAPACK's /dgesvd/.+svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+svdR = svdAux dgesvd "svdR"++-- | Full SVD of a real matrix using LAPACK's /dgesdd/.+svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+svdRd = svdAux dgesdd "svdRdd"++-- | Full SVD of a complex matrix using LAPACK's /zgesvd/.+svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+svdC = svdAux zgesvd "svdC"++-- | Full SVD of a complex matrix using LAPACK's /zgesdd/.+svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+svdCd = svdAux zgesdd "svdCdd"++svdAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r r+ s <- createVector (min r c)+ v <- createMatrix ColumnMajor c c+ (a # u # s #! v) f #| st+ return (u,s,v)+ where+ r = rows x+ c = cols x+++-- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'.+thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+thinSVDR = thinSVDAux dgesvd "thinSVDR"++-- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'.+thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+thinSVDC = thinSVDAux zgesvd "thinSVDC"++-- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'.+thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)+thinSVDRd = thinSVDAux dgesdd "thinSVDRdd"++-- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'.+thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))+thinSVDCd = thinSVDAux zgesdd "thinSVDCdd"++thinSVDAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r q+ s <- createVector q+ v <- createMatrix ColumnMajor q c+ (a # u # s #! v) f #| st+ return (u,s,v)+ where+ r = rows x+ c = cols x+ q = min r c+++-- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'.+svR :: Matrix Double -> Vector Double+svR = svAux dgesvd "svR"++-- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'.+svC :: Matrix (Complex Double) -> Vector Double+svC = svAux zgesvd "svC"++-- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'.+svRd :: Matrix Double -> Vector Double+svRd = svAux dgesdd "svRd"++-- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'.+svCd :: Matrix (Complex Double) -> Vector Double+svCd = svAux zgesdd "svCd"++svAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ s <- createVector q+ (a #! s) g #| st+ return s+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa nb pb = f ra ca xra xca pa 0 0 0 0 nullPtr nb pb 0 0 0 0 nullPtr+++-- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'.+rightSVR :: Matrix Double -> (Vector Double, Matrix Double)+rightSVR = rightSVAux dgesvd "rightSVR"++-- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'.+rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+rightSVC = rightSVAux zgesvd "rightSVC"++rightSVAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ s <- createVector q+ v <- createMatrix ColumnMajor c c+ (a # s #! v) g #| st+ return (s,v)+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr+++-- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'.+leftSVR :: Matrix Double -> (Matrix Double, Vector Double)+leftSVR = leftSVAux dgesvd "leftSVR"++-- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'.+leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double)+leftSVC = leftSVAux zgesvd "leftSVC"++leftSVAux f st x = unsafePerformIO $ do+ a <- copy ColumnMajor x+ u <- createMatrix ColumnMajor r r+ s <- createVector q+ (a # u #! s) g #| st+ return (u,s)+ where+ r = rows x+ c = cols x+ q = min r c+ g ra ca xra xca pa ru cu xru xcu pu nb pb = f ra ca xra xca pa ru cu xru xcu pu nb pb 0 0 0 0 nullPtr++-----------------------------------------------------------------------------++foreign import ccall unsafe "eig_l_R" dgeev :: R ::> R ::> C :> R ::> Ok+foreign import ccall unsafe "eig_l_G" dggev :: R ::> R ::> C :> R :> R ::> R ::> Ok+foreign import ccall unsafe "eig_l_C" zgeev :: C ::> C ::> C :> C ::> Ok+foreign import ccall unsafe "eig_l_GC" zggev :: C ::> C ::> C :> C :> C ::> C ::> Ok+foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> R :> R ::> Ok+foreign import ccall unsafe "eig_l_H" zheev :: CInt -> R :> C ::> Ok++eigAux f st m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ v <- createMatrix ColumnMajor r r+ (a # l #! v) g #| st+ return (l,v)+ where+ r = rows m+ g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr+++-- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/.+-- The eigenvectors are the columns of v. The eigenvalues are not sorted.+eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double))+eigC = eigAux zgeev "eigC"++eigOnlyAux f st m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ (a #! l) g #| st+ return l+ where+ r = rows m+ g ra ca xra xca pa nl pl = f ra ca xra xca pa 0 0 0 0 nullPtr nl pl 0 0 0 0 nullPtr++-- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'.+-- The eigenvalues are not sorted.+eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double)+eigOnlyC = eigOnlyAux zgeev "eigOnlyC"++-- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/.+-- The eigenvectors are the columns of v. The eigenvalues are not sorted.+eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double))+eigR m = (s', v'')+ where (s,v) = eigRaux m+ s' = fixeig1 s+ v' = toRows $ trans v+ v'' = fromColumns $ fixeig (toList s') v'++eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double)+eigRaux m = unsafePerformIO $ do+ a <- copy ColumnMajor m+ l <- createVector r+ v <- createMatrix ColumnMajor r r+ (a # l #! v) g #| "eigR"+ return (l,v)+ where+ r = rows m+ g ra ca xra xca pa = dgeev ra ca xra xca pa 0 0 0 0 nullPtr++fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s))+ where r = dim s++fixeig [] _ = []+fixeig [_] [v] = [comp' v]+fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs)+ | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1, mapVector negate v2) : fixeig r vs+ | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs)+fixeig _ _ = error "fixeig with impossible inputs"++-- For dggev alpha(i) / beta(i), alpha(i+1) / beta(i+1) form a complex conjugate pair when Im alpha(i) != 0.+-- However, this does not lead to Re alpha(i) == Re alpha(i+1), since beta(i) and beta(i+1)+-- can be different. Therefore old 'fixeig' would fail for 'eigG'.+fixeigG [] _ = []+fixeigG [_] [v] = [comp' v]+fixeigG ((_:+ai1) : an : as) (v1:v2:vs)+ | abs ai1 > 1e-13 = toComplex' (v1, v2) : toComplex' (v1, mapVector negate v2) : fixeigG as vs+ | otherwise = comp' v1 : fixeigG (an:as) (v2:vs)+fixeigG _ _ = error "fixeigG with impossible inputs"++-- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'.+-- The eigenvalues are not sorted.+eigOnlyR :: Matrix Double -> Vector (Complex Double)+eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR"++-- | Generalized eigenvalues and right eigenvectors of a pair of real matrices, using LAPACK's /dggev/.+-- The eigenvectors are the columns of v. The eigenvalues are represented as alphas / betas and not sorted.+eigG :: Matrix Double -> Matrix Double -> (Vector (Complex Double), Vector Double, Matrix (Complex Double))+eigG a b = (alpha', beta, v'')+ where+ (alpha, beta, v) = eigGaux dggev a b "eigG"+ alpha' = fixeig1 alpha+ v' = toRows $ trans v+ v'' = fromColumns $ fixeigG (toList alpha') v'++eigGaux f ma mb st = unsafePerformIO $ do+ a <- copy ColumnMajor ma+ b <- copy ColumnMajor mb+ alpha <- createVector r+ beta <- createVector r+ vr <- createMatrix ColumnMajor r r++ (a # b # alpha # beta #! vr) g #| st++ return (alpha, beta, vr)+ where+ r = rows ma+ g ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta = f ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta 0 0 0 0 nullPtr ++eigGOnlyAux f ma mb st = unsafePerformIO $ do+ a <- copy ColumnMajor ma+ b <- copy ColumnMajor mb+ alpha <- createVector r+ beta <- createVector r++ (a # b # alpha #! beta) g #| st++ return (alpha, beta)+ where+ r = rows ma+ g ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta = f ar ac xra xca pa br bc xrb xcb pb alphan palpha betan pbeta 0 0 0 0 nullPtr 0 0 0 0 nullPtr++-- | Generalized eigenvalues and right eigenvectors of a pair of complex matrices, using LAPACK's /zggev/.+-- The eigenvectors are the columns of v. The eigenvalues are represented as alphas / betas and not sorted.+eigGC :: Matrix (Complex Double) -> Matrix (Complex Double) -> (Vector (Complex Double), Vector (Complex Double), Matrix (Complex Double))+eigGC a b = eigGaux zggev a b "eigGC"++eigOnlyG :: Matrix Double -> Matrix Double -> (Vector (Complex Double), Vector Double)+eigOnlyG a b = first fixeig1 $ eigGOnlyAux dggev a b "eigOnlyG"++eigOnlyGC :: Matrix (Complex Double) -> Matrix (Complex Double) -> (Vector (Complex Double), Vector (Complex Double))+eigOnlyGC a b = eigGOnlyAux zggev a b "eigOnlyGC"++-----------------------------------------------------------------------------++eigSHAux f st m = unsafePerformIO $ do+ l <- createVector r+ v <- copy ColumnMajor m+ (l #! v) f #| st+ return (l,v)+ where+ r = rows m++-- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/.+-- The eigenvectors are the columns of v.+-- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order).+eigS :: Matrix Double -> (Vector Double, Matrix Double)+eigS m = (s', fliprl v)+ where (s,v) = eigS' m+ s' = fromList . reverse . toList $ s++-- | 'eigS' in ascending order+eigS' :: Matrix Double -> (Vector Double, Matrix Double)+eigS' = eigSHAux (dsyev 1) "eigS'"++-- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/.+-- The eigenvectors are the columns of v.+-- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order).+eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+eigH m = (s', fliprl v)+ where+ (s,v) = eigH' m+ s' = fromList . reverse . toList $ s++-- | 'eigH' in ascending order+eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))+eigH' = eigSHAux (zheev 1) "eigH'"+++-- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'.+-- The eigenvalues are sorted in descending order.+eigOnlyS :: Matrix Double -> Vector Double+eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'"++-- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'.+-- The eigenvalues are sorted in descending order.+eigOnlyH :: Matrix (Complex Double) -> Vector Double+eigOnlyH = vrev . fst. eigSHAux (zheev 0) "eigH'"++vrev = flatten . flipud . reshape 1++-----------------------------------------------------------------------------+foreign import ccall unsafe "linearSolveR_l" dgesv :: R ::> R ::> Ok+foreign import ccall unsafe "linearSolveC_l" zgesv :: C ::> C ::> Ok++linearSolveSQAux g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ a' <- copy ColumnMajor a+ s <- copy ColumnMajor b+ (a' #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++-- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'.+linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double+linearSolveR a b = linearSolveSQAux id dgesv "linearSolveR" a b++mbLinearSolveR :: Matrix Double -> Matrix Double -> Maybe (Matrix Double)+mbLinearSolveR a b = linearSolveSQAux mbCatch dgesv "linearSolveR" a b+++-- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'.+linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+linearSolveC a b = linearSolveSQAux id zgesv "linearSolveC" a b++mbLinearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Maybe (Matrix (Complex Double))+mbLinearSolveC a b = linearSolveSQAux mbCatch zgesv "linearSolveC" a b++--------------------------------------------------------------------------------+foreign import ccall unsafe "cholSolveR_l" dpotrs :: R ::> R ::> Ok+foreign import ccall unsafe "cholSolveC_l" zpotrs :: C ::> C ::> Ok+++linearSolveSQAux2 g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ s <- copy ColumnMajor b+ (a #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++-- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'.+cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double+cholSolveR a b = linearSolveSQAux2 id dpotrs "cholSolveR" (fmat a) b++-- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'.+cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b++--------------------------------------------------------------------------------+foreign import ccall unsafe "triSolveR_l_u" dtrtrs_u :: R ::> R ::> Ok+foreign import ccall unsafe "triSolveC_l_u" ztrtrs_u :: C ::> C ::> Ok+foreign import ccall unsafe "triSolveR_l_l" dtrtrs_l :: R ::> R ::> Ok+foreign import ccall unsafe "triSolveC_l_l" ztrtrs_l :: C ::> C ::> Ok+++linearSolveTRAux2 g f st a b+ | n1==n2 && n1==r = unsafePerformIO . g $ do+ s <- copy ColumnMajor b+ (a #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ n1 = rows a+ n2 = cols a+ r = rows b++data UpLo = Lower | Upper++-- | Solves a triangular system of linear equations.+triSolveR :: UpLo -> Matrix Double -> Matrix Double -> Matrix Double+triSolveR Lower a b = linearSolveTRAux2 id dtrtrs_l "triSolveR" (fmat a) b+triSolveR Upper a b = linearSolveTRAux2 id dtrtrs_u "triSolveR" (fmat a) b++-- | Solves a triangular system of linear equations.+triSolveC :: UpLo -> Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+triSolveC Lower a b = linearSolveTRAux2 id ztrtrs_l "triSolveC" (fmat a) b+triSolveC Upper a b = linearSolveTRAux2 id ztrtrs_u "triSolveC" (fmat a) b++--------------------------------------------------------------------------------+foreign import ccall unsafe "triDiagSolveR_l" dgttrs :: R :> R :> R :> R ::> Ok+foreign import ccall unsafe "triDiagSolveC_l" zgttrs :: C :> C :> C :> C ::> Ok++linearSolveGTAux2 g f st dl d du b+ | ndl == nd - 1 &&+ ndu == nd - 1 &&+ nd == r = unsafePerformIO . g $ do+ dl' <- head . toRows <$> copy ColumnMajor (fromRows [dl])+ du' <- head . toRows <$> copy ColumnMajor (fromRows [du])+ s <- copy ColumnMajor b+ (dl' # d # du' #! s) f #| st+ return s+ | otherwise = error $ st ++ " of nonsquare matrix"+ where+ ndl = dim dl+ nd = dim d+ ndu = dim du+ r = rows b++-- | Solves a tridiagonal system of linear equations.+triDiagSolveR dl d du b = linearSolveGTAux2 id dgttrs "triDiagSolveR" dl d du b+triDiagSolveC dl d du b = linearSolveGTAux2 id zgttrs "triDiagSolveC" dl d du b++-----------------------------------------------------------------------------------++foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok+foreign import ccall unsafe "linearSolveLSC_l" zgels :: C ::> C ::> Ok+foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> R ::> R ::> Ok+foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> C ::> C ::> Ok++linearSolveAux f st a b+ | m == rows b = unsafePerformIO $ do+ a' <- copy ColumnMajor a+ r <- createMatrix ColumnMajor (max m n) nrhs+ setRect 0 0 b r+ (a' #! r) f #| st+ return r+ | otherwise = error $ "different number of rows in linearSolve ("++st++")"+ where+ m = rows a+ n = cols a+ nrhs = cols b++-- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'.+linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double+linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux dgels "linearSolverLSR" a b++-- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'.+linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)+linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux zgels "linearSolveLSC" a b++-- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.+linearSolveSVDR :: Maybe Double -- ^ rcond+ -> Matrix Double -- ^ coefficient matrix+ -> Matrix Double -- ^ right hand sides (as columns)+ -> Matrix Double -- ^ solution vectors (as columns)+linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux (dgelss rcond) "linearSolveSVDR" a b+linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b++-- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.+linearSolveSVDC :: Maybe Double -- ^ rcond+ -> Matrix (Complex Double) -- ^ coefficient matrix+ -> Matrix (Complex Double) -- ^ right hand sides (as columns)+ -> Matrix (Complex Double) -- ^ solution vectors (as columns)+linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $+ linearSolveAux (zgelss rcond) "linearSolveSVDC" a b+linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b++-----------------------------------------------------------------------------------++foreign import ccall unsafe "chol_l_H" zpotrf :: C ::> Ok+foreign import ccall unsafe "chol_l_S" dpotrf :: R ::> Ok++cholAux f st a = do+ r <- copy ColumnMajor a+ (r # id) f #| st+ return r++-- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/.+cholH :: Matrix (Complex Double) -> Matrix (Complex Double)+cholH = unsafePerformIO . cholAux zpotrf "cholH"++-- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/.+cholS :: Matrix Double -> Matrix Double+cholS = unsafePerformIO . cholAux dpotrf "cholS"++-- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version).+mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double))+mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH"++-- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version).+mbCholS :: Matrix Double -> Maybe (Matrix Double)+mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS"++-----------------------------------------------------------------------------------++type TMVM t = t ::> t :> t ::> Ok++foreign import ccall unsafe "qr_l_R" dgeqr2 :: R :> R ::> Ok+foreign import ccall unsafe "qr_l_C" zgeqr2 :: C :> C ::> Ok++-- | QR factorization of a real matrix, using LAPACK's /dgeqr2/.+qrR :: Matrix Double -> (Matrix Double, Vector Double)+qrR = qrAux dgeqr2 "qrR"++-- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/.+qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))+qrC = qrAux zgeqr2 "qrC"++qrAux f st a = unsafePerformIO $ do+ r <- copy ColumnMajor a+ tau <- createVector mn+ (tau #! r) f #| st+ return (r,tau)+ where+ m = rows a+ n = cols a+ mn = min m n++foreign import ccall unsafe "c_dorgqr" dorgqr :: R :> R ::> Ok+foreign import ccall unsafe "c_zungqr" zungqr :: C :> C ::> Ok++-- | build rotation from reflectors+qrgrR :: Int -> (Matrix Double, Vector Double) -> Matrix Double+qrgrR = qrgrAux dorgqr "qrgrR"+-- | build rotation from reflectors+qrgrC :: Int -> (Matrix (Complex Double), Vector (Complex Double)) -> Matrix (Complex Double)+qrgrC = qrgrAux zungqr "qrgrC"++qrgrAux f st n (a, tau) = unsafePerformIO $ do+ res <- copy ColumnMajor (subMatrix (0,0) (rows a,n) a)+ ((subVector 0 n tau') #! res) f #| st+ return res+ where+ tau' = vjoin [tau, constantD 0 n]++-----------------------------------------------------------------------------------+foreign import ccall unsafe "hess_l_R" dgehrd :: R :> R ::> Ok+foreign import ccall unsafe "hess_l_C" zgehrd :: C :> C ::> Ok++-- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/.+hessR :: Matrix Double -> (Matrix Double, Vector Double)+hessR = hessAux dgehrd "hessR"++-- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/.+hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))+hessC = hessAux zgehrd "hessC"++hessAux f st a = unsafePerformIO $ do+ r <- copy ColumnMajor a+ tau <- createVector (mn-1)+ (tau #! r) f #| st+ return (r,tau)+ where+ m = rows a+ n = cols a+ mn = min m n++-----------------------------------------------------------------------------------+foreign import ccall unsafe "schur_l_R" dgees :: R ::> R ::> Ok+foreign import ccall unsafe "schur_l_C" zgees :: C ::> C ::> Ok++-- | Schur factorization of a square real matrix, using LAPACK's /dgees/.+schurR :: Matrix Double -> (Matrix Double, Matrix Double)+schurR = schurAux dgees "schurR"++-- | Schur factorization of a square complex matrix, using LAPACK's /zgees/.+schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double))+schurC = schurAux zgees "schurC"++schurAux f st a = unsafePerformIO $ do+ u <- createMatrix ColumnMajor n n+ s <- copy ColumnMajor a+ (u #! s) f #| st+ return (u,s)+ where+ n = rows a++-----------------------------------------------------------------------------------+foreign import ccall unsafe "lu_l_R" dgetrf :: R :> R ::> Ok+foreign import ccall unsafe "lu_l_C" zgetrf :: R :> C ::> Ok++-- | LU factorization of a general real matrix, using LAPACK's /dgetrf/.+luR :: Matrix Double -> (Matrix Double, [Int])+luR = luAux dgetrf "luR"++-- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/.+luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])+luC = luAux zgetrf "luC"++luAux f st a = unsafePerformIO $ do+ lu <- copy ColumnMajor a+ piv <- createVector (min n m)+ (piv #! lu) f #| st+ return (lu, map (pred.round) (toList piv))+ where+ n = rows a+ m = cols a++-----------------------------------------------------------------------------------++foreign import ccall unsafe "luS_l_R" dgetrs :: R ::> R :> R ::> Ok+foreign import ccall unsafe "luS_l_C" zgetrs :: C ::> R :> C ::> Ok++-- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/.+lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double+lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv b++-- | Solve a complex linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/.+lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)+lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv b++lusAux f st a piv b+ | n1==n2 && n2==n =unsafePerformIO $ do+ x <- copy ColumnMajor b+ (a # piv' #! x) f #| st+ return x+ | otherwise = error st+ where+ n1 = rows a+ n2 = cols a+ n = rows b+ piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double++-----------------------------------------------------------------------------------+foreign import ccall unsafe "ldl_R" dsytrf :: R :> R ::> Ok+foreign import ccall unsafe "ldl_C" zhetrf :: R :> C ::> Ok++-- | LDL factorization of a symmetric real matrix, using LAPACK's /dsytrf/.+ldlR :: Matrix Double -> (Matrix Double, [Int])+ldlR = ldlAux dsytrf "ldlR"++-- | LDL factorization of a hermitian complex matrix, using LAPACK's /zhetrf/.+ldlC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])+ldlC = ldlAux zhetrf "ldlC"++ldlAux f st a = unsafePerformIO $ do+ ldl <- copy ColumnMajor a+ piv <- createVector (rows a)+ (piv #! ldl) f #| st+ return (ldl, map (pred.round) (toList piv))++-----------------------------------------------------------------------------------++foreign import ccall unsafe "ldl_S_R" dsytrs :: R ::> R :> R ::> Ok+foreign import ccall unsafe "ldl_S_C" zsytrs :: C ::> R :> C ::> Ok++-- | Solve a real linear system from a precomputed LDL decomposition ('ldlR'), using LAPACK's /dsytrs/.+ldlsR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double+ldlsR a piv b = lusAux dsytrs "ldlsR" (fmat a) piv b++-- | Solve a complex linear system from a precomputed LDL decomposition ('ldlC'), using LAPACK's /zsytrs/.+ldlsC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)+ldlsC a piv b = lusAux zsytrs "ldlsC" (fmat a) piv b
+ src/Internal/Matrix.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ConstrainedClassMethods #-}++-- |+-- Module : Internal.Matrix+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Internal matrix representation+--++module Internal.Matrix where++import Internal.Vector+import Internal.Devel+import Internal.Vectorized hiding ((#), (#!))+import Foreign.Marshal.Alloc ( free )+import Foreign.Marshal.Array(newArray)+import Foreign.Ptr ( Ptr )+import Foreign.Storable ( Storable )+import Data.Complex ( Complex )+import Foreign.C.Types ( CInt(..) )+import Foreign.C.String ( CString, newCString )+import System.IO.Unsafe ( unsafePerformIO )+import Control.DeepSeq ( NFData(..) )+import Text.Printf++-----------------------------------------------------------------++data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq)++-- | Matrix representation suitable for BLAS\/LAPACK computations.++data Matrix t = Matrix+ { irows :: {-# UNPACK #-} !Int+ , icols :: {-# UNPACK #-} !Int+ , xRow :: {-# UNPACK #-} !Int+ , xCol :: {-# UNPACK #-} !Int+ , xdat :: {-# UNPACK #-} !(Vector t)+ }+++rows :: Matrix t -> Int+rows = irows+{-# INLINE rows #-}++cols :: Matrix t -> Int+cols = icols+{-# INLINE cols #-}++size :: Matrix t -> (Int, Int)+size m = (irows m, icols m)+{-# INLINE size #-}++rowOrder :: Matrix t -> Bool+rowOrder m = xCol m == 1 || cols m == 1+{-# INLINE rowOrder #-}++colOrder :: Matrix t -> Bool+colOrder m = xRow m == 1 || rows m == 1+{-# INLINE colOrder #-}++is1d :: Matrix t -> Bool+is1d (size->(r,c)) = r==1 || c==1+{-# INLINE is1d #-}++-- data is not contiguous+isSlice :: Storable t => Matrix t -> Bool+isSlice m@(size->(r,c)) = r*c < dim (xdat m)+{-# INLINE isSlice #-}++orderOf :: Matrix t -> MatrixOrder+orderOf m = if rowOrder m then RowMajor else ColumnMajor+++showInternal :: Storable t => Matrix t -> IO ()+showInternal m = printf "%dx%d %s %s %d:%d (%d)\n" r c slc ord xr xc dv+ where+ r = rows m+ c = cols m+ xr = xRow m+ xc = xCol m+ slc = if isSlice m then "slice" else "full"+ ord = if is1d m then "1d" else if rowOrder m then "rows" else "cols"+ dv = dim (xdat m)++--------------------------------------------------------------------------------++-- | Matrix transpose.+trans :: Matrix t -> Matrix t+trans m@Matrix { irows = r, icols = c, xRow = xr, xCol = xc } =+ m { irows = c, icols = r, xRow = xc, xCol = xr }+++cmat :: (Element t) => Matrix t -> Matrix t+cmat m+ | rowOrder m = m+ | otherwise = extractAll RowMajor m+++fmat :: (Element t) => Matrix t -> Matrix t+fmat m+ | colOrder m = m+ | otherwise = extractAll ColumnMajor m+++-- C-Haskell matrix adapters+{-# INLINE amatr #-}+amatr :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> Ptr a -> f) -> IO r+amatr x f g = unsafeWith (xdat x) (f . g r c)+ where+ r = fi (rows x)+ c = fi (cols x)++{-# INLINE amat #-}+amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r+amat x f g = unsafeWith (xdat x) (f . g r c sr sc)+ where+ r = fi (rows x)+ c = fi (cols x)+ sr = fi (xRow x)+ sc = fi (xCol x)+++instance Storable t => TransArray (Matrix t)+ where+ type TransRaw (Matrix t) b = CInt -> CInt -> Ptr t -> b+ type Trans (Matrix t) b = CInt -> CInt -> CInt -> CInt -> Ptr t -> b+ apply = amat+ {-# INLINE apply #-}+ applyRaw = amatr+ {-# INLINE applyRaw #-}++infixr 1 #+(#) :: TransArray c => c -> (b -> IO r) -> Trans c b -> IO r+a # b = apply a b+{-# INLINE (#) #-}++(#!) :: (TransArray c, TransArray c1) => c1 -> c -> Trans c1 (Trans c (IO r)) -> IO r+a #! b = a # b # id+{-# INLINE (#!) #-}++--------------------------------------------------------------------------------++copy :: Element t => MatrixOrder -> Matrix t -> IO (Matrix t)+copy ord m = extractR ord m 0 (idxs[0,rows m-1]) 0 (idxs[0,cols m-1])++extractAll :: Element t => MatrixOrder -> Matrix t -> Matrix t+extractAll ord m = unsafePerformIO (copy ord m)++{- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose.++>>> flatten (ident 3)+[1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0]+it :: (Num t, Element t) => Vector t++-}+flatten :: Element t => Matrix t -> Vector t+flatten m+ | isSlice m || not (rowOrder m) = xdat (extractAll RowMajor m)+ | otherwise = xdat m+++-- | the inverse of 'Data.Packed.Matrix.fromLists'+toLists :: (Element t) => Matrix t -> [[t]]+toLists = map toList . toRows++++-- | common value with \"adaptable\" 1+compatdim :: [Int] -> Maybe Int+compatdim [] = Nothing+compatdim [a] = Just a+compatdim (a:b:xs)+ | a==b = compatdim (b:xs)+ | a==1 = compatdim (b:xs)+ | b==1 = compatdim (a:xs)+ | otherwise = Nothing+++++-- | Create a matrix from a list of vectors.+-- All vectors must have the same dimension,+-- or dimension 1, which is are automatically expanded.+fromRows :: Element t => [Vector t] -> Matrix t+fromRows [] = emptyM 0 0+fromRows vs = case compatdim (map dim vs) of+ Nothing -> error $ "fromRows expects vectors with equal sizes (or singletons), given: " ++ show (map dim vs)+ Just 0 -> emptyM r 0+ Just c -> matrixFromVector RowMajor r c . vjoin . map (adapt c) $ vs+ where+ r = length vs+ adapt c v+ | c == 0 = fromList[]+ | dim v == c = v+ | otherwise = constantD (v@>0) c++-- | extracts the rows of a matrix as a list of vectors+toRows :: Element t => Matrix t -> [Vector t]+toRows m+ | rowOrder m = map sub rowRange+ | otherwise = map ext rowRange+ where+ rowRange = [0..rows m-1]+ sub k = subVector (k*xRow m) (cols m) (xdat m)+ ext k = xdat $ unsafePerformIO $ extractR RowMajor m 1 (idxs[k]) 0 (idxs[0,cols m-1])+++-- | Creates a matrix from a list of vectors, as columns+fromColumns :: Element t => [Vector t] -> Matrix t+fromColumns m = trans . fromRows $ m++-- | Creates a list of vectors from the columns of a matrix+toColumns :: Element t => Matrix t -> [Vector t]+toColumns m = toRows . trans $ m++-- | Reads a matrix position.+(@@>) :: Storable t => Matrix t -> (Int,Int) -> t+infixl 9 @@>+m@Matrix {irows = r, icols = c} @@> (i,j)+ | i<0 || i>=r || j<0 || j>=c = error "matrix indexing out of range"+ | otherwise = atM' m i j+{-# INLINE (@@>) #-}++-- Unsafe matrix access without range checking+atM' :: Storable t => Matrix t -> Int -> Int -> t+atM' m i j = xdat m `at'` (i * (xRow m) + j * (xCol m))+{-# INLINE atM' #-}++------------------------------------------------------------------++matrixFromVector :: Storable t => MatrixOrder -> Int -> Int -> Vector t -> Matrix t+matrixFromVector _ 1 _ v@(dim->d) = Matrix { irows = 1, icols = d, xdat = v, xRow = d, xCol = 1 }+matrixFromVector _ _ 1 v@(dim->d) = Matrix { irows = d, icols = 1, xdat = v, xRow = 1, xCol = d }+matrixFromVector o r c v+ | r * c == dim v = m+ | otherwise = error $ "can't reshape vector dim = "++ show (dim v)++" to matrix " ++ shSize m+ where+ m | o == RowMajor = Matrix { irows = r, icols = c, xdat = v, xRow = c, xCol = 1 }+ | otherwise = Matrix { irows = r, icols = c, xdat = v, xRow = 1, xCol = r }++-- allocates memory for a new matrix+createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a)+createMatrix ord r c = do+ p <- createVector (r*c)+ return (matrixFromVector ord r c p)++{- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = tr' . reshape r@+where r is the desired number of rows.)++>>> reshape 4 (fromList [1..12])+(3><4)+ [ 1.0, 2.0, 3.0, 4.0+ , 5.0, 6.0, 7.0, 8.0+ , 9.0, 10.0, 11.0, 12.0 ]++-}+reshape :: Storable t => Int -> Vector t -> Matrix t+reshape 0 v = matrixFromVector RowMajor 0 0 v+reshape c v = matrixFromVector RowMajor (dim v `div` c) c v+++-- | application of a vector function on the flattened matrix elements+liftMatrix :: (Element a, Element b) => (Vector a -> Vector b) -> Matrix a -> Matrix b+liftMatrix f m@Matrix { irows = r, icols = c, xdat = d}+ | isSlice m = matrixFromVector RowMajor r c (f (flatten m))+ | otherwise = matrixFromVector (orderOf m) r c (f d)++-- | application of a vector function on the flattened matrices elements+liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t+liftMatrix2 f m1@(size->(r,c)) m2+ | (r,c)/=size m2 = error "nonconformant matrices in liftMatrix2"+ | rowOrder m1 = matrixFromVector RowMajor r c (f (flatten m1) (flatten m2))+ | otherwise = matrixFromVector ColumnMajor r c (f (flatten (trans m1)) (flatten (trans m2)))++------------------------------------------------------------------++-- | Supported matrix elements.+class (Storable a) => Element a where+ constantD :: a -> Int -> Vector a+ extractR :: MatrixOrder -> Matrix a -> CInt -> Vector CInt -> CInt -> Vector CInt -> IO (Matrix a)+ setRect :: Int -> Int -> Matrix a -> Matrix a -> IO ()+ sortI :: Ord a => Vector a -> Vector CInt+ sortV :: Ord a => Vector a -> Vector a+ compareV :: Ord a => Vector a -> Vector a -> Vector CInt+ selectV :: Vector CInt -> Vector a -> Vector a -> Vector a -> Vector a+ remapM :: Matrix CInt -> Matrix CInt -> Matrix a -> Matrix a+ rowOp :: Int -> a -> Int -> Int -> Int -> Int -> Matrix a -> IO ()+ gemm :: Vector a -> Matrix a -> Matrix a -> Matrix a -> IO ()+ reorderV :: Vector CInt-> Vector CInt-> Vector a -> Vector a -- see reorderVector for documentation+++instance Element Float where+ constantD = constantAux cconstantF+ extractR = extractAux c_extractF+ setRect = setRectAux c_setRectF+ sortI = sortIdxF+ sortV = sortValF+ compareV = compareF+ selectV = selectF+ remapM = remapF+ rowOp = rowOpAux c_rowOpF+ gemm = gemmg c_gemmF+ reorderV = reorderAux c_reorderF++instance Element Double where+ constantD = constantAux cconstantR+ extractR = extractAux c_extractD+ setRect = setRectAux c_setRectD+ sortI = sortIdxD+ sortV = sortValD+ compareV = compareD+ selectV = selectD+ remapM = remapD+ rowOp = rowOpAux c_rowOpD+ gemm = gemmg c_gemmD+ reorderV = reorderAux c_reorderD++instance Element (Complex Float) where+ constantD = constantAux cconstantQ+ extractR = extractAux c_extractQ+ setRect = setRectAux c_setRectQ+ sortI = undefined+ sortV = undefined+ compareV = undefined+ selectV = selectQ+ remapM = remapQ+ rowOp = rowOpAux c_rowOpQ+ gemm = gemmg c_gemmQ+ reorderV = reorderAux c_reorderQ++instance Element (Complex Double) where+ constantD = constantAux cconstantC+ extractR = extractAux c_extractC+ setRect = setRectAux c_setRectC+ sortI = undefined+ sortV = undefined+ compareV = undefined+ selectV = selectC+ remapM = remapC+ rowOp = rowOpAux c_rowOpC+ gemm = gemmg c_gemmC+ reorderV = reorderAux c_reorderC++instance Element (CInt) where+ constantD = constantAux cconstantI+ extractR = extractAux c_extractI+ setRect = setRectAux c_setRectI+ sortI = sortIdxI+ sortV = sortValI+ compareV = compareI+ selectV = selectI+ remapM = remapI+ rowOp = rowOpAux c_rowOpI+ gemm = gemmg c_gemmI+ reorderV = reorderAux c_reorderI++instance Element Z where+ constantD = constantAux cconstantL+ extractR = extractAux c_extractL+ setRect = setRectAux c_setRectL+ sortI = sortIdxL+ sortV = sortValL+ compareV = compareL+ selectV = selectL+ remapM = remapL+ rowOp = rowOpAux c_rowOpL+ gemm = gemmg c_gemmL+ reorderV = reorderAux c_reorderL++-------------------------------------------------------------------++-- | reference to a rectangular slice of a matrix (no data copy)+subMatrix :: Element a+ => (Int,Int) -- ^ (r0,c0) starting position+ -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix+ -> Matrix a -- ^ input matrix+ -> Matrix a -- ^ result+subMatrix (r0,c0) (rt,ct) m+ | rt <= 0 || ct <= 0 = matrixFromVector RowMajor (max 0 rt) (max 0 ct) (fromList [])+ | 0 <= r0 && 0 <= rt && r0+rt <= rows m &&+ 0 <= c0 && 0 <= ct && c0+ct <= cols m = res+ | otherwise = error $ "wrong subMatrix "++show ((r0,c0),(rt,ct))++" of "++shSize m+ where+ p = r0 * xRow m + c0 * xCol m+ tot | rowOrder m = ct + (rt-1) * xRow m+ | otherwise = rt + (ct-1) * xCol m+ res = m { irows = rt, icols = ct, xdat = subVector p tot (xdat m) }++--------------------------------------------------------------------------++maxZ :: (Num t1, Ord t1, Foldable t) => t t1 -> t1+maxZ xs = if minimum xs == 0 then 0 else maximum xs++conformMs :: Element t => [Matrix t] -> [Matrix t]+conformMs ms = map (conformMTo (r,c)) ms+ where+ r = maxZ (map rows ms)+ c = maxZ (map cols ms)++conformVs :: Element t => [Vector t] -> [Vector t]+conformVs vs = map (conformVTo n) vs+ where+ n = maxZ (map dim vs)++conformMTo :: Element t => (Int, Int) -> Matrix t -> Matrix t+conformMTo (r,c) m+ | size m == (r,c) = m+ | size m == (1,1) = matrixFromVector RowMajor r c (constantD (m@@>(0,0)) (r*c))+ | size m == (r,1) = repCols c m+ | size m == (1,c) = repRows r m+ | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to " ++ shDim (r,c)++conformVTo :: Element t => Int -> Vector t -> Vector t+conformVTo n v+ | dim v == n = v+ | dim v == 1 = constantD (v@>0) n+ | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n++repRows :: Element t => Int -> Matrix t -> Matrix t+repRows n x = fromRows (replicate n (flatten x))+repCols :: Element t => Int -> Matrix t -> Matrix t+repCols n x = fromColumns (replicate n (flatten x))++shSize :: Matrix t -> [Char]+shSize = shDim . size++shDim :: (Show a, Show a1) => (a1, a) -> [Char]+shDim (r,c) = "(" ++ show r ++"x"++ show c ++")"++emptyM :: Storable t => Int -> Int -> Matrix t+emptyM r c = matrixFromVector RowMajor r c (fromList[])++----------------------------------------------------------------------++instance (Storable t, NFData t) => NFData (Matrix t)+ where+ rnf m | d > 0 = rnf (v @> 0)+ | otherwise = ()+ where+ d = dim v+ v = xdat m++---------------------------------------------------------------++extractAux :: (Eq t3, Eq t2, TransArray c, Storable a, Storable t1,+ Storable t, Num t3, Num t2, Integral t1, Integral t)+ => (t3 -> t2 -> CInt -> Ptr t1 -> CInt -> Ptr t+ -> Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt))+ -> MatrixOrder -> c -> t3 -> Vector t1 -> t2 -> Vector t -> IO (Matrix a)+extractAux f ord m moder vr modec vc = do+ let nr = if moder == 0 then fromIntegral $ vr@>1 - vr@>0 + 1 else dim vr+ nc = if modec == 0 then fromIntegral $ vc@>1 - vc@>0 + 1 else dim vc+ r <- createMatrix ord nr nc+ (vr # vc # m #! r) (f moder modec) #|"extract"++ return r++type Extr x = CInt -> CInt -> CIdxs (CIdxs (OM x (OM x (IO CInt))))++foreign import ccall unsafe "extractD" c_extractD :: Extr Double+foreign import ccall unsafe "extractF" c_extractF :: Extr Float+foreign import ccall unsafe "extractC" c_extractC :: Extr (Complex Double)+foreign import ccall unsafe "extractQ" c_extractQ :: Extr (Complex Float)+foreign import ccall unsafe "extractI" c_extractI :: Extr CInt+foreign import ccall unsafe "extractL" c_extractL :: Extr Z++---------------------------------------------------------------++setRectAux :: (TransArray c1, TransArray c)+ => (CInt -> CInt -> Trans c1 (Trans c (IO CInt)))+ -> Int -> Int -> c1 -> c -> IO ()+setRectAux f i j m r = (m #! r) (f (fi i) (fi j)) #|"setRect"++type SetRect x = I -> I -> x ::> x::> Ok++foreign import ccall unsafe "setRectD" c_setRectD :: SetRect Double+foreign import ccall unsafe "setRectF" c_setRectF :: SetRect Float+foreign import ccall unsafe "setRectC" c_setRectC :: SetRect (Complex Double)+foreign import ccall unsafe "setRectQ" c_setRectQ :: SetRect (Complex Float)+foreign import ccall unsafe "setRectI" c_setRectI :: SetRect I+foreign import ccall unsafe "setRectL" c_setRectL :: SetRect Z++--------------------------------------------------------------------------------++sortG :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+sortG f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"sortG"+ return r++sortIdxD :: Vector Double -> Vector CInt+sortIdxD = sortG c_sort_indexD+sortIdxF :: Vector Float -> Vector CInt+sortIdxF = sortG c_sort_indexF+sortIdxI :: Vector CInt -> Vector CInt+sortIdxI = sortG c_sort_indexI+sortIdxL :: Vector Z -> Vector I+sortIdxL = sortG c_sort_indexL++sortValD :: Vector Double -> Vector Double+sortValD = sortG c_sort_valD+sortValF :: Vector Float -> Vector Float+sortValF = sortG c_sort_valF+sortValI :: Vector CInt -> Vector CInt+sortValI = sortG c_sort_valI+sortValL :: Vector Z -> Vector Z+sortValL = sortG c_sort_valL++foreign import ccall unsafe "sort_indexD" c_sort_indexD :: CV Double (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexF" c_sort_indexF :: CV Float (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexI" c_sort_indexI :: CV CInt (CV CInt (IO CInt))+foreign import ccall unsafe "sort_indexL" c_sort_indexL :: Z :> I :> Ok++foreign import ccall unsafe "sort_valuesD" c_sort_valD :: CV Double (CV Double (IO CInt))+foreign import ccall unsafe "sort_valuesF" c_sort_valF :: CV Float (CV Float (IO CInt))+foreign import ccall unsafe "sort_valuesI" c_sort_valI :: CV CInt (CV CInt (IO CInt))+foreign import ccall unsafe "sort_valuesL" c_sort_valL :: Z :> Z :> Ok++--------------------------------------------------------------------------------++compareG :: (TransArray c, Storable t, Storable a)+ => Trans c (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt)+ -> c -> Vector t -> Vector a+compareG f u v = unsafePerformIO $ do+ r <- createVector (dim v)+ (u # v #! r) f #|"compareG"+ return r++compareD :: Vector Double -> Vector Double -> Vector CInt+compareD = compareG c_compareD+compareF :: Vector Float -> Vector Float -> Vector CInt+compareF = compareG c_compareF+compareI :: Vector CInt -> Vector CInt -> Vector CInt+compareI = compareG c_compareI+compareL :: Vector Z -> Vector Z -> Vector CInt+compareL = compareG c_compareL++foreign import ccall unsafe "compareD" c_compareD :: CV Double (CV Double (CV CInt (IO CInt)))+foreign import ccall unsafe "compareF" c_compareF :: CV Float (CV Float (CV CInt (IO CInt)))+foreign import ccall unsafe "compareI" c_compareI :: CV CInt (CV CInt (CV CInt (IO CInt)))+foreign import ccall unsafe "compareL" c_compareL :: Z :> Z :> I :> Ok++--------------------------------------------------------------------------------++selectG :: (TransArray c, TransArray c1, TransArray c2, Storable t, Storable a)+ => Trans c2 (Trans c1 (CInt -> Ptr t -> Trans c (CInt -> Ptr a -> IO CInt)))+ -> c2 -> c1 -> Vector t -> c -> Vector a+selectG f c u v w = unsafePerformIO $ do+ r <- createVector (dim v)+ (c # u # v # w #! r) f #|"selectG"+ return r++selectD :: Vector CInt -> Vector Double -> Vector Double -> Vector Double -> Vector Double+selectD = selectG c_selectD+selectF :: Vector CInt -> Vector Float -> Vector Float -> Vector Float -> Vector Float+selectF = selectG c_selectF+selectI :: Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt+selectI = selectG c_selectI+selectL :: Vector CInt -> Vector Z -> Vector Z -> Vector Z -> Vector Z+selectL = selectG c_selectL+selectC :: Vector CInt+ -> Vector (Complex Double)+ -> Vector (Complex Double)+ -> Vector (Complex Double)+ -> Vector (Complex Double)+selectC = selectG c_selectC+selectQ :: Vector CInt+ -> Vector (Complex Float)+ -> Vector (Complex Float)+ -> Vector (Complex Float)+ -> Vector (Complex Float)+selectQ = selectG c_selectQ++type Sel x = CV CInt (CV x (CV x (CV x (CV x (IO CInt)))))++foreign import ccall unsafe "chooseD" c_selectD :: Sel Double+foreign import ccall unsafe "chooseF" c_selectF :: Sel Float+foreign import ccall unsafe "chooseI" c_selectI :: Sel CInt+foreign import ccall unsafe "chooseC" c_selectC :: Sel (Complex Double)+foreign import ccall unsafe "chooseQ" c_selectQ :: Sel (Complex Float)+foreign import ccall unsafe "chooseL" c_selectL :: Sel Z++---------------------------------------------------------------------------++remapG :: (TransArray c, TransArray c1, Storable t, Storable a)+ => (CInt -> CInt -> CInt -> CInt -> Ptr t+ -> Trans c1 (Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt)))+ -> Matrix t -> c1 -> c -> Matrix a+remapG f i j m = unsafePerformIO $ do+ r <- createMatrix RowMajor (rows i) (cols i)+ (i # j # m #! r) f #|"remapG"+ return r++remapD :: Matrix CInt -> Matrix CInt -> Matrix Double -> Matrix Double+remapD = remapG c_remapD+remapF :: Matrix CInt -> Matrix CInt -> Matrix Float -> Matrix Float+remapF = remapG c_remapF+remapI :: Matrix CInt -> Matrix CInt -> Matrix CInt -> Matrix CInt+remapI = remapG c_remapI+remapL :: Matrix CInt -> Matrix CInt -> Matrix Z -> Matrix Z+remapL = remapG c_remapL+remapC :: Matrix CInt+ -> Matrix CInt+ -> Matrix (Complex Double)+ -> Matrix (Complex Double)+remapC = remapG c_remapC+remapQ :: Matrix CInt -> Matrix CInt -> Matrix (Complex Float) -> Matrix (Complex Float)+remapQ = remapG c_remapQ++type Rem x = OM CInt (OM CInt (OM x (OM x (IO CInt))))++foreign import ccall unsafe "remapD" c_remapD :: Rem Double+foreign import ccall unsafe "remapF" c_remapF :: Rem Float+foreign import ccall unsafe "remapI" c_remapI :: Rem CInt+foreign import ccall unsafe "remapC" c_remapC :: Rem (Complex Double)+foreign import ccall unsafe "remapQ" c_remapQ :: Rem (Complex Float)+foreign import ccall unsafe "remapL" c_remapL :: Rem Z++--------------------------------------------------------------------------------++rowOpAux :: (TransArray c, Storable a) =>+ (CInt -> Ptr a -> CInt -> CInt -> CInt -> CInt -> Trans c (IO CInt))+ -> Int -> a -> Int -> Int -> Int -> Int -> c -> IO ()+rowOpAux f c x i1 i2 j1 j2 m = do+ px <- newArray [x]+ (m # id) (f (fi c) px (fi i1) (fi i2) (fi j1) (fi j2)) #|"rowOp"+ free px++type RowOp x = CInt -> Ptr x -> CInt -> CInt -> CInt -> CInt -> x ::> Ok++foreign import ccall unsafe "rowop_double" c_rowOpD :: RowOp R+foreign import ccall unsafe "rowop_float" c_rowOpF :: RowOp Float+foreign import ccall unsafe "rowop_TCD" c_rowOpC :: RowOp C+foreign import ccall unsafe "rowop_TCF" c_rowOpQ :: RowOp (Complex Float)+foreign import ccall unsafe "rowop_int32_t" c_rowOpI :: RowOp I+foreign import ccall unsafe "rowop_int64_t" c_rowOpL :: RowOp Z+foreign import ccall unsafe "rowop_mod_int32_t" c_rowOpMI :: I -> RowOp I+foreign import ccall unsafe "rowop_mod_int64_t" c_rowOpML :: Z -> RowOp Z++--------------------------------------------------------------------------------++gemmg :: (TransArray c1, TransArray c, TransArray c2, TransArray c3)+ => Trans c3 (Trans c2 (Trans c1 (Trans c (IO CInt))))+ -> c3 -> c2 -> c1 -> c -> IO ()+gemmg f v m1 m2 m3 = (v # m1 # m2 #! m3) f #|"gemmg"++type Tgemm x = x :> x ::> x ::> x ::> Ok++foreign import ccall unsafe "gemm_double" c_gemmD :: Tgemm R+foreign import ccall unsafe "gemm_float" c_gemmF :: Tgemm Float+foreign import ccall unsafe "gemm_TCD" c_gemmC :: Tgemm C+foreign import ccall unsafe "gemm_TCF" c_gemmQ :: Tgemm (Complex Float)+foreign import ccall unsafe "gemm_int32_t" c_gemmI :: Tgemm I+foreign import ccall unsafe "gemm_int64_t" c_gemmL :: Tgemm Z+foreign import ccall unsafe "gemm_mod_int32_t" c_gemmMI :: I -> Tgemm I+foreign import ccall unsafe "gemm_mod_int64_t" c_gemmML :: Z -> Tgemm Z++--------------------------------------------------------------------------------++reorderAux :: (TransArray c, Storable t, Storable a1, Storable t1, Storable a) =>+ (CInt -> Ptr a -> CInt -> Ptr t1+ -> Trans c (CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt))+ -> Vector t1 -> c -> Vector t -> Vector a1+reorderAux f s d v = unsafePerformIO $ do+ k <- createVector (dim s)+ r <- createVector (dim v)+ (k # s # d # v #! r) f #| "reorderV"+ return r++type Reorder x = CV CInt (CV CInt (CV CInt (CV x (CV x (IO CInt)))))++foreign import ccall unsafe "reorderD" c_reorderD :: Reorder Double+foreign import ccall unsafe "reorderF" c_reorderF :: Reorder Float+foreign import ccall unsafe "reorderI" c_reorderI :: Reorder CInt+foreign import ccall unsafe "reorderC" c_reorderC :: Reorder (Complex Double)+foreign import ccall unsafe "reorderQ" c_reorderQ :: Reorder (Complex Float)+foreign import ccall unsafe "reorderL" c_reorderL :: Reorder Z++-- | Transpose an array with dimensions @dims@ by making a copy using @strides@. For example, for an array with 3 indices,+-- @(reorderVector strides dims v) ! ((i * dims ! 1 + j) * dims ! 2 + k) == v ! (i * strides ! 0 + j * strides ! 1 + k * strides ! 2)@+-- This function is intended to be used internally by tensor libraries.+reorderVector :: Element a+ => Vector CInt -- ^ @strides@: array strides+ -> Vector CInt -- ^ @dims@: array dimensions of new array @v@+ -> Vector a -- ^ @v@: flattened input array+ -> Vector a -- ^ @v'@: flattened output array+reorderVector = reorderV++--------------------------------------------------------------------------------++foreign import ccall unsafe "saveMatrix" c_saveMatrix+ :: CString -> CString -> Double ::> Ok++{- | save a matrix as a 2D ASCII table+-}+saveMatrix+ :: FilePath+ -> String -- ^ \"printf\" format (e.g. \"%.2f\", \"%g\", etc.)+ -> Matrix Double+ -> IO ()+saveMatrix name format m = do+ cname <- newCString name+ cformat <- newCString format+ (m # id) (c_saveMatrix cname cformat) #|"saveMatrix"+ free cname+ free cformat+ return ()++--------------------------------------------------------------------------------
+ src/Internal/Modular.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{- |+Module : Internal.Modular+Copyright : (c) Alberto Ruiz 2015+License : BSD3+Stability : experimental++Proof of concept of statically checked modular arithmetic.++-}++module Internal.Modular(+ Mod, type (./.)+) where++import Internal.Vector+import Internal.Matrix hiding (size)+import Internal.Numeric+import Internal.Element+import Internal.Container+import Internal.Vectorized (prodI,sumI,prodL,sumL)+import Internal.LAPACK (multiplyI, multiplyL)+import Internal.Algorithms(luFact,LU(..))+import Internal.Util(Normed(..),Indexable(..),+ gaussElim, gaussElim_1, gaussElim_2,+ luST, luSolve', luPacked', magnit, invershur)+import Internal.ST(mutable)+#if MIN_VERSION_base(4,11,0)+import GHC.TypeLits hiding (Mod)+#else+import GHC.TypeLits+#endif+import Data.Proxy(Proxy)+import Foreign.ForeignPtr(castForeignPtr)+import Foreign.Storable+import Data.Ratio+import Data.Complex+import Control.DeepSeq ( NFData(..) )+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++++-- | Wrapper with a phantom integer for statically checked modular arithmetic.+newtype Mod (n :: Nat) t = Mod {unMod:: t}+ deriving (Storable)++instance (NFData t) => NFData (Mod n t)+ where+ rnf (Mod x) = rnf x++infixr 5 ./.+type (./.) x n = Mod n x++instance (Integral t, Enum t, KnownNat m) => Enum (Mod m t)+ where+ toEnum = l0 (\m x -> fromIntegral $ x `mod` (fromIntegral m))+ fromEnum = fromIntegral . unMod++instance (Eq t, KnownNat m) => Eq (Mod m t)+ where+ a == b = (unMod a) == (unMod b)++instance (Ord t, KnownNat m) => Ord (Mod m t)+ where+ compare a b = compare (unMod a) (unMod b)++instance (Integral t, Real t, KnownNat m) => Real (Mod m t)+ where+ toRational x = toInteger x % 1++instance (Integral t, KnownNat m) => Integral (Mod m t)+ where+ toInteger = toInteger . unMod+ quotRem a b = (Mod q, Mod r)+ where+ (q,r) = quotRem (unMod a) (unMod b)++-- | this instance is only valid for prime m+instance (Integral t, Show t, Eq t, KnownNat m) => Fractional (Mod m t)+ where+ recip x+ | x*r == 1 = r+ | otherwise = error $ show x ++" does not have a multiplicative inverse mod "++show m'+ where+ r = x^(m'-2 :: Integer)+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++l2 :: forall m a b c. (Num c, KnownNat m) => (c -> a -> b -> c) -> Mod m a -> Mod m b -> Mod m c+l2 f (Mod u) (Mod v) = Mod (f m' u v)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++l1 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> Mod m a -> Mod m b+l1 f (Mod u) = Mod (f m' u)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++l0 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> a -> Mod m b+l0 f u = Mod (f m' u)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+++instance Show t => Show (Mod n t)+ where+ show = show . unMod++instance (Integral t, KnownNat n) => Num (Mod n t)+ where+ (+) = l2 (\m a b -> (a + b) `mod` (fromIntegral m))+ (*) = l2 (\m a b -> (a * b) `mod` (fromIntegral m))+ (-) = l2 (\m a b -> (a - b) `mod` (fromIntegral m))+ abs = l1 (const abs)+ signum = l1 (const signum)+ fromInteger = l0 (\m x -> fromInteger x `mod` (fromIntegral m))+++instance KnownNat m => Element (Mod m I)+ where+ constantD x n = i2f (constantD (unMod x) n)+ extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js+ setRect i j m x = setRect i j (f2iM m) (f2iM x)+ sortI = sortI . f2i+ sortV = i2f . sortV . f2i+ compareV u v = compareV (f2i u) (f2i v)+ selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))+ remapM i j m = i2fM (remap i j (f2iM m))+ rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpMI m') c (unMod a) i1 i2 j1 j2 (f2iM x)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ gemm u a b c = gemmg (c_gemmMI m') (f2i u) (f2iM a) (f2iM b) (f2iM c)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ reorderV strides dims = i2f . reorderAux c_reorderI strides dims . f2i++instance KnownNat m => Element (Mod m Z)+ where+ constantD x n = i2f (constantD (unMod x) n)+ extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js+ setRect i j m x = setRect i j (f2iM m) (f2iM x)+ sortI = sortI . f2i+ sortV = i2f . sortV . f2i+ compareV u v = compareV (f2i u) (f2i v)+ selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g))+ remapM i j m = i2fM (remap i j (f2iM m))+ rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpML m') c (unMod a) i1 i2 j1 j2 (f2iM x)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ gemm u a b c = gemmg (c_gemmML m') (f2i u) (f2iM a) (f2iM b) (f2iM c)+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ reorderV strides dims = i2f . reorderAux c_reorderL strides dims . f2i+++instance KnownNat m => CTrans (Mod m I)+instance KnownNat m => CTrans (Mod m Z)+++instance KnownNat m => Container Vector (Mod m I)+ where+ conj' = id+ size' = dim+ scale' s x = vmod (scale (unMod s) (f2i x))+ addConstant c x = vmod (addConstant (unMod c) (f2i x))+ add' a b = vmod (add' (f2i a) (f2i b))+ sub a b = vmod (sub (f2i a) (f2i b))+ mul a b = vmod (mul (f2i a) (f2i b))+ equal u v = equal (f2i u) (f2i v)+ scalar' x = fromList [x]+ konst' x = i2f . konst (unMod x)+ build' n f = build n (fromIntegral . f)+ cmap' = mapVector+ atIndex' x k = fromIntegral (atIndex (f2i x) k)+ minIndex' = minIndex . f2i+ maxIndex' = maxIndex . f2i+ minElement' = Mod . minElement . f2i+ maxElement' = Mod . maxElement . f2i+ sumElements' = fromIntegral . sumI m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ prodElements' = fromIntegral . prodI m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ step' = i2f . step . f2i+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' a b = ccompare (f2i a) (f2i b)+ cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)+ scaleRecip s x = scale' s (cmap recip x)+ divide x y = mul x (cmap recip y)+ arctan2' = undefined+ cmod' m = vmod . cmod' (unMod m) . f2i+ fromInt' = vmod+ toInt' = f2i+ fromZ' = vmod . fromZ'+ toZ' = toZ' . f2i++instance KnownNat m => Container Vector (Mod m Z)+ where+ conj' = id+ size' = dim+ scale' s x = vmod (scale (unMod s) (f2i x))+ addConstant c x = vmod (addConstant (unMod c) (f2i x))+ add' a b = vmod (add' (f2i a) (f2i b))+ sub a b = vmod (sub (f2i a) (f2i b))+ mul a b = vmod (mul (f2i a) (f2i b))+ equal u v = equal (f2i u) (f2i v)+ scalar' x = fromList [x]+ konst' x = i2f . konst (unMod x)+ build' n f = build n (fromIntegral . f)+ cmap' = mapVector+ atIndex' x k = fromIntegral (atIndex (f2i x) k)+ minIndex' = minIndex . f2i+ maxIndex' = maxIndex . f2i+ minElement' = Mod . minElement . f2i+ maxElement' = Mod . maxElement . f2i+ sumElements' = fromIntegral . sumL m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ prodElements' = fromIntegral . prodL m' . f2i+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)+ step' = i2f . step . f2i+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' a b = ccompare (f2i a) (f2i b)+ cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g)+ scaleRecip s x = scale' s (cmap recip x)+ divide x y = mul x (cmap recip y)+ arctan2' = undefined+ cmod' m = vmod . cmod' (unMod m) . f2i+ fromInt' = vmod . fromInt'+ toInt' = toInt . f2i+ fromZ' = vmod+ toZ' = f2i+++instance (Storable t, Indexable (Vector t) t) => Indexable (Vector (Mod m t)) (Mod m t)+ where+ (!) = (@>)++type instance RealOf (Mod n I) = I+type instance RealOf (Mod n Z) = Z++instance KnownNat m => Product (Mod m I) where+ norm2 = undefined+ absSum = undefined+ norm1 = undefined+ normInf = undefined+ multiply = lift2m (multiplyI m')+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++instance KnownNat m => Product (Mod m Z) where+ norm2 = undefined+ absSum = undefined+ norm1 = undefined+ normInf = undefined+ multiply = lift2m (multiplyL m')+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++instance KnownNat m => Normed (Vector (Mod m I))+ where+ norm_0 = norm_0 . toInt+ norm_1 = norm_1 . toInt+ norm_2 = norm_2 . toInt+ norm_Inf = norm_Inf . toInt++instance KnownNat m => Normed (Vector (Mod m Z))+ where+ norm_0 = norm_0 . toZ+ norm_1 = norm_1 . toZ+ norm_2 = norm_2 . toZ+ norm_Inf = norm_Inf . toZ+++instance KnownNat m => Numeric (Mod m I)+instance KnownNat m => Numeric (Mod m Z)++i2f :: Storable t => Vector t -> Vector (Mod n t)+i2f v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)+ where (fp,i,n) = unsafeToForeignPtr v++f2i :: Storable t => Vector (Mod n t) -> Vector t+f2i v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n)+ where (fp,i,n) = unsafeToForeignPtr v++f2iM :: (Element t, Element (Mod n t)) => Matrix (Mod n t) -> Matrix t+f2iM m = m { xdat = f2i (xdat m) }++i2fM :: (Element t, Element (Mod n t)) => Matrix t -> Matrix (Mod n t)+i2fM m = m { xdat = i2f (xdat m) }++vmod :: forall m t. (KnownNat m, Storable t, Integral t, Numeric t) => Vector t -> Vector (Mod m t)+vmod = i2f . cmod' m'+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m)++lift1 f a = vmod (f (f2i a))+lift2 f a b = vmod (f (f2i a) (f2i b))++lift2m f a b = liftMatrix vmod (f (f2iM a) (f2iM b))++instance KnownNat m => Num (Vector (Mod m I))+ where+ (+) = lift2 (+)+ (*) = lift2 (*)+ (-) = lift2 (-)+ abs = lift1 abs+ signum = lift1 signum+ negate = lift1 negate+ fromInteger x = fromInt (fromInteger x)++instance KnownNat m => Num (Vector (Mod m Z))+ where+ (+) = lift2 (+)+ (*) = lift2 (*)+ (-) = lift2 (-)+ abs = lift1 abs+ signum = lift1 signum+ negate = lift1 negate+ fromInteger x = fromZ (fromInteger x)++--------------------------------------------------------------------------------++instance (KnownNat m) => Testable (Matrix (Mod m I))+ where+ checkT _ = test++test = (ok, info)+ where+ v = fromList [3,-5,75] :: Vector (Mod 11 I)+ m = (3><3) [1..] :: Matrix (Mod 11 I)++ a = (3><3) [1,2 , 3+ ,4,5 , 6+ ,0,10,-3] :: Matrix I++ b = (3><2) [0..] :: Matrix I++ am = fromInt a :: Matrix (Mod 13 I)+ bm = fromInt b :: Matrix (Mod 13 I)+ ad = fromInt a :: Matrix Double+ bd = fromInt b :: Matrix Double++ g = (3><3) (repeat (40000)) :: Matrix I+ gm = fromInt g :: Matrix (Mod 100000 I)++ lg = (3><3) (repeat (3*10^(9::Int))) :: Matrix Z+ lgm = fromZ lg :: Matrix (Mod 10000000000 Z)++ gen n = diagRect 1 (konst 5 n) n n :: Numeric t => Matrix t+ + rgen n = gen n :: Matrix R+ cgen n = complex (rgen n) + fliprl (complex (rgen n)) * scalar (0:+1) :: Matrix C+ sgen n = single (cgen n)+ + checkGen x = norm_Inf $ flatten $ invg x <> x - ident (rows x)+ + invg t = gaussElim t (ident (rows t))++ checkLU okf t = norm_Inf $ flatten (l <> u <> p - t)+ where+ (l,u,p,_) = luFact (LU x' p')+ where+ (x',p') = mutable (luST okf) t++ checkSolve aa = norm_Inf $ flatten (aa <> x - bb)+ where+ bb = flipud aa+ x = luSolve' (luPacked' aa) bb++ tmm = diagRect 1 (fromList [2..6]) 5 5 :: Matrix (Mod 19 I)++ info = do+ print v+ print m+ print (tr m)+ print $ v+v+ print $ m+m+ print $ m <> m+ print $ m #> v++ print $ am <> gaussElim am bm - bm+ print $ ad <> gaussElim ad bd - bd++ print g+ print $ g <> g+ print gm+ print $ gm <> gm++ print lg+ print $ lg <> lg+ print lgm+ print $ lgm <> lgm+ + putStrLn "checkGen"+ print (checkGen (gen 5 :: Matrix R))+ print (checkGen (gen 5 :: Matrix Float))+ print (checkGen (cgen 5 :: Matrix C))+ print (checkGen (sgen 5 :: Matrix (Complex Float)))+ print (invg (gen 5) :: Matrix (Mod 7 I))+ print (invg (gen 5) :: Matrix (Mod 7 Z))+ + print $ mutable (luST (const True)) (gen 5 :: Matrix R)+ print $ mutable (luST (const True)) (gen 5 :: Matrix (Mod 11 Z))++ putStrLn "checkLU"+ print $ checkLU (magnit 0) (gen 5 :: Matrix R)+ print $ checkLU (magnit 0) (gen 5 :: Matrix Float)+ print $ checkLU (magnit 0) (cgen 5 :: Matrix C)+ print $ checkLU (magnit 0) (sgen 5 :: Matrix (Complex Float))+ print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))+ print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))++ putStrLn "checkSolve"+ print $ checkSolve (gen 5 :: Matrix R)+ print $ checkSolve (gen 5 :: Matrix Float)+ print $ checkSolve (cgen 5 :: Matrix C)+ print $ checkSolve (sgen 5 :: Matrix (Complex Float))+ print $ checkSolve (gen 5 :: Matrix (Mod 7 I))+ print $ checkSolve (gen 5 :: Matrix (Mod 7 Z))+ + putStrLn "luSolve'"+ print $ luSolve' (luPacked' tmm) (ident (rows tmm))+ print $ invershur tmm+++ ok = and+ [ toInt (m #> v) == cmod 11 (toInt m #> toInt v )+ , am <> gaussElim_1 am bm == bm+ , am <> gaussElim_2 am bm == bm+ , am <> gaussElim am bm == bm+ , (checkGen (gen 5 :: Matrix R)) < 1E-15+ , (checkGen (gen 5 :: Matrix Float)) < 2E-7+ , (checkGen (cgen 5 :: Matrix C)) < 1E-15+ , (checkGen (sgen 5 :: Matrix (Complex Float))) < 3E-7+ , (checkGen (gen 5 :: Matrix (Mod 7 I))) == 0+ , (checkGen (gen 5 :: Matrix (Mod 7 Z))) == 0+ , (checkLU (magnit 1E-10) (gen 5 :: Matrix R)) < 2E-15+ , (checkLU (magnit 1E-5) (gen 5 :: Matrix Float)) < 1E-6+ , (checkLU (magnit 1E-10) (cgen 5 :: Matrix C)) < 5E-15+ , (checkLU (magnit 1E-5) (sgen 5 :: Matrix (Complex Float))) < 1E-6+ , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))) == 0+ , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))) == 0+ , checkSolve (gen 5 :: Matrix R) < 2E-15+ , checkSolve (gen 5 :: Matrix Float) < 1E-6+ , checkSolve (cgen 5 :: Matrix C) < 4E-15+ , checkSolve (sgen 5 :: Matrix (Complex Float)) < 1E-6+ , checkSolve (gen 5 :: Matrix (Mod 7 I)) == 0+ , checkSolve (gen 5 :: Matrix (Mod 7 Z)) == 0+ , prodElements (konst (9:: Mod 10 I) (12::Int)) == product (replicate 12 (9:: Mod 10 I))+ , gm <> gm == konst 0 (3,3)+ , lgm <> lgm == konst 0 (3,3)+ , invershur tmm == luSolve' (luPacked' tmm) (ident (rows tmm))+ , luSolve' (luPacked' (tr $ ident 5 :: Matrix (I ./. 2))) (ident 5) == ident 5+ ]++
+ src/Internal/Numeric.hs view
@@ -0,0 +1,945 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Packed.Internal.Numeric+-- Copyright : (c) Alberto Ruiz 2010-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-----------------------------------------------------------------------------++module Internal.Numeric where++import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.ST as ST+import Internal.Conversion+import Internal.Vectorized+import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL)+import Data.List.Split(chunksOf)+import qualified Data.Vector.Storable as V++--------------------------------------------------------------------------------++type family IndexOf (c :: * -> *)++type instance IndexOf Vector = Int+type instance IndexOf Matrix = (Int,Int)++type family ArgOf (c :: * -> *) a++type instance ArgOf Vector a = a -> a+type instance ArgOf Matrix a = a -> a -> a++--------------------------------------------------------------------------------++-- | Basic element-by-element functions for numeric containers+class Element e => Container c e+ where+ conj' :: c e -> c e+ size' :: c e -> IndexOf c+ scalar' :: e -> c e+ scale' :: e -> c e -> c e+ addConstant :: e -> c e -> c e+ add' :: c e -> c e -> c e+ sub :: c e -> c e -> c e+ -- | element by element multiplication+ mul :: c e -> c e -> c e+ equal :: c e -> c e -> Bool+ cmap' :: (Element b) => (e -> b) -> c e -> c b+ konst' :: e -> IndexOf c -> c e+ build' :: IndexOf c -> (ArgOf c e) -> c e+ atIndex' :: c e -> IndexOf c -> e+ minIndex' :: c e -> IndexOf c+ maxIndex' :: c e -> IndexOf c+ minElement' :: c e -> e+ maxElement' :: c e -> e+ sumElements' :: c e -> e+ prodElements' :: c e -> e+ step' :: Ord e => c e -> c e+ ccompare' :: Ord e => c e -> c e -> c I+ cselect' :: c I -> c e -> c e -> c e -> c e+ find' :: (e -> Bool) -> c e -> [IndexOf c]+ assoc' :: IndexOf c -- ^ size+ -> e -- ^ default value+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+ accum' :: c e -- ^ initial structure+ -> (e -> e -> e) -- ^ update function+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result++ -- | scale the element by element reciprocal of the object:+ --+ -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@+ scaleRecip :: Fractional e => e -> c e -> c e+ -- | element by element division+ divide :: Fractional e => c e -> c e -> c e+ --+ -- element by element inverse tangent+ arctan2' :: Fractional e => c e -> c e -> c e+ cmod' :: Integral e => e -> c e -> c e+ fromInt' :: c I -> c e+ toInt' :: c e -> c I+ fromZ' :: c Z -> c e+ toZ' :: c e -> c Z++--------------------------------------------------------------------------++instance Container Vector I+ where+ conj' = id+ size' = dim+ scale' = vectorMapValI Scale+ addConstant = vectorMapValI AddConstant+ add' = vectorZipI Add+ sub = vectorZipI Sub+ mul = vectorZipI Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarI MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarI MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarI Min)+ maxElement' = emptyErrorV "maxElement" (toScalarI Max)+ sumElements' = sumI 1+ prodElements' = prodI 1+ step' = stepI+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = undefined -- cannot match+ divide = undefined+ arctan2' = undefined+ cmod' m x+ | m /= 0 = vectorMapValI ModVS m x+ | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x)+ fromInt' = id+ toInt' = id+ fromZ' = long2intV+ toZ' = int2longV+++instance Container Vector Z+ where+ conj' = id+ size' = dim+ scale' = vectorMapValL Scale+ addConstant = vectorMapValL AddConstant+ add' = vectorZipL Add+ sub = vectorZipL Sub+ mul = vectorZipL Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarL MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarL MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarL Min)+ maxElement' = emptyErrorV "maxElement" (toScalarL Max)+ sumElements' = sumL 1+ prodElements' = prodL 1+ step' = stepL+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = undefined -- cannot match+ divide = undefined+ arctan2' = undefined+ cmod' m x+ | m /= 0 = vectorMapValL ModVS m x+ | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x)+ fromInt' = int2longV+ toInt' = long2intV+ fromZ' = id+ toZ' = id++++instance Container Vector Float+ where+ conj' = id+ size' = dim+ scale' = vectorMapValF Scale+ addConstant = vectorMapValF AddConstant+ add' = vectorZipF Add+ sub = vectorZipF Sub+ mul = vectorZipF Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (round . toScalarF MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (round . toScalarF MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarF Min)+ maxElement' = emptyErrorV "maxElement" (toScalarF Max)+ sumElements' = sumF+ prodElements' = prodF+ step' = stepF+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = vectorMapValF Recip+ divide = vectorZipF Div+ arctan2' = vectorZipF ATan2+ cmod' = undefined+ fromInt' = int2floatV+ toInt' = float2IntV+ fromZ' = (single :: Vector R-> Vector Float) . fromZ'+ toZ' = toZ' . double+++instance Container Vector Double+ where+ conj' = id+ size' = dim+ scale' = vectorMapValR Scale+ addConstant = vectorMapValR AddConstant+ add' = vectorZipR Add+ sub = vectorZipR Sub+ mul = vectorZipR Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (round . toScalarR MinIdx)+ maxIndex' = emptyErrorV "maxIndex" (round . toScalarR MaxIdx)+ minElement' = emptyErrorV "minElement" (toScalarR Min)+ maxElement' = emptyErrorV "maxElement" (toScalarR Max)+ sumElements' = sumR+ prodElements' = prodR+ step' = stepD+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = compareCV compareV+ cselect' = selectCV selectV+ scaleRecip = vectorMapValR Recip+ divide = vectorZipR Div+ arctan2' = vectorZipR ATan2+ cmod' = undefined+ fromInt' = int2DoubleV+ toInt' = double2IntV+ fromZ' = long2DoubleV+ toZ' = double2longV+++instance Container Vector (Complex Double)+ where+ conj' = conjugateC+ size' = dim+ scale' = vectorMapValC Scale+ addConstant = vectorMapValC AddConstant+ add' = vectorZipC Add+ sub = vectorZipC Sub+ mul = vectorZipC Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))+ maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))+ minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')+ maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')+ sumElements' = sumC+ prodElements' = prodC+ step' = undefined -- cannot match+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = undefined -- cannot match+ cselect' = selectCV selectV+ scaleRecip = vectorMapValC Recip+ divide = vectorZipC Div+ arctan2' = vectorZipC ATan2+ cmod' = undefined+ fromInt' = complex . int2DoubleV+ toInt' = toInt' . fst . fromComplex+ fromZ' = complex . long2DoubleV+ toZ' = toZ' . fst . fromComplex++instance Container Vector (Complex Float)+ where+ conj' = conjugateQ+ size' = dim+ scale' = vectorMapValQ Scale+ addConstant = vectorMapValQ AddConstant+ add' = vectorZipQ Add+ sub = vectorZipQ Sub+ mul = vectorZipQ Mul+ equal = (==)+ scalar' = V.singleton+ konst' = constantD+ build' = buildV+ cmap' = mapVector+ atIndex' = (@>)+ minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj'))+ maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj'))+ minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex')+ maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex')+ sumElements' = sumQ+ prodElements' = prodQ+ step' = undefined -- cannot match+ find' = findV+ assoc' = assocV+ accum' = accumV+ ccompare' = undefined -- cannot match+ cselect' = selectCV selectV+ scaleRecip = vectorMapValQ Recip+ divide = vectorZipQ Div+ arctan2' = vectorZipQ ATan2+ cmod' = undefined+ fromInt' = complex . int2floatV+ toInt' = toInt' . fst . fromComplex+ fromZ' = complex . single . long2DoubleV+ toZ' = toZ' . double . fst . fromComplex++---------------------------------------------------------------++instance (Num a, Element a, Container Vector a) => Container Matrix a+ where+ conj' = liftMatrix conj'+ size' = size+ scale' x = liftMatrix (scale' x)+ addConstant x = liftMatrix (addConstant x)+ add' = liftMatrix2 add'+ sub = liftMatrix2 sub+ mul = liftMatrix2 mul+ equal a b = cols a == cols b && flatten a `equal` flatten b+ scalar' x = (1><1) [x]+ konst' v (r,c) = matrixFromVector RowMajor r c (konst' v (r*c))+ build' = buildM+ cmap' f = liftMatrix (mapVector f)+ atIndex' = (@@>)+ minIndex' = emptyErrorM "minIndex of Matrix" $+ \m -> divMod (minIndex' $ flatten m) (cols m)+ maxIndex' = emptyErrorM "maxIndex of Matrix" $+ \m -> divMod (maxIndex' $ flatten m) (cols m)+ minElement' = emptyErrorM "minElement of Matrix" (atIndex' <*> minIndex')+ maxElement' = emptyErrorM "maxElement of Matrix" (atIndex' <*> maxIndex')+ sumElements' = sumElements' . flatten+ prodElements' = prodElements' . flatten+ step' = liftMatrix step'+ find' = findM+ assoc' = assocM+ accum' = accumM+ ccompare' = compareM+ cselect' = selectM+ scaleRecip x = liftMatrix (scaleRecip x)+ divide = liftMatrix2 divide+ arctan2' = liftMatrix2 arctan2'+ cmod' m x+ | m /= 0 = liftMatrix (cmod' m) x+ | otherwise = error $ "cmod 0 on matrix "++shSize x+ fromInt' = liftMatrix fromInt'+ toInt' = liftMatrix toInt'+ fromZ' = liftMatrix fromZ'+ toZ' = liftMatrix toZ'+++emptyErrorV msg f v =+ if dim v > 0+ then f v+ else error $ msg ++ " of empty Vector"++emptyErrorM msg f m =+ if rows m > 0 && cols m > 0+ then f m+ else error $ msg++" "++shSize m++--------------------------------------------------------------------------------++-- | create a structure with a single element+--+-- >>> let v = fromList [1..3::Double]+-- >>> v / scalar (norm2 v)+-- fromList [0.2672612419124244,0.5345224838248488,0.8017837257372732]+--+scalar :: Container c e => e -> c e+scalar = scalar'++-- | complex conjugate+conj :: Container c e => c e -> c e+conj = conj'+++arctan2 :: (Fractional e, Container c e) => c e -> c e -> c e+arctan2 = arctan2'++-- | 'mod' for integer arrays+--+-- >>> cmod 3 (range 5)+-- fromList [0,1,2,0,1]+cmod :: (Integral e, Container c e) => e -> c e -> c e+cmod = cmod'++-- |+-- >>>fromInt ((2><2) [0..3]) :: Matrix (Complex Double)+-- (2><2)+-- [ 0.0 :+ 0.0, 1.0 :+ 0.0+-- , 2.0 :+ 0.0, 3.0 :+ 0.0 ]+--+fromInt :: (Container c e) => c I -> c e+fromInt = fromInt'++toInt :: (Container c e) => c e -> c I+toInt = toInt'++fromZ :: (Container c e) => c Z -> c e+fromZ = fromZ'++toZ :: (Container c e) => c e -> c Z+toZ = toZ'++-- | like 'fmap' (cannot implement instance Functor because of Element class constraint)+cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b+cmap = cmap'++-- | generic indexing function+--+-- >>> vector [1,2,3] `atIndex` 1+-- 2.0+--+-- >>> matrix 3 [0..8] `atIndex` (2,0)+-- 6.0+--+atIndex :: Container c e => c e -> IndexOf c -> e+atIndex = atIndex'++-- | index of minimum element+minIndex :: Container c e => c e -> IndexOf c+minIndex = minIndex'++-- | index of maximum element+maxIndex :: Container c e => c e -> IndexOf c+maxIndex = maxIndex'++-- | value of minimum element+minElement :: Container c e => c e -> e+minElement = minElement'++-- | value of maximum element+maxElement :: Container c e => c e -> e+maxElement = maxElement'++-- | the sum of elements+sumElements :: Container c e => c e -> e+sumElements = sumElements'++-- | the product of elements+prodElements :: Container c e => c e -> e+prodElements = prodElements'+++-- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@+--+-- >>> step $ linspace 5 (-1,1::Double)+-- 5 |> [0.0,0.0,0.0,1.0,1.0]+--+step+ :: (Ord e, Container c e)+ => c e+ -> c e+step = step'+++-- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@.+--+-- Arguments with any dimension = 1 are automatically expanded:+--+-- >>> cond ((1><4)[1..]) ((3><1)[1..]) 0 100 ((3><4)[1..]) :: Matrix Double+-- (3><4)+-- [ 100.0, 2.0, 3.0, 4.0+-- , 0.0, 100.0, 7.0, 8.0+-- , 0.0, 0.0, 100.0, 12.0 ]+--+-- >>> let chop x = cond (abs x) 1E-6 0 0 x+--+cond+ :: (Ord e, Container c e, Container c x)+ => c e -- ^ a+ -> c e -- ^ b+ -> c x -- ^ l+ -> c x -- ^ e+ -> c x -- ^ g+ -> c x -- ^ result+cond a b l e g = cselect' (ccompare' a b) l e g+++-- | Find index of elements which satisfy a predicate+--+-- >>> find (>0) (ident 3 :: Matrix Double)+-- [(0,0),(1,1),(2,2)]+--+find+ :: Container c e+ => (e -> Bool)+ -> c e+ -> [IndexOf c]+find = find'+++-- | Create a structure from an association list+--+-- >>> assoc 5 0 [(3,7),(1,4)] :: Vector Double+-- fromList [0.0,4.0,0.0,7.0,0.0]+--+-- >>> assoc (2,3) 0 [((0,2),7),((1,0),2*i-3)] :: Matrix (Complex Double)+-- (2><3)+-- [ 0.0 :+ 0.0, 0.0 :+ 0.0, 7.0 :+ 0.0+-- , (-3.0) :+ 2.0, 0.0 :+ 0.0, 0.0 :+ 0.0 ]+--+assoc+ :: Container c e+ => IndexOf c -- ^ size+ -> e -- ^ default value+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+assoc = assoc'+++-- | Modify a structure using an update function+--+-- >>> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double+-- (5><5)+-- [ 1.0, 0.0, 0.0, 3.0, 0.0+-- , 0.0, 6.0, 0.0, 0.0, 0.0+-- , 0.0, 0.0, 1.0, 0.0, 0.0+-- , 0.0, 0.0, 0.0, 1.0, 0.0+-- , 0.0, 0.0, 0.0, 0.0, 1.0 ]+--+-- computation of histogram:+--+-- >>> accum (konst 0 7) (+) (map (flip (,) 1) [4,5,4,1,5,2,5]) :: Vector Double+-- fromList [0.0,1.0,1.0,0.0,2.0,3.0,0.0]+--+accum+ :: Container c e+ => c e -- ^ initial structure+ -> (e -> e -> e) -- ^ update function+ -> [(IndexOf c, e)] -- ^ association list+ -> c e -- ^ result+accum = accum'++--------------------------------------------------------------------------------++class Konst e d c | d -> c, c -> d+ where+ -- |+ -- >>> konst 7 3 :: Vector Float+ -- fromList [7.0,7.0,7.0]+ --+ -- >>> konst i (3::Int,4::Int)+ -- (3><4)+ -- [ 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0+ -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0+ -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 ]+ --+ konst :: e -> d -> c e++instance Container Vector e => Konst e Int Vector+ where+ konst = konst'++instance (Num e, Container Vector e) => Konst e (Int,Int) Matrix+ where+ konst = konst'++--------------------------------------------------------------------------------++class ( Container Vector t+ , Container Matrix t+ , Konst t Int Vector+ , Konst t (Int,Int) Matrix+ , CTrans t+ , Product t+ , Additive (Vector t)+ , Additive (Matrix t)+ , Linear t Vector+ , Linear t Matrix+ ) => Numeric t++instance Numeric Double+instance Numeric (Complex Double)+instance Numeric Float+instance Numeric (Complex Float)+instance Numeric I+instance Numeric Z++--------------------------------------------------------------------------------++--------------------------------------------------------------------------------++-- | Matrix product and related functions+class (Num e, Element e) => Product e where+ -- | matrix product+ multiply :: Matrix e -> Matrix e -> Matrix e+ -- | sum of absolute value of elements (differs in complex case from @norm1@)+ absSum :: Vector e -> RealOf e+ -- | sum of absolute value of elements+ norm1 :: Vector e -> RealOf e+ -- | euclidean norm+ norm2 :: Floating e => Vector e -> RealOf e+ -- | element of maximum magnitude+ normInf :: Vector e -> RealOf e++instance Product Float where+ norm2 = emptyVal (toScalarF Norm2)+ absSum = emptyVal (toScalarF AbsSum)+ norm1 = emptyVal (toScalarF AbsSum)+ normInf = emptyVal (maxElement . vectorMapF Abs)+ multiply = emptyMul multiplyF++instance Product Double where+ norm2 = emptyVal (toScalarR Norm2)+ absSum = emptyVal (toScalarR AbsSum)+ norm1 = emptyVal (toScalarR AbsSum)+ normInf = emptyVal (maxElement . vectorMapR Abs)+ multiply = emptyMul multiplyR++instance Product (Complex Float) where+ norm2 = emptyVal (toScalarQ Norm2)+ absSum = emptyVal (toScalarQ AbsSum)+ norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapQ Abs)+ normInf = emptyVal (maxElement . fst . fromComplex . vectorMapQ Abs)+ multiply = emptyMul multiplyQ++instance Product (Complex Double) where+ norm2 = emptyVal (toScalarC Norm2)+ absSum = emptyVal (toScalarC AbsSum)+ norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapC Abs)+ normInf = emptyVal (maxElement . fst . fromComplex . vectorMapC Abs)+ multiply = emptyMul multiplyC++instance Product I where+ norm2 = undefined+ absSum = emptyVal (sumElements . vectorMapI Abs)+ norm1 = absSum+ normInf = emptyVal (maxElement . vectorMapI Abs)+ multiply = emptyMul (multiplyI 1)++instance Product Z where+ norm2 = undefined+ absSum = emptyVal (sumElements . vectorMapL Abs)+ norm1 = absSum+ normInf = emptyVal (maxElement . vectorMapL Abs)+ multiply = emptyMul (multiplyL 1)+++emptyMul m a b+ | x1 == 0 && x2 == 0 || r == 0 || c == 0 = konst' 0 (r,c)+ | otherwise = m a b+ where+ r = rows a+ x1 = cols a+ x2 = rows b+ c = cols b++emptyVal f v =+ if dim v > 0+ then f v+ else 0++-- FIXME remove unused C wrappers+-- | unconjugated dot product+udot :: Product e => Vector e -> Vector e -> e+udot u v+ | dim u == dim v = val (asRow u `multiply` asColumn v)+ | otherwise = error $ "different dimensions "++show (dim u)++" and "++show (dim v)++" in dot product"+ where+ val m | dim u > 0 = m@@>(0,0)+ | otherwise = 0++----------------------------------------------------------++-- synonym for matrix product+mXm :: Product t => Matrix t -> Matrix t -> Matrix t+mXm = multiply++-- matrix - vector product+mXv :: Product t => Matrix t -> Vector t -> Vector t+mXv m v = flatten $ m `mXm` (asColumn v)++-- vector - matrix product+vXm :: Product t => Vector t -> Matrix t -> Vector t+vXm v m = flatten $ (asRow v) `mXm` m++{- | Outer product of two vectors.++>>> fromList [1,2,3] `outer` fromList [5,2,3]+(3><3)+ [ 5.0, 2.0, 3.0+ , 10.0, 4.0, 6.0+ , 15.0, 6.0, 9.0 ]++-}+outer :: (Product t) => Vector t -> Vector t -> Matrix t+outer u v = asColumn u `multiply` asRow v++{- | Kronecker product of two matrices.++@m1=(2><3)+ [ 1.0, 2.0, 0.0+ , 0.0, -1.0, 3.0 ]+m2=(4><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0+ , 10.0, 11.0, 12.0 ]@++>>> kronecker m1 m2+(8><9)+ [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0+ , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0+ , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0+ , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0+ , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0+ , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0+ , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0+ , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ]++-}+kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t+kronecker a b = fromBlocks+ . chunksOf (cols a)+ . map (reshape (cols b))+ . toRows+ $ flatten a `outer` flatten b++-------------------------------------------------------------------+++class Convert t where+ real :: Complexable c => c (RealOf t) -> c t+ complex :: Complexable c => c t -> c (ComplexOf t)+ single :: Complexable c => c t -> c (SingleOf t)+ double :: Complexable c => c t -> c (DoubleOf t)+ toComplex :: (Complexable c, RealElement t) => (c t, c t) -> c (Complex t)+ fromComplex :: (Complexable c, RealElement t) => c (Complex t) -> (c t, c t)+++instance Convert Double where+ real = id+ complex = comp'+ single = single'+ double = id+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert Float where+ real = id+ complex = comp'+ single = id+ double = double'+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert (Complex Double) where+ real = comp'+ complex = id+ single = single'+ double = id+ toComplex = toComplex'+ fromComplex = fromComplex'++instance Convert (Complex Float) where+ real = comp'+ complex = id+ single = id+ double = double'+ toComplex = toComplex'+ fromComplex = fromComplex'++-------------------------------------------------------------------++type family RealOf x++type instance RealOf Double = Double+type instance RealOf (Complex Double) = Double++type instance RealOf Float = Float+type instance RealOf (Complex Float) = Float++type instance RealOf I = I+type instance RealOf Z = Z++type ComplexOf x = Complex (RealOf x)++type family SingleOf x++type instance SingleOf Double = Float+type instance SingleOf Float = Float++type instance SingleOf (Complex a) = Complex (SingleOf a)++type family DoubleOf x++type instance DoubleOf Double = Double+type instance DoubleOf Float = Double++type instance DoubleOf (Complex a) = Complex (DoubleOf a)++type family ElementOf c++type instance ElementOf (Vector a) = a+type instance ElementOf (Matrix a) = a++------------------------------------------------------------++buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ]+ where rs = map fromIntegral [0 .. (rc-1)]+ cs = map fromIntegral [0 .. (cc-1)]++buildV n f = fromList [f k | k <- ks]+ where ks = map fromIntegral [0 .. (n-1)]++--------------------------------------------------------++-- | Creates a square matrix with a given diagonal.+diag :: (Num a, Element a) => Vector a -> Matrix a+diag v = diagRect 0 v n n where n = dim v++-- | creates the identity matrix of given dimension+ident :: (Num a, Element a) => Int -> Matrix a+ident n = diag (constantD 1 n)++--------------------------------------------------------++findV p x = foldVectorWithIndex g [] x where+ g k z l = if p z then k:l else l++findM p x = map ((`divMod` cols x)) $ findV p (flatten x)++assocV n z xs = ST.runSTVector $ do+ v <- ST.newVector z n+ mapM_ (\(k,x) -> ST.writeVector v k x) xs+ return v++assocM (r,c) z xs = ST.runSTMatrix $ do+ m <- ST.newMatrix z r c+ mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs+ return m++accumV v0 f xs = ST.runSTVector $ do+ v <- ST.thawVector v0+ mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs+ return v++accumM m0 f xs = ST.runSTMatrix $ do+ m <- ST.thawMatrix m0+ mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs+ return m++----------------------------------------------------------------------++compareM a b = matrixFromVector RowMajor (rows a'') (cols a'') $ ccompare' a' b'+ where+ args@(a'':_) = conformMs [a,b]+ [a', b'] = map flatten args++compareCV f a b = f a' b'+ where+ [a', b'] = conformVs [a,b]++selectM c l e t = matrixFromVector RowMajor (rows a'') (cols a'') $ cselect' (toInt c') l' e' t'+ where+ args@(a'':_) = conformMs [fromInt c,l,e,t]+ [c', l', e', t'] = map flatten args++selectCV f c l e t = f (toInt c') l' e' t'+ where+ [c', l', e', t'] = conformVs [fromInt c,l,e,t]++--------------------------------------------------------------------------------++class CTrans t+ where+ ctrans :: Matrix t -> Matrix t+ ctrans = trans++instance CTrans Float+instance CTrans R+instance CTrans I+instance CTrans Z++instance CTrans C+ where+ ctrans = conj . trans++instance CTrans (Complex Float)+ where+ ctrans = conj . trans++class Transposable m mt | m -> mt, mt -> m+ where+ -- | conjugate transpose+ tr :: m -> mt+ -- | transpose+ tr' :: m -> mt++instance (CTrans t, Container Vector t) => Transposable (Matrix t) (Matrix t)+ where+ tr = ctrans+ tr' = trans++class Additive c+ where+ add :: c -> c -> c++class Linear t c+ where+ scale :: t -> c t -> c t+++instance Container Vector t => Linear t Vector+ where+ scale = scale'++instance Container Matrix t => Linear t Matrix+ where+ scale = scale'++instance Container Vector t => Additive (Vector t)+ where+ add = add'++instance Container Matrix t => Additive (Matrix t)+ where+ add = add'+++class Testable t+ where+ checkT :: t -> (Bool, IO())+ ioCheckT :: t -> IO (Bool, IO())+ ioCheckT = return . checkT++--------------------------------------------------------------------------------+
+ src/Internal/Random.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module : Numeric.LinearAlgebra.Random+-- Copyright : (c) Alberto Ruiz 2009-14+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Random vectors and matrices.+--+-----------------------------------------------------------------------------++module Internal.Random (+ Seed,+ RandDist(..),+ randomVector,+ gaussianSample,+ uniformSample,+ rand, randn+) where++import Internal.Vectorized+import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import Internal.Algorithms+import System.Random(randomIO)++-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate+-- Gaussian distribution.+gaussianSample :: Seed+ -> Int -- ^ number of rows+ -> Vector Double -- ^ mean vector+ -> Herm Double -- ^ covariance matrix+ -> Matrix Double -- ^ result+gaussianSample seed n med cov = m where+ c = dim med+ meds = konst' 1 n `outer` med+ rs = reshape c $ randomVector seed Gaussian (c * n)+ m = rs `mXm` chol cov `add` meds++-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate+-- uniform distribution.+uniformSample :: Seed+ -> Int -- ^ number of rows+ -> [(Double,Double)] -- ^ ranges for each column+ -> Matrix Double -- ^ result+uniformSample seed n rgs = m where+ (as,bs) = unzip rgs+ a = fromList as+ cs = zipWith subtract as bs+ d = dim a+ dat = toRows $ reshape n $ randomVector seed Uniform (n*d)+ am = konst' 1 n `outer` a+ m = fromColumns (zipWith scale cs dat) `add` am++-- | pseudorandom matrix with uniform elements between 0 and 1+randm :: RandDist+ -> Int -- ^ rows+ -> Int -- ^ columns+ -> IO (Matrix Double)+randm d r c = do+ seed <- randomIO+ return (reshape c $ randomVector seed d (r*c))++-- | pseudorandom matrix with uniform elements between 0 and 1+rand :: Int -> Int -> IO (Matrix Double)+rand = randm Uniform++{- | pseudorandom matrix with normal elements++>>> disp 3 =<< randn 3 5+3x5+0.386 -1.141 0.491 -0.510 1.512+0.069 -0.919 1.022 -0.181 0.745+0.313 -0.670 -0.097 -1.575 -0.583++-}+randn :: Int -> Int -> IO (Matrix Double)+randn = randm Gaussian+
+ src/Internal/ST.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Internal.ST+-- Copyright : (c) Alberto Ruiz 2008+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- In-place manipulation inside the ST monad.+-- See @examples/inplace.hs@ in the repository.+--+-----------------------------------------------------------------------------++module Internal.ST (+ ST, runST,+ -- * Mutable Vectors+ STVector, newVector, thawVector, freezeVector, runSTVector,+ readVector, writeVector, modifyVector, liftSTVector,+ -- * Mutable Matrices+ STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix,+ readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,+ mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..),+ -- * Unsafe functions+ newUndefinedVector,+ unsafeReadVector, unsafeWriteVector,+ unsafeThawVector, unsafeFreezeVector,+ newUndefinedMatrix,+ unsafeReadMatrix, unsafeWriteMatrix,+ unsafeThawMatrix, unsafeFreezeMatrix+) where++import Internal.Vector+import Internal.Matrix+import Internal.Vectorized+import Control.Monad.ST(ST, runST)+import Foreign.Storable(Storable, peekElemOff, pokeElemOff)+import Control.Monad.ST.Unsafe(unsafeIOToST)++{-# INLINE ioReadV #-}+ioReadV :: Storable t => Vector t -> Int -> IO t+ioReadV v k = unsafeWith v $ \s -> peekElemOff s k++{-# INLINE ioWriteV #-}+ioWriteV :: Storable t => Vector t -> Int -> t -> IO ()+ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x++newtype STVector s t = STVector (Vector t)++thawVector :: Storable t => Vector t -> ST s (STVector s t)+thawVector = unsafeIOToST . fmap STVector . cloneVector++unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t)+unsafeThawVector = unsafeIOToST . return . STVector++runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t+runSTVector st = runST (st >>= unsafeFreezeVector)++{-# INLINE unsafeReadVector #-}+unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t+unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x++{-# INLINE unsafeWriteVector #-}+unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s ()+unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k++{-# INLINE modifyVector #-}+modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s ()+modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k++liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s t -> ST s a+liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x++freezeVector :: (Storable t) => STVector s t -> ST s (Vector t)+freezeVector v = liftSTVector id v++unsafeFreezeVector :: (Storable t) => STVector s t -> ST s (Vector t)+unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x++{-# INLINE safeIndexV #-}+safeIndexV :: Storable t2+ => (STVector s t2 -> Int -> t) -> STVector t1 t2 -> Int -> t+safeIndexV f (STVector v) k+ | k < 0 || k>= dim v = error $ "out of range error in vector (dim="+ ++show (dim v)++", pos="++show k++")"+ | otherwise = f (STVector v) k++{-# INLINE readVector #-}+readVector :: Storable t => STVector s t -> Int -> ST s t+readVector = safeIndexV unsafeReadVector++{-# INLINE writeVector #-}+writeVector :: Storable t => STVector s t -> Int -> t -> ST s ()+writeVector = safeIndexV unsafeWriteVector++newUndefinedVector :: Storable t => Int -> ST s (STVector s t)+newUndefinedVector = unsafeIOToST . fmap STVector . createVector++{-# INLINE newVector #-}+newVector :: Storable t => t -> Int -> ST s (STVector s t)+newVector x n = do+ v <- newUndefinedVector n+ let go (-1) = return v+ go !k = unsafeWriteVector v k x >> go (k-1 :: Int)+ go (n-1)++-------------------------------------------------------------------------++{-# INLINE ioReadM #-}+ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t+ioReadM m r c = ioReadV (xdat m) (r * xRow m + c * xCol m)+++{-# INLINE ioWriteM #-}+ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO ()+ioWriteM m r c val = ioWriteV (xdat m) (r * xRow m + c * xCol m) val+++newtype STMatrix s t = STMatrix (Matrix t)++thawMatrix :: Element t => Matrix t -> ST s (STMatrix s t)+thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix++unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t)+unsafeThawMatrix = unsafeIOToST . return . STMatrix++runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t+runSTMatrix st = runST (st >>= unsafeFreezeMatrix)++{-# INLINE unsafeReadMatrix #-}+unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t+unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r++{-# INLINE unsafeWriteMatrix #-}+unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()+unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c++{-# INLINE modifyMatrix #-}+modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s ()+modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c++liftSTMatrix :: (Element t) => (Matrix t -> a) -> STMatrix s t -> ST s a+liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x++unsafeFreezeMatrix :: (Storable t) => STMatrix s t -> ST s (Matrix t)+unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x+++freezeMatrix :: (Element t) => STMatrix s t -> ST s (Matrix t)+freezeMatrix m = liftSTMatrix id m++cloneMatrix :: Element t => Matrix t -> IO (Matrix t)+cloneMatrix m = copy (orderOf m) m++{-# INLINE safeIndexM #-}+safeIndexM :: (STMatrix s t2 -> Int -> Int -> t)+ -> STMatrix t1 t2 -> Int -> Int -> t+safeIndexM f (STMatrix m) r c+ | r<0 || r>=rows m ||+ c<0 || c>=cols m = error $ "out of range error in matrix (size="+ ++show (rows m,cols m)++", pos="++show (r,c)++")"+ | otherwise = f (STMatrix m) r c++{-# INLINE readMatrix #-}+readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t+readMatrix = safeIndexM unsafeReadMatrix++{-# INLINE writeMatrix #-}+writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s ()+writeMatrix = safeIndexM unsafeWriteMatrix++setMatrix :: Element t => STMatrix s t -> Int -> Int -> Matrix t -> ST s ()+setMatrix (STMatrix x) i j m = unsafeIOToST $ setRect i j m x++newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t)+newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c++{-# NOINLINE newMatrix #-}+newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t)+newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c)++--------------------------------------------------------------------------------++data ColRange = AllCols+ | ColRange Int Int+ | Col Int+ | FromCol Int++getColRange :: Int -> ColRange -> (Int, Int)+getColRange c AllCols = (0,c-1)+getColRange c (ColRange a b) = (a `mod` c, b `mod` c)+getColRange c (Col a) = (a `mod` c, a `mod` c)+getColRange c (FromCol a) = (a `mod` c, c-1)++data RowRange = AllRows+ | RowRange Int Int+ | Row Int+ | FromRow Int++getRowRange :: Int -> RowRange -> (Int, Int)+getRowRange r AllRows = (0,r-1)+getRowRange r (RowRange a b) = (a `mod` r, b `mod` r)+getRowRange r (Row a) = (a `mod` r, a `mod` r)+getRowRange r (FromRow a) = (a `mod` r, r-1)++data RowOper t = AXPY t Int Int ColRange+ | SCAL t RowRange ColRange+ | SWAP Int Int ColRange++rowOper :: (Num t, Element t) => RowOper t -> STMatrix s t -> ST s ()++rowOper (AXPY x i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 0 x i1' i2' j1 j2 m+ where+ (j1,j2) = getColRange (cols m) r+ i1' = i1 `mod` (rows m)+ i2' = i2 `mod` (rows m)++rowOper (SCAL x rr rc) (STMatrix m) = unsafeIOToST $ rowOp 1 x i1 i2 j1 j2 m+ where+ (i1,i2) = getRowRange (rows m) rr+ (j1,j2) = getColRange (cols m) rc++rowOper (SWAP i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 2 0 i1' i2' j1 j2 m+ where+ (j1,j2) = getColRange (cols m) r+ i1' = i1 `mod` (rows m)+ i2' = i2 `mod` (rows m)+++extractMatrix :: Element a => STMatrix t a -> RowRange -> ColRange -> ST s (Matrix a)+extractMatrix (STMatrix m) rr rc = unsafeIOToST (extractR (orderOf m) m 0 (idxs[i1,i2]) 0 (idxs[j1,j2]))+ where+ (i1,i2) = getRowRange (rows m) rr+ (j1,j2) = getColRange (cols m) rc++-- | r0 c0 height width+data Slice s t = Slice (STMatrix s t) Int Int Int Int++slice :: Element a => Slice t a -> Matrix a+slice (Slice (STMatrix m) r0 c0 nr nc) = subMatrix (r0,c0) (nr,nc) m++gemmm :: Element t => t -> Slice s t -> t -> Slice s t -> Slice s t -> ST s ()+gemmm beta (slice->r) alpha (slice->a) (slice->b) = res+ where+ res = unsafeIOToST (gemm v a b r)+ v = fromList [alpha,beta]+++mutable :: Element t => (forall s . (Int, Int) -> STMatrix s t -> ST s u) -> Matrix t -> (Matrix t,u)+mutable f a = runST $ do+ x <- thawMatrix a+ info <- f (rows a, cols a) x+ r <- unsafeFreezeMatrix x+ return (r,info)
+ src/Internal/Sparse.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++module Internal.Sparse(+ GMatrix(..), CSR(..), mkCSR, fromCSR, impureCSR,+ mkSparse, mkDiagR, mkDense,+ AssocMatrix,+ toDense,+ gmXv, (!#>)+)where++import Internal.Vector+import Internal.Matrix+import Internal.Numeric+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as M+import Control.Arrow((***))+import Control.Monad(when, foldM)+import Control.Monad.ST (runST)+import Control.Monad.Primitive (PrimMonad)+import Data.List(sort)+import Foreign.C.Types(CInt(..))++import Internal.Devel+import System.IO.Unsafe(unsafePerformIO)+import Foreign(Ptr)+import Text.Printf(printf)++type AssocMatrix = [(IndexOf Matrix, Double)]++data CSR = CSR+ { csrVals :: Vector Double+ , csrCols :: Vector CInt+ , csrRows :: Vector CInt+ , csrNRows :: Int+ , csrNCols :: Int+ } deriving Show++data CSC = CSC+ { cscVals :: Vector Double+ , cscRows :: Vector CInt+ , cscCols :: Vector CInt+ , cscNRows :: Int+ , cscNCols :: Int+ } deriving Show+++-- | Produce a CSR sparse matrix from a association matrix.+mkCSR :: AssocMatrix -> CSR+mkCSR ms =+ runST $ impureCSR runFold $ sort ms+ where+ runFold next initialise xtract as0 = do+ i0 <- initialise+ acc <- foldM next i0 as0+ xtract acc++-- | Produce a CSR sparse matrix by applying a generic folding function.+--+-- This allows one to build a CSR from an effectful streaming source+-- when combined with libraries like pipes, io-streams, or streaming.+--+-- For example+--+-- > impureCSR Pipes.Prelude.foldM :: PrimMonad m => Producer AssocEntry m () -> m CSR+-- > impureCSR Streaming.Prelude.foldM :: PrimMonad m => Stream (Of AssocEntry) m r -> m (Of CSR r)+--+impureCSR+ :: PrimMonad m+ => (forall x . (x -> (IndexOf Matrix, Double) -> m x) -> m x -> (x -> m CSR) -> r)+ -> r+impureCSR f = f next begin done+ where+ sfi = succ . fi+ begin = do+ mv <- M.unsafeNew 64+ mr <- M.unsafeNew 64+ mc <- M.unsafeNew 64+ return (mv, mr, mc, 0, 0, 0, -1)++ next (!mv, !mr, !mc, !idxVC, !idxR, !maxC, !curRow) ((r,c),d) = do+ when (r < curRow) $+ error (printf "impureCSR: row %i specified after %i" r curRow)++ let lenVC = M.length mv+ lenR = M.length mr+ maxC' = max maxC c++ (mv', mc') <-+ if idxVC >= lenVC then do+ mv' <- M.unsafeGrow mv lenVC+ mc' <- M.unsafeGrow mc lenVC+ return (mv', mc')+ else+ return (mv, mc)++ mr' <-+ if idxR >= lenR - 1 then+ M.unsafeGrow mr lenR+ else+ return mr++ M.unsafeWrite mc' idxVC (sfi c)+ M.unsafeWrite mv' idxVC d++ idxR' <-+ foldM+ (\idxR' _ -> idxR' + 1 <$ M.unsafeWrite mr' idxR' (sfi idxVC))+ idxR [1 .. (r-curRow)]++ return (mv', mr', mc', idxVC + 1, idxR', maxC', r)++ done (!mv, !mr, !mc, !idxVC, !idxR, !maxC, !curR) = do+ M.unsafeWrite mr idxR (sfi idxVC)+ vv <- V.unsafeFreeze (M.unsafeTake idxVC mv)+ vc <- V.unsafeFreeze (M.unsafeTake idxVC mc)+ vr <- V.unsafeFreeze (M.unsafeTake (idxR + 1) mr)+ return $ CSR vv vc vr (succ curR) (succ maxC)+++{- | General matrix with specialized internal representations for+ dense, sparse, diagonal, banded, and constant elements.++>>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]+>>> m+SparseR {gmCSR = CSR {csrVals = fromList [1.0,2.0],+ csrCols = fromList [1000,2000],+ csrRows = fromList [1,2,3],+ csrNRows = 2,+ csrNCols = 2000},+ nRows = 2,+ nCols = 2000}++>>> let m = mkDense (mat 2 [1..4])+>>> m+Dense {gmDense = (2><2)+ [ 1.0, 2.0+ , 3.0, 4.0 ], nRows = 2, nCols = 2}++-}+data GMatrix+ = SparseR+ { gmCSR :: CSR+ , nRows :: Int+ , nCols :: Int+ }+ | SparseC+ { gmCSC :: CSC+ , nRows :: Int+ , nCols :: Int+ }+ | Diag+ { diagVals :: Vector Double+ , nRows :: Int+ , nCols :: Int+ }+ | Dense+ { gmDense :: Matrix Double+ , nRows :: Int+ , nCols :: Int+ }+-- | Banded+ deriving Show+++mkDense :: Matrix Double -> GMatrix+mkDense m = Dense{..}+ where+ gmDense = m+ nRows = rows m+ nCols = cols m++mkSparse :: AssocMatrix -> GMatrix+mkSparse = fromCSR . mkCSR++fromCSR :: CSR -> GMatrix+fromCSR csr = SparseR {..}+ where+ gmCSR@CSR {..} = csr+ nRows = csrNRows+ nCols = csrNCols+++mkDiagR :: Int -> Int -> Vector Double -> GMatrix+mkDiagR r c v+ | dim v <= min r c = Diag{..}+ | otherwise = error $ printf "mkDiagR: incorrect sizes (%d,%d) [%d]" r c (dim v)+ where+ nRows = r+ nCols = c+ diagVals = v+++type IV t = CInt -> Ptr CInt -> t+type V t = CInt -> Ptr Double -> t+type SMxV = V (IV (IV (V (V (IO CInt)))))++gmXv :: GMatrix -> Vector Double -> Vector Double+gmXv SparseR { gmCSR = CSR{..}, .. } v = unsafePerformIO $ do+ when (dim v /= nCols) $+ error (printf "gmXv (CSR): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v))++ r <- createVector nRows+ (csrVals # csrCols # csrRows # v #! r) c_smXv #|"CSRXv"+ return r++gmXv SparseC { gmCSC = CSC{..}, .. } v = unsafePerformIO $ do+ when (dim v /= nCols) $+ error (printf "gmXv (CSC): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v))++ r <- createVector nRows+ (cscVals # cscRows # cscCols # v #! r) c_smTXv #|"CSCXv"+ return r++gmXv Diag{..} v+ | dim v == nCols+ = vjoin [ subVector 0 (dim diagVals) v `mul` diagVals+ , konst 0 (nRows - dim diagVals) ]+ | otherwise = error $ printf "gmXv (Diag): incorrect sizes: (%d,%d) [%d] x %d"+ nRows nCols (dim diagVals) (dim v)++gmXv Dense{..} v+ | dim v == nCols+ = mXv gmDense v+ | otherwise = error $ printf "gmXv (Dense): incorrect sizes: (%d,%d) x %d"+ nRows nCols (dim v)+++{- | general matrix - vector product++>>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]+m :: GMatrix+>>> m !#> vector [1..2000]+[1000.0,4000.0]+it :: Vector Double++-}+infixr 8 !#>+(!#>) :: GMatrix -> Vector Double -> Vector Double+(!#>) = gmXv++--------------------------------------------------------------------------------++foreign import ccall unsafe "smXv"+ c_smXv :: SMxV++foreign import ccall unsafe "smTXv"+ c_smTXv :: SMxV++--------------------------------------------------------------------------------++toDense :: AssocMatrix -> Matrix Double+toDense asm = assoc (r+1,c+1) 0 asm+ where+ (r,c) = (maximum *** maximum) . unzip . map fst $ asm+++instance Transposable CSR CSC+ where+ tr (CSR vs cs rs n m) = CSC vs cs rs m n+ tr' = tr++instance Transposable CSC CSR+ where+ tr (CSC vs rs cs n m) = CSR vs rs cs m n+ tr' = tr++instance Transposable GMatrix GMatrix+ where+ tr (SparseR s n m) = SparseC (tr s) m n+ tr (SparseC s n m) = SparseR (tr s) m n+ tr (Diag v n m) = Diag v m n+ tr (Dense a n m) = Dense (tr a) m n+ tr' = tr
+ src/Internal/Static.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 708++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++{- |+Module : Internal.Static+Copyright : (c) Alberto Ruiz 2006-14+License : BSD3+Stability : provisional++-}++module Internal.Static where+++import GHC.TypeLits+import qualified Numeric.LinearAlgebra as LA+import Numeric.LinearAlgebra hiding (konst,size,R,C)+import Internal.Vector as D hiding (R,C)+import Internal.ST+import Control.DeepSeq+import Data.Proxy(Proxy)+import Foreign.Storable(Storable)+import Text.Printf++import Data.Binary+import GHC.Generics (Generic)+import Data.Proxy (Proxy(..))++--------------------------------------------------------------------------------++type ℝ = Double+type ℂ = Complex Double++newtype Dim (n :: Nat) t = Dim t+ deriving (Show, Generic)++instance (KnownNat n, Binary a) => Binary (Dim n a) where+ get = do+ k <- get+ let n = natVal (Proxy :: Proxy n)+ if n == k+ then Dim <$> get+ else fail ("Expected dimension " ++ (show n) ++ ", but found dimension " ++ (show k))++ put (Dim x) = do+ put (natVal (Proxy :: Proxy n))+ put x++lift1F+ :: (c t -> c t)+ -> Dim n (c t) -> Dim n (c t)+lift1F f (Dim v) = Dim (f v)++lift2F+ :: (c t -> c t -> c t)+ -> Dim n (c t) -> Dim n (c t) -> Dim n (c t)+lift2F f (Dim u) (Dim v) = Dim (f u v)++instance NFData t => NFData (Dim n t) where+ rnf (Dim (force -> !_)) = ()++--------------------------------------------------------------------------------++newtype R n = R (Dim n (Vector ℝ))+ deriving (Num,Fractional,Floating,Generic,Binary)++newtype C n = C (Dim n (Vector ℂ))+ deriving (Num,Fractional,Floating,Generic)++newtype L m n = L (Dim m (Dim n (Matrix ℝ)))+ deriving (Generic, Binary)++newtype M m n = M (Dim m (Dim n (Matrix ℂ)))+ deriving (Generic)++mkR :: Vector ℝ -> R n+mkR = R . Dim++mkC :: Vector ℂ -> C n+mkC = C . Dim++mkL :: Matrix ℝ -> L m n+mkL x = L (Dim (Dim x))++mkM :: Matrix ℂ -> M m n+mkM x = M (Dim (Dim x))++instance NFData (R n) where+ rnf (R (force -> !_)) = ()++instance NFData (C n) where+ rnf (C (force -> !_)) = ()++instance NFData (L n m) where+ rnf (L (force -> !_)) = ()++instance NFData (M n m) where+ rnf (M (force -> !_)) = ()++--------------------------------------------------------------------------------++type V n t = Dim n (Vector t)++ud :: Dim n (Vector t) -> Vector t+ud (Dim v) = v++mkV :: forall (n :: Nat) t . t -> Dim n t+mkV = Dim+++vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t)+ => V n t -> V m t -> V (n+m) t+(ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v'])+ where+ du = fromIntegral . natVal $ (undefined :: Proxy n)+ dv = fromIntegral . natVal $ (undefined :: Proxy m)+ u' | du /= 1 && LA.size u == 1 = LA.konst (u D.@> 0) du+ | otherwise = u+ v' | dv /= 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv+ | otherwise = v+++gvec2 :: Storable t => t -> t -> V 2 t+gvec2 a b = mkV $ runSTVector $ do+ v <- newUndefinedVector 2+ writeVector v 0 a+ writeVector v 1 b+ return v++gvec3 :: Storable t => t -> t -> t -> V 3 t+gvec3 a b c = mkV $ runSTVector $ do+ v <- newUndefinedVector 3+ writeVector v 0 a+ writeVector v 1 b+ writeVector v 2 c+ return v+++gvec4 :: Storable t => t -> t -> t -> t -> V 4 t+gvec4 a b c d = mkV $ runSTVector $ do+ v <- newUndefinedVector 4+ writeVector v 0 a+ writeVector v 1 b+ writeVector v 2 c+ writeVector v 3 d+ return v+++gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t+gvect st xs'+ | ok = mkV v+ | not (null rest) && null (tail rest) = abort (show xs')+ | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")+ | otherwise = abort (show xs)+ where+ (xs,rest) = splitAt d xs'+ ok = LA.size v == d && null rest+ v = LA.fromList xs+ d = fromIntegral . natVal $ (undefined :: Proxy n)+ abort info = error $ st++" "++show d++" can't be created from elements "++info+++--------------------------------------------------------------------------------++type GM m n t = Dim m (Dim n (Matrix t))+++gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t+gmat st xs'+ | ok = Dim (Dim x)+ | not (null rest) && null (tail rest) = abort (show xs')+ | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")+ | otherwise = abort (show xs)+ where+ (xs,rest) = splitAt (m'*n') xs'+ v = LA.fromList xs+ x = reshape n' v+ ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n'))+ m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int+ n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int+ abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info++--------------------------------------------------------------------------------++class Num t => Sized t s d | s -> t, s -> d+ where+ konst :: t -> s+ unwrap :: s -> d t+ fromList :: [t] -> s+ extract :: s -> d t+ create :: d t -> Maybe s+ size :: s -> IndexOf d++singleV v = LA.size v == 1+singleM m = rows m == 1 && cols m == 1+++instance KnownNat n => Sized ℂ (C n) Vector+ where+ size _ = fromIntegral . natVal $ (undefined :: Proxy n)+ konst x = mkC (LA.scalar x)+ unwrap (C (Dim v)) = v+ fromList xs = C (gvect "C" xs)+ extract s@(unwrap -> v)+ | singleV v = LA.konst (v!0) (size s)+ | otherwise = v+ create v+ | LA.size v == size r = Just r+ | otherwise = Nothing+ where+ r = mkC v :: C n+++instance KnownNat n => Sized ℝ (R n) Vector+ where+ size _ = fromIntegral . natVal $ (undefined :: Proxy n)+ konst x = mkR (LA.scalar x)+ unwrap (R (Dim v)) = v+ fromList xs = R (gvect "R" xs)+ extract s@(unwrap -> v)+ | singleV v = LA.konst (v!0) (size s)+ | otherwise = v+ create v+ | LA.size v == size r = Just r+ | otherwise = Nothing+ where+ r = mkR v :: R n++++instance (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix+ where+ size _ = ((fromIntegral . natVal) (undefined :: Proxy m)+ ,(fromIntegral . natVal) (undefined :: Proxy n))+ konst x = mkL (LA.scalar x)+ fromList xs = L (gmat "L" xs)+ unwrap (L (Dim (Dim m))) = m+ extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n'+ extract s@(unwrap -> a)+ | singleM a = LA.konst (a `atIndex` (0,0)) (size s)+ | otherwise = a+ create x+ | LA.size x == size r = Just r+ | otherwise = Nothing+ where+ r = mkL x :: L m n+++instance (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix+ where+ size _ = ((fromIntegral . natVal) (undefined :: Proxy m)+ ,(fromIntegral . natVal) (undefined :: Proxy n))+ konst x = mkM (LA.scalar x)+ fromList xs = M (gmat "M" xs)+ unwrap (M (Dim (Dim m))) = m+ extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n'+ extract s@(unwrap -> a)+ | singleM a = LA.konst (a `atIndex` (0,0)) (size s)+ | otherwise = a+ create x+ | LA.size x == size r = Just r+ | otherwise = Nothing+ where+ r = mkM x :: M m n++--------------------------------------------------------------------------------++instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m)+ where+ tr a@(isDiag -> Just _) = mkL (extract a)+ tr (extract -> a) = mkL (tr a)+ tr' = tr++instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m)+ where+ tr a@(isDiagC -> Just _) = mkM (extract a)+ tr (extract -> a) = mkM (tr a)+ tr' a@(isDiagC -> Just _) = mkM (extract a)+ tr' (extract -> a) = mkM (tr' a)++--------------------------------------------------------------------------------++isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int))+isDiag (L x) = isDiagg x++isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int))+isDiagC (M x) = isDiagg x+++isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int))+isDiagg (Dim (Dim x))+ | singleM x = Nothing+ | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n'))+ | otherwise = Nothing+ where+ m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int+ n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int+ v = flatten x+ z = v `atIndex` 0+ y = subVector 1 (LA.size v-1) v+ ny = LA.size y+ zeros = LA.konst 0 (max 0 (min m' n' - ny))+ yz = vjoin [y,zeros]++--------------------------------------------------------------------------------++instance KnownNat n => Show (R n)+ where+ show s@(R (Dim v))+ | singleV v = "(" ++ show (v!0) ++ " :: R " ++ show d ++ ")"+ | otherwise = "(vector " ++ show v ++ " :: R " ++ show d ++")"+ where+ d = size s++instance KnownNat n => Show (C n)+ where+ show s@(C (Dim v))+ | singleV v = "(" ++ show (v!0) ++ " :: C " ++ show d ++ ")"+ | otherwise = "(vector " ++ show v ++ " :: C " ++ show d ++")"+ where+ d = size s++instance (KnownNat m, KnownNat n) => Show (L m n)+ where+ show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (show y) m' n'+ show s@(L (Dim (Dim x)))+ | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n'+ | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: L " ++ show m' ++ " " ++ show n' ++ ")"+ where+ (m',n') = size s++instance (KnownNat m, KnownNat n) => Show (M m n)+ where+ show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (show y) m' n'+ show s@(M (Dim (Dim x)))+ | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n'+ | otherwise = "(matrix" ++ dropWhile (/='\n') (show x) ++ " :: M " ++ show m' ++ " " ++ show n' ++ ")"+ where+ (m',n') = size s++--------------------------------------------------------------------------------++instance (Num (Vector t), Numeric t )=> Num (Dim n (Vector t))+ where+ (+) = lift2F (+)+ (*) = lift2F (*)+ (-) = lift2F (-)+ abs = lift1F abs+ signum = lift1F signum+ negate = lift1F negate+ fromInteger x = Dim (fromInteger x)++instance (Num (Vector t), Fractional t, Numeric t) => Fractional (Dim n (Vector t))+ where+ fromRational x = Dim (fromRational x)+ (/) = lift2F (/)++instance (Fractional t, Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where+ sin = lift1F sin+ cos = lift1F cos+ tan = lift1F tan+ asin = lift1F asin+ acos = lift1F acos+ atan = lift1F atan+ sinh = lift1F sinh+ cosh = lift1F cosh+ tanh = lift1F tanh+ asinh = lift1F asinh+ acosh = lift1F acosh+ atanh = lift1F atanh+ exp = lift1F exp+ log = lift1F log+ sqrt = lift1F sqrt+ (**) = lift2F (**)+ pi = Dim pi+++instance (Num (Vector t), Numeric t) => Num (Dim m (Dim n (Matrix t)))+ where+ (+) = (lift2F . lift2F) (+)+ (*) = (lift2F . lift2F) (*)+ (-) = (lift2F . lift2F) (-)+ abs = (lift1F . lift1F) abs+ signum = (lift1F . lift1F) signum+ negate = (lift1F . lift1F) negate+ fromInteger x = Dim (Dim (fromInteger x))++instance (Num (Vector t), Fractional t, Numeric t) => Fractional (Dim m (Dim n (Matrix t)))+ where+ fromRational x = Dim (Dim (fromRational x))+ (/) = (lift2F.lift2F) (/)++instance (Floating (Vector t), Floating t, Numeric t) => Floating (Dim m (Dim n (Matrix t))) where+ sin = (lift1F . lift1F) sin+ cos = (lift1F . lift1F) cos+ tan = (lift1F . lift1F) tan+ asin = (lift1F . lift1F) asin+ acos = (lift1F . lift1F) acos+ atan = (lift1F . lift1F) atan+ sinh = (lift1F . lift1F) sinh+ cosh = (lift1F . lift1F) cosh+ tanh = (lift1F . lift1F) tanh+ asinh = (lift1F . lift1F) asinh+ acosh = (lift1F . lift1F) acosh+ atanh = (lift1F . lift1F) atanh+ exp = (lift1F . lift1F) exp+ log = (lift1F . lift1F) log+ sqrt = (lift1F . lift1F) sqrt+ (**) = (lift2F . lift2F) (**)+ pi = Dim (Dim pi)++--------------------------------------------------------------------------------+++adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b+adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b))+adaptDiag f a b = f a b++isFull m = isDiag m == Nothing && not (singleM (unwrap m))+++lift1L f (L v) = L (f v)+lift2L f (L a) (L b) = L (f a b)+lift2LD f = adaptDiag (lift2L f)+++instance (KnownNat n, KnownNat m) => Num (L n m)+ where+ (+) = lift2LD (+)+ (*) = lift2LD (*)+ (-) = lift2LD (-)+ abs = lift1L abs+ signum = lift1L signum+ negate = lift1L negate+ fromInteger = L . Dim . Dim . fromInteger++instance (KnownNat n, KnownNat m) => Fractional (L n m)+ where+ fromRational = L . Dim . Dim . fromRational+ (/) = lift2LD (/)++instance (KnownNat n, KnownNat m) => Floating (L n m) where+ sin = lift1L sin+ cos = lift1L cos+ tan = lift1L tan+ asin = lift1L asin+ acos = lift1L acos+ atan = lift1L atan+ sinh = lift1L sinh+ cosh = lift1L cosh+ tanh = lift1L tanh+ asinh = lift1L asinh+ acosh = lift1L acosh+ atanh = lift1L atanh+ exp = lift1L exp+ log = lift1L log+ sqrt = lift1L sqrt+ (**) = lift2LD (**)+ pi = konst pi++--------------------------------------------------------------------------------++adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b+adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b))+adaptDiagC f a b = f a b++isFullC m = isDiagC m == Nothing && not (singleM (unwrap m))++lift1M f (M v) = M (f v)+lift2M f (M a) (M b) = M (f a b)+lift2MD f = adaptDiagC (lift2M f)++instance (KnownNat n, KnownNat m) => Num (M n m)+ where+ (+) = lift2MD (+)+ (*) = lift2MD (*)+ (-) = lift2MD (-)+ abs = lift1M abs+ signum = lift1M signum+ negate = lift1M negate+ fromInteger = M . Dim . Dim . fromInteger++instance (KnownNat n, KnownNat m) => Fractional (M n m)+ where+ fromRational = M . Dim . Dim . fromRational+ (/) = lift2MD (/)++instance (KnownNat n, KnownNat m) => Floating (M n m) where+ sin = lift1M sin+ cos = lift1M cos+ tan = lift1M tan+ asin = lift1M asin+ acos = lift1M acos+ atan = lift1M atan+ sinh = lift1M sinh+ cosh = lift1M cosh+ tanh = lift1M tanh+ asinh = lift1M asinh+ acosh = lift1M acosh+ atanh = lift1M atanh+ exp = lift1M exp+ log = lift1M log+ sqrt = lift1M sqrt+ (**) = lift2MD (**)+ pi = M pi++instance Additive (R n) where+ add = (+)++instance Additive (C n) where+ add = (+)++instance (KnownNat m, KnownNat n) => Additive (L m n) where+ add = (+)++instance (KnownNat m, KnownNat n) => Additive (M m n) where+ add = (+)++--------------------------------------------------------------------------------+++class Disp t+ where+ disp :: Int -> t -> IO ()+++instance (KnownNat m, KnownNat n) => Disp (L m n)+ where+ disp n x = do+ let a = extract x+ let su = LA.dispf n a+ printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)++instance (KnownNat m, KnownNat n) => Disp (M m n)+ where+ disp n x = do+ let a = extract x+ let su = LA.dispcf n a+ printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)+++instance KnownNat n => Disp (R n)+ where+ disp n v = do+ let su = LA.dispf n (asRow $ extract v)+ putStr "R " >> putStr (tail . dropWhile (/='x') $ su)++instance KnownNat n => Disp (C n)+ where+ disp n v = do+ let su = LA.dispcf n (asRow $ extract v)+ putStr "C " >> putStr (tail . dropWhile (/='x') $ su)++--------------------------------------------------------------------------------++overMatL' :: (KnownNat m, KnownNat n)+ => (LA.Matrix ℝ -> LA.Matrix ℝ) -> L m n -> L m n+overMatL' f = mkL . f . unwrap+{-# INLINE overMatL' #-}++overMatM' :: (KnownNat m, KnownNat n)+ => (LA.Matrix ℂ -> LA.Matrix ℂ) -> M m n -> M m n+overMatM' f = mkM . f . unwrap+{-# INLINE overMatM' #-}+++#else++module Numeric.LinearAlgebra.Static.Internal where++#endif+
+ src/Internal/Util.hs view
@@ -0,0 +1,914 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+{- |+Module : Internal.Util+Copyright : (c) Alberto Ruiz 2013+License : BSD3+Maintainer : Alberto Ruiz+Stability : provisional++-}+-----------------------------------------------------------------------------++module Internal.Util(++ -- * Convenience functions+ vector, matrix,+ disp,+ formatSparse,+ approxInt,+ dispDots,+ dispBlanks,+ formatShort,+ dispShort,+ zeros, ones,+ diagl,+ row,+ col,+ (&), (¦), (|||), (——), (===),+ (?), (¿),+ Indexable(..), size,+ Numeric,+ rand, randn,+ cross,+ norm,+ ℕ,ℤ,ℝ,ℂ,iC,+ Normed(..), norm_Frob, norm_nuclear,+ magnit,+ normalize,+ mt,+ (~!~),+ pairwiseD2,+ rowOuters,+ null1,+ null1sym,+ -- * Convolution+ -- ** 1D+ corr, conv, corrMin,+ -- ** 2D+ corr2, conv2, separable,+ block2x2,block3x3,view1,unView1,foldMatrix,+ gaussElim_1, gaussElim_2, gaussElim,+ luST, luSolve', luSolve'', luPacked', luPacked'',+ invershur+) where++import Internal.Vector+import Internal.Matrix hiding (size)+import Internal.Numeric+import Internal.Element+import Internal.Container+import Internal.Vectorized+import Internal.IO+import Internal.Algorithms hiding (Normed,linearSolve',luSolve', luPacked')+import Numeric.Matrix()+import Numeric.Vector()+import Internal.Random+import Internal.Convolution+import Control.Monad(when,forM_)+import Text.Printf+import Data.List.Split(splitOn)+import Data.List(intercalate,sortBy,foldl')+import Control.Arrow((&&&),(***))+import Data.Complex+import Data.Function(on)+import Internal.ST+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++type ℝ = Double+type ℕ = Int+type ℤ = Int+type ℂ = Complex Double++-- | imaginary unit+iC :: C+iC = 0:+1++{- | Create a real vector.++>>> vector [1..5]+[1.0,2.0,3.0,4.0,5.0]+it :: Vector R++-}+vector :: [R] -> Vector R+vector = fromList++{- | Create a real matrix.++>>> matrix 5 [1..15]+(3><5)+ [ 1.0, 2.0, 3.0, 4.0, 5.0+ , 6.0, 7.0, 8.0, 9.0, 10.0+ , 11.0, 12.0, 13.0, 14.0, 15.0 ]++-}+matrix+ :: Int -- ^ number of columns+ -> [R] -- ^ elements in row order+ -> Matrix R+matrix c = reshape c . fromList+++{- | print a real matrix with given number of digits after the decimal point++>>> disp 5 $ ident 2 / 3+2x2+0.33333 0.00000+0.00000 0.33333++-}+disp :: Int -> Matrix Double -> IO ()++disp n = putStr . dispf n+++{- | create a real diagonal matrix from a list++>>> diagl [1,2,3]+(3><3)+ [ 1.0, 0.0, 0.0+ , 0.0, 2.0, 0.0+ , 0.0, 0.0, 3.0 ]++-}+diagl :: [Double] -> Matrix Double+diagl = diag . fromList++-- | a real matrix of zeros+zeros :: Int -- ^ rows+ -> Int -- ^ columns+ -> Matrix Double+zeros r c = konst 0 (r,c)++-- | a real matrix of ones+ones :: Int -- ^ rows+ -> Int -- ^ columns+ -> Matrix Double+ones r c = konst 1 (r,c)++-- | concatenation of real vectors+infixl 3 &+(&) :: Vector Double -> Vector Double -> Vector Double+a & b = vjoin [a,b]++{- | horizontal concatenation++>>> ident 3 ||| konst 7 (3,4)+(3><7)+ [ 1.0, 0.0, 0.0, 7.0, 7.0, 7.0, 7.0+ , 0.0, 1.0, 0.0, 7.0, 7.0, 7.0, 7.0+ , 0.0, 0.0, 1.0, 7.0, 7.0, 7.0, 7.0 ]++-}+infixl 3 |||+(|||) :: Element t => Matrix t -> Matrix t -> Matrix t+a ||| b = fromBlocks [[a,b]]++-- | a synonym for ('|||') (unicode 0x00a6, broken bar)+infixl 3 ¦+(¦) :: Matrix Double -> Matrix Double -> Matrix Double+(¦) = (|||)+++-- | vertical concatenation+--+(===) :: Element t => Matrix t -> Matrix t -> Matrix t+infixl 2 ===+a === b = fromBlocks [[a],[b]]++-- | a synonym for ('===') (unicode 0x2014, em dash)+(——) :: Matrix Double -> Matrix Double -> Matrix Double+infixl 2 ——+(——) = (===)+++-- | create a single row real matrix from a list+--+-- >>> row [2,3,1,8]+-- (1><4)+-- [ 2.0, 3.0, 1.0, 8.0 ]+--+row :: [Double] -> Matrix Double+row = asRow . fromList++-- | create a single column real matrix from a list+--+-- >>> col [7,-2,4]+-- (3><1)+-- [ 7.0+-- , -2.0+-- , 4.0 ]+--+col :: [Double] -> Matrix Double+col = asColumn . fromList++{- | extract rows++>>> (20><4) [1..] ? [2,1,1]+(3><4)+ [ 9.0, 10.0, 11.0, 12.0+ , 5.0, 6.0, 7.0, 8.0+ , 5.0, 6.0, 7.0, 8.0 ]++-}+infixl 9 ?+(?) :: Element t => Matrix t -> [Int] -> Matrix t+(?) = flip extractRows++{- | extract columns++(unicode 0x00bf, inverted question mark, Alt-Gr ?)++>>> (3><4) [1..] ¿ [3,0]+(3><2)+ [ 4.0, 1.0+ , 8.0, 5.0+ , 12.0, 9.0 ]++-}+infixl 9 ¿+(¿) :: Element t => Matrix t -> [Int] -> Matrix t+(¿)= flip extractColumns+++cross :: Product t => Vector t -> Vector t -> Vector t+-- ^ cross product (for three-element vectors)+cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3]+ | otherwise = error $ "the cross product requires 3-element vectors (sizes given: "+ ++show (dim x)++" and "++show (dim y)++")"+ where+ [x1,x2,x3] = toList x+ [y1,y2,y3] = toList y+ z1 = x2*y3-x3*y2+ z2 = x3*y1-x1*y3+ z3 = x1*y2-x2*y1++{-# SPECIALIZE cross :: Vector Double -> Vector Double -> Vector Double #-}+{-# SPECIALIZE cross :: Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-}++norm :: Vector Double -> Double+-- ^ 2-norm of real vector+norm = pnorm PNorm2++-- | p-norm for vectors, operator norm for matrices+class Normed a+ where+ norm_0 :: a -> R+ norm_1 :: a -> R+ norm_2 :: a -> R+ norm_Inf :: a -> R+++instance Normed (Vector R)+ where+ norm_0 v = sumElements (step (abs v - scalar (eps*normInf v)))+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Vector C)+ where+ norm_0 v = sumElements (step (fst (fromComplex (abs v)) - scalar (eps*normInf v)))+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Matrix R)+ where+ norm_0 = norm_0 . flatten+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Matrix C)+ where+ norm_0 = norm_0 . flatten+ norm_1 = pnorm PNorm1+ norm_2 = pnorm PNorm2+ norm_Inf = pnorm Infinity++instance Normed (Vector I)+ where+ norm_0 = fromIntegral . sumElements . step . abs+ norm_1 = fromIntegral . norm1+ norm_2 v = sqrt . fromIntegral $ dot v v+ norm_Inf = fromIntegral . normInf++instance Normed (Vector Z)+ where+ norm_0 = fromIntegral . sumElements . step . abs+ norm_1 = fromIntegral . norm1+ norm_2 v = sqrt . fromIntegral $ dot v v+ norm_Inf = fromIntegral . normInf++instance Normed (Vector Float)+ where+ norm_0 = norm_0 . double+ norm_1 = norm_1 . double+ norm_2 = norm_2 . double+ norm_Inf = norm_Inf . double++instance Normed (Vector (Complex Float))+ where+ norm_0 = norm_0 . double+ norm_1 = norm_1 . double+ norm_2 = norm_2 . double+ norm_Inf = norm_Inf . double++-- | Frobenius norm (Schatten p-norm with p=2)+norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> R+norm_Frob = norm_2 . flatten++-- | Sum of singular values (Schatten p-norm with p=1)+norm_nuclear :: Field t => Matrix t -> R+norm_nuclear = sumElements . singularValues++{- | Check if the absolute value or complex magnitude is greater than a given threshold++>>> magnit 1E-6 (1E-12 :: R)+False+>>> magnit 1E-6 (3+iC :: C)+True+>>> magnit 0 (3 :: I ./. 5)+True++-}+magnit :: (Element t, Normed (Vector t)) => R -> t -> Bool+magnit e x = norm_1 (fromList [x]) > e+++-- | Obtains a vector in the same direction with 2-norm=1+normalize :: (Normed (Vector t), Num (Vector t), Field t) => Vector t -> Vector t+normalize v = v / real (scalar (norm_2 v))+++-- | trans . inv+mt :: Matrix Double -> Matrix Double+mt = trans . inv++--------------------------------------------------------------------------------+{- |++>>> size $ vector [1..10]+10+>>> size $ (2><5)[1..10::Double]+(2,5)++-}+size :: Container c t => c t -> IndexOf c+size = size'++{- | Alternative indexing function.++>>> vector [1..10] ! 3+4.0++On a matrix it gets the k-th row as a vector:++>>> matrix 5 [1..15] ! 1+[6.0,7.0,8.0,9.0,10.0]+it :: Vector Double++>>> matrix 5 [1..15] ! 1 ! 3+9.0++-}+class Indexable c t | c -> t , t -> c+ where+ infixl 9 !+ (!) :: c -> Int -> t++instance Indexable (Vector Double) Double+ where+ (!) = (@>)++instance Indexable (Vector Float) Float+ where+ (!) = (@>)++instance Indexable (Vector I) I+ where+ (!) = (@>)++instance Indexable (Vector Z) Z+ where+ (!) = (@>)++instance Indexable (Vector (Complex Double)) (Complex Double)+ where+ (!) = (@>)++instance Indexable (Vector (Complex Float)) (Complex Float)+ where+ (!) = (@>)++instance Element t => Indexable (Matrix t) (Vector t)+ where+ m ! j = subVector (j*c) c (flatten m)+ where+ c = cols m++--------------------------------------------------------------------------------++-- | Matrix of pairwise squared distances of row vectors+-- (using the matrix product trick in blog.smola.org)+pairwiseD2 :: Matrix Double -> Matrix Double -> Matrix Double+pairwiseD2 x y | ok = x2 `outer` oy + ox `outer` y2 - 2* x <> trans y+ | otherwise = error $ "pairwiseD2 with different number of columns: "+ ++ show (size x) ++ ", " ++ show (size y)+ where+ ox = one (rows x)+ oy = one (rows y)+ oc = one (cols x)+ one k = konst 1 k+ x2 = x * x <> oc+ y2 = y * y <> oc+ ok = cols x == cols y++--------------------------------------------------------------------------------++{- | outer products of rows++>>> a+(3><2)+ [ 1.0, 2.0+ , 10.0, 20.0+ , 100.0, 200.0 ]+>>> b+(3><3)+ [ 1.0, 2.0, 3.0+ , 4.0, 5.0, 6.0+ , 7.0, 8.0, 9.0 ]++>>> rowOuters a (b ||| 1)+(3><8)+ [ 1.0, 2.0, 3.0, 1.0, 2.0, 4.0, 6.0, 2.0+ , 40.0, 50.0, 60.0, 10.0, 80.0, 100.0, 120.0, 20.0+ , 700.0, 800.0, 900.0, 100.0, 1400.0, 1600.0, 1800.0, 200.0 ]++-}+rowOuters :: Matrix Double -> Matrix Double -> Matrix Double+rowOuters a b = a' * b'+ where+ a' = kronecker a (ones 1 (cols b))+ b' = kronecker (ones 1 (cols a)) b++--------------------------------------------------------------------------------++-- | solution of overconstrained homogeneous linear system+null1 :: Matrix R -> Vector R+null1 = last . toColumns . snd . rightSV++-- | solution of overconstrained homogeneous symmetric linear system+null1sym :: Herm R -> Vector R+null1sym = last . toColumns . snd . eigSH++--------------------------------------------------------------------------------++infixl 0 ~!~+c ~!~ msg = when c (error msg)++--------------------------------------------------------------------------------++formatSparse :: String -> String -> String -> Int -> Matrix Double -> String++formatSparse zeroI _zeroF sep _ (approxInt -> Just m) = format sep f m+ where+ f 0 = zeroI+ f x = printf "%.0f" x++formatSparse zeroI zeroF sep n m = format sep f m+ where+ f x | abs (x::Double) < 2*peps = zeroI++zeroF+ | abs (fromIntegral (round x::Int) - x) / abs x < 2*peps+ = printf ("%.0f."++replicate n ' ') x+ | otherwise = printf ("%."++show n++"f") x++approxInt m+ | norm_Inf (v - vi) < 2*peps * norm_Inf v = Just (reshape (cols m) vi)+ | otherwise = Nothing+ where+ v = flatten m+ vi = roundVector v++dispDots n = putStr . formatSparse "." (replicate n ' ') " " n++dispBlanks n = putStr . formatSparse "" "" " " n++formatShort sep fmt maxr maxc m = auxm4+ where+ (rm,cm) = size m+ (r1,r2,r3)+ | rm <= maxr = (rm,0,0)+ | otherwise = (maxr-3,rm-maxr+1,2)+ (c1,c2,c3)+ | cm <= maxc = (cm,0,0)+ | otherwise = (maxc-3,cm-maxc+1,2)+ [ [a,_,b]+ ,[_,_,_]+ ,[c,_,d]] = toBlocks [r1,r2,r3]+ [c1,c2,c3] m+ auxm = fromBlocks [[a,b],[c,d]]+ auxm2+ | cm > maxc = format "|" fmt auxm+ | otherwise = format sep fmt auxm+ auxm3+ | cm > maxc = map (f . splitOn "|") (lines auxm2)+ | otherwise = (lines auxm2)+ f items = intercalate sep (take (maxc-3) items) ++ " .. " +++ intercalate sep (drop (maxc-3) items)+ auxm4+ | rm > maxr = unlines (take (maxr-3) auxm3 ++ vsep : drop (maxr-3) auxm3)+ | otherwise = unlines auxm3+ vsep = map g (head auxm3)+ g '.' = ':'+ g _ = ' '+++dispShort :: Int -> Int -> Int -> Matrix Double -> IO ()+dispShort maxr maxc dec m =+ printf "%dx%d\n%s" (rows m) (cols m) (formatShort " " fmt maxr maxc m)+ where+ fmt = printf ("%."++show dec ++"f")++--------------------------------------------------------------------------------++-- matrix views++block2x2 r c m = [[m11,m12],[m21,m22]]+ where+ m11 = m ?? (Take r, Take c)+ m12 = m ?? (Take r, Drop c)+ m21 = m ?? (Drop r, Take c)+ m22 = m ?? (Drop r, Drop c)++block3x3 r nr c nc m = [[m ?? (er !! i, ec !! j) | j <- [0..2] ] | i <- [0..2] ]+ where+ er = [ Range 0 1 (r-1), Range r 1 (r+nr-1), Drop (nr+r) ]+ ec = [ Range 0 1 (c-1), Range c 1 (c+nc-1), Drop (nc+c) ]++view1 :: Numeric t => Matrix t -> Maybe (View1 t)+view1 m+ | rows m > 0 && cols m > 0 = Just (e, flatten m12, flatten m21 , m22)+ | otherwise = Nothing+ where+ [[m11,m12],[m21,m22]] = block2x2 1 1 m+ e = m11 `atIndex` (0, 0)++unView1 :: Numeric t => View1 t -> Matrix t+unView1 (e,r,c,m) = fromBlocks [[scalar e, asRow r],[asColumn c, m]]++type View1 t = (t, Vector t, Vector t, Matrix t)++foldMatrix :: Numeric t => (Matrix t -> Matrix t) -> (View1 t -> View1 t) -> (Matrix t -> Matrix t)+foldMatrix g f ( (f <$>) . view1 . g -> Just (e,r,c,m)) = unView1 (e, r, c, foldMatrix g f m)+foldMatrix _ _ m = m+++swapMax k m+ | rows m > 0 && j>0 = (j, m ?? (Pos (idxs swapped), All))+ | otherwise = (0,m)+ where+ j = maxIndex $ abs (tr m ! k)+ swapped = j:[1..j-1] ++ 0:[j+1..rows m-1]++down g a = foldMatrix g f a+ where+ f (e,r,c,m)+ | e /= 0 = (1, r', 0, m - outer c r')+ | otherwise = error "singular!"+ where+ r' = r / scalar e+++-- | generic reference implementation of gaussian elimination+--+-- @a <> gaussElim a b = b@+--+gaussElim_2+ :: (Eq t, Fractional t, Num (Vector t), Numeric t)+ => Matrix t -> Matrix t -> Matrix t++gaussElim_2 a b = flipudrl r+ where+ flipudrl = flipud . fliprl+ splitColsAt n = (takeColumns n &&& dropColumns n)+ go f x y = splitColsAt (cols a) (down f $ x ||| y)+ (a1,b1) = go (snd . swapMax 0) a b+ ( _, r) = go id (flipudrl $ a1) (flipudrl $ b1)++--------------------------------------------------------------------------------++gaussElim_1+ :: (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Matrix t -> Matrix t -> Matrix t++gaussElim_1 x y = dropColumns (rows x) (flipud $ fromRows s2)+ where+ rs = toRows $ x ||| y+ s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting+ s2 = pivotUp (rows x-1) (toRows $ flipud s1)++pivotDown+ :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Int -> Int -> [Vector t] -> [Vector t]+pivotDown t n xs+ | t == n = []+ | otherwise = y : pivotDown t (n+1) ys+ where+ y:ys = redu (pivot n xs)++ pivot k = (const k &&& id)+ . sortBy (flip compare `on` (abs. (! k)))++ redu :: (Int, [Vector t]) -> [Vector t]+ redu (k,x:zs)+ | p == 0 = error "gauss: singular!" -- FIXME+ | otherwise = u : map f zs+ where+ p = x!k+ u = scale (recip (x!k)) x+ f z = z - scale (z!k) u+ redu (_,[]) = []+++pivotUp+ :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t)+ => Int -> [Vector t] -> [Vector t]+pivotUp n xs+ | n == -1 = []+ | otherwise = y : pivotUp (n-1) ys+ where+ y:ys = redu' (n,xs)++ redu' :: (Int, [Vector t]) -> [Vector t]+ redu' (k,x:zs) = u : map f zs+ where+ u = x+ f z = z - scale (z!k) u+ redu' (_,[]) = []++--------------------------------------------------------------------------------++gaussElim a b = dropColumns (rows a) $ fst $ mutable gaussST (a ||| b)++gaussST (r,_) x = do+ let n = r-1+ axpy m a i j = rowOper (AXPY a i j AllCols) m+ swap m i j = rowOper (SWAP i j AllCols) m+ scal m a i = rowOper (SCAL a (Row i) AllCols) m+ forM_ [0..n] $ \i -> do+ c <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i)+ swap x i (i+c)+ a <- readMatrix x i i+ when (a == 0) $ error "singular!"+ scal x (recip a) i+ forM_ [i+1..n] $ \j -> do+ b <- readMatrix x j i+ axpy x (-b) i j+ forM_ [n,n-1..1] $ \i -> do+ forM_ [i-1,i-2..0] $ \j -> do+ b <- readMatrix x j i+ axpy x (-b) i j++++luST ok (r,_) x = do+ let axpy m a i j = rowOper (AXPY a i j (FromCol (i+1))) m+ swap m i j = rowOper (SWAP i j AllCols) m+ p <- newUndefinedVector r+ forM_ [0..r-1] $ \i -> do+ k <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i)+ writeVector p i (k+i)+ swap x i (i+k)+ a <- readMatrix x i i+ when (ok a) $ do+ forM_ [i+1..r-1] $ \j -> do+ b <- (/a) <$> readMatrix x j i+ axpy x (-b) i j+ writeMatrix x j i b+ v <- unsafeFreezeVector p+ return (toList v)++{- | Experimental implementation of 'luPacked'+ for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'.++>>> let m = ident 5 + (5><5) [0..] :: Matrix (Z ./. 17)+(5><5)+ [ 1, 1, 2, 3, 4+ , 5, 7, 7, 8, 9+ , 10, 11, 13, 13, 14+ , 15, 16, 0, 2, 2+ , 3, 4, 5, 6, 8 ]++>>> let (l,u,p,s) = luFact $ luPacked' m+>>> l+(5><5)+ [ 1, 0, 0, 0, 0+ , 6, 1, 0, 0, 0+ , 12, 7, 1, 0, 0+ , 7, 10, 7, 1, 0+ , 8, 2, 6, 11, 1 ]+>>> u+(5><5)+ [ 15, 16, 0, 2, 2+ , 0, 13, 7, 13, 14+ , 0, 0, 15, 0, 11+ , 0, 0, 0, 15, 15+ , 0, 0, 0, 0, 1 ]++-}+luPacked' x = LU m p+ where+ (m,p) = mutable (luST (magnit 0)) x++--------------------------------------------------------------------------------++scalS a (Slice x r0 c0 nr nc) = rowOper (SCAL a (RowRange r0 (r0+nr-1)) (ColRange c0 (c0+nc-1))) x++view x k r = do+ d <- readMatrix x k k+ let rr = r-1-k+ o = if k < r-1 then 1 else 0+ s = Slice x (k+1) (k+1) rr rr+ u = Slice x k (k+1) o rr+ l = Slice x (k+1) k rr o+ return (d,u,l,s)++withVec r f = \s x -> do+ p <- newUndefinedVector r+ _ <- f s x p+ v <- unsafeFreezeVector p+ return v+++luPacked'' m = (id *** toList) (mutable (withVec (rows m) lu2) m)+ where+ lu2 (r,_) x p = do+ forM_ [0..r-1] $ \k -> do+ pivot x p k+ (d,u,l,s) <- view x k r+ when (magnit 0 d) $ do+ scalS (recip d) l+ gemmm 1 s (-1) l u++ pivot x p k = do+ j <- maxIndex . abs . flatten <$> extractMatrix x (FromRow k) (Col k)+ writeVector p k (j+k)+ swap k (k+j)+ where+ swap i j = rowOper (SWAP i j AllCols) x++--------------------------------------------------------------------------------++rowRange m = [0..rows m -1]++at k = Pos (idxs[k])++backSust' lup rhs = foldl' f (rhs?[]) (reverse ls)+ where+ ls = [ (d k , u k , b k) | k <- rowRange lup ]+ where+ d k = lup ?? (at k, at k)+ u k = lup ?? (at k, Drop (k+1))+ b k = rhs ?? (at k, All)++ f x (d,u,b) = (b - u<>x) / d+ ===+ x+++forwSust' lup rhs = foldl' f (rhs?[]) ls+ where+ ls = [ (l k , b k) | k <- rowRange lup ]+ where+ l k = lup ?? (at k, Take k)+ b k = rhs ?? (at k, All)++ f x (l,b) = x+ ===+ (b - l<>x)+++luSolve'' (LU lup p) b = backSust' lup (forwSust' lup pb)+ where+ pb = b ?? (Pos (fixPerm' p), All)++--------------------------------------------------------------------------------++forwSust lup rhs = fst $ mutable f rhs+ where+ f (r,c) x = do+ l <- unsafeThawMatrix lup+ let go k = gemmm 1 (Slice x k 0 1 c) (-1) (Slice l k 0 1 k) (Slice x 0 0 k c)+ mapM_ go [0..r-1]+++backSust lup rhs = fst $ mutable f rhs+ where+ f (r,c) m = do+ l <- unsafeThawMatrix lup+ let d k = recip (lup `atIndex` (k,k))+ u k = Slice l k (k+1) 1 (r-1-k)+ b k = Slice m k 0 1 c+ x k = Slice m (k+1) 0 (r-1-k) c+ scal k = rowOper (SCAL (d k) (Row k) AllCols) m++ go k = gemmm 1 (b k) (-1) (u k) (x k) >> scal k+ mapM_ go [r-1,r-2..0]+++{- | Experimental implementation of 'luSolve' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'.++>>> let a = (2><2) [1,2,3,5] :: Matrix (Z ./. 13)+(2><2)+ [ 1, 2+ , 3, 5 ]+>>> b+(2><3)+ [ 5, 1, 3+ , 8, 6, 3 ]++>>> luSolve' (luPacked' a) b+(2><3)+ [ 4, 7, 4+ , 7, 10, 6 ]++-}+luSolve' (LU lup p) b = backSust lup (forwSust lup pb)+ where+ pb = b ?? (Pos (fixPerm' p), All)+++--------------------------------------------------------------------------------++data MatrixView t b+ = Elem t+ | Block b b b b+ deriving Show+++viewBlock' r c m+ | (rt,ct) == (1,1) = Elem (atM' m 0 0)+ | otherwise = Block m11 m12 m21 m22+ where+ (rt,ct) = size m+ m11 = subm (0,0) (r,c) m+ m12 = subm (0,c) (r,ct-c) m+ m21 = subm (r,0) (rt-r,c) m+ m22 = subm (r,c) (rt-r,ct-c) m+ subm = subMatrix++viewBlock m = viewBlock' n n m+ where+ n = rows m `div` 2++invershur (viewBlock -> Block a b c d) = fromBlocks [[a',b'],[c',d']]+ where+ r1 = invershur a+ r2 = c <> r1+ r3 = r1 <> b+ r4 = c <> r3+ r5 = r4-d+ r6 = invershur r5+ b' = r3 <> r6+ c' = r6 <> r2+ r7 = r3 <> c'+ a' = r1-r7+ d' = -r6++invershur x = recip x++--------------------------------------------------------------------------------++instance Testable (Matrix I) where+ checkT _ = test++test :: (Bool, IO())+test = (and ok, return ())+ where+ m = (3><4) [1..12] :: Matrix I+ r = (2><3) [1,2,3,4,3,2]+ c = (3><2) [0,4,4,1,2,3]+ p = (9><10) [0..89] :: Matrix I+ ep = (2><3) [10,24,32,44,31,23]+ md = fromInt m :: Matrix Double+ ok = [ tr m <> m == toInt (tr md <> md)+ , m <> tr m == toInt (md <> tr md)+ , m ?? (Take 2, Take 3) == remap (asColumn (range 2)) (asRow (range 3)) m+ , remap r (tr c) p == ep+ , tr p ?? (PosCyc (idxs[-5,13]), Pos (idxs[3,7,1])) == (2><3) [35,75,15,33,73,13]+ ]
+ src/Internal/Vector.hs view
@@ -0,0 +1,468 @@+{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module : Internal.Vector+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--++module Internal.Vector(+ I,Z,R,C,+ fi,ti,+ Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith,+ createVector, avec, inlinePerformIO,+ toList, dim, (@>), at', (|>),+ vjoin, subVector, takesV, idxs,+ buildVector,+ asReal, asComplex,+ toByteString,fromByteString,+ zipVector, unzipVector, zipVectorWith, unzipVectorWith,+ foldVector, foldVectorG, foldVectorWithIndex, foldLoop,+ mapVector, mapVectorM, mapVectorM_,+ mapVectorWithIndex, mapVectorWithIndexM, mapVectorWithIndexM_+) where++import Foreign.Marshal.Array+import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable+import Foreign.C.Types(CInt)+import Data.Int(Int64)+import Data.Complex+import System.IO.Unsafe(unsafePerformIO)+import GHC.ForeignPtr(mallocPlainForeignPtrBytes)+import GHC.Base(realWorld#, IO(IO), when)+import qualified Data.Vector.Storable as Vector+import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith)++import Data.Binary+import Data.Binary.Put+import Control.Monad(replicateM)+import qualified Data.ByteString.Internal as BS+import Data.Vector.Storable.Internal(updPtr)++type I = CInt+type Z = Int64+type R = Double+type C = Complex Double+++-- | specialized fromIntegral+fi :: Int -> CInt+fi = fromIntegral++-- | specialized fromIntegral+ti :: CInt -> Int+ti = fromIntegral+++-- | Number of elements+dim :: (Storable t) => Vector t -> Int+dim = Vector.length+{-# INLINE dim #-}+++-- C-Haskell vector adapter+{-# INLINE avec #-}+avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r)+avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr)++-- allocates memory for a new vector+createVector :: Storable a => Int -> IO (Vector a)+createVector n = do+ when (n < 0) $ error ("trying to createVector of negative dim: "++show n)+ fp <- doMalloc undefined+ return $ unsafeFromForeignPtr fp 0 n+ where+ --+ -- Use the much cheaper Haskell heap allocated storage+ -- for foreign pointer space we control+ --+ doMalloc :: Storable b => b -> IO (ForeignPtr b)+ doMalloc dummy = do+ mallocPlainForeignPtrBytes (n * sizeOf dummy)++{- | creates a Vector from a list:++@> fromList [2,3,5,7]+4 |> [2.0,3.0,5.0,7.0]@++-}++safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c+safeRead v = inlinePerformIO . unsafeWith v+{-# INLINE safeRead #-}++inlinePerformIO :: IO a -> a+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r+{-# INLINE inlinePerformIO #-}++{- extracts the Vector elements to a list++>>> toList (linspace 5 (1,10))+[1.0,3.25,5.5,7.75,10.0]++-}+toList :: Storable a => Vector a -> [a]+toList v = safeRead v $ peekArray (dim v)++{- | Create a vector from a list of elements and explicit dimension. The input+ list is truncated if it is too long, so it may safely+ be used, for instance, with infinite lists.++>>> 5 |> [1..]+[1.0,2.0,3.0,4.0,5.0]+it :: (Enum a, Num a, Foreign.Storable.Storable a) => Vector a++-}+(|>) :: (Storable a) => Int -> [a] -> Vector a+infixl 9 |>+n |> l+ | length l' == n = fromList l'+ | otherwise = error "list too short for |>"+ where+ l' = take n l+++-- | Create a vector of indexes, useful for matrix extraction using '(??)'+idxs :: [Int] -> Vector I+idxs js = fromList (map fromIntegral js) :: Vector I++{- | takes a number of consecutive elements from a Vector++>>> subVector 2 3 (fromList [1..10])+[3.0,4.0,5.0]+it :: (Enum t, Num t, Foreign.Storable.Storable t) => Vector t++-}+subVector :: Storable t => Int -- ^ index of the starting element+ -> Int -- ^ number of elements to extract+ -> Vector t -- ^ source+ -> Vector t -- ^ result+subVector = Vector.slice+{-# INLINE subVector #-}+++++{- | Reads a vector position:++>>> fromList [0..9] @> 7+7.0++-}+(@>) :: Storable t => Vector t -> Int -> t+infixl 9 @>+v @> n+ | n >= 0 && n < dim v = at' v n+ | otherwise = error "vector index out of range"+{-# INLINE (@>) #-}++-- | access to Vector elements without range checking+at' :: Storable a => Vector a -> Int -> a+at' v n = safeRead v $ flip peekElemOff n+{-# INLINE at' #-}++{- | concatenate a list of vectors++>>> vjoin [fromList [1..5::Double], konst 1 3]+[1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]+it :: Vector Double++-}+vjoin :: Storable t => [Vector t] -> Vector t+vjoin [] = fromList []+vjoin [v] = v+vjoin as = unsafePerformIO $ do+ let tot = sum (map dim as)+ r <- createVector tot+ unsafeWith r $ \ptr ->+ joiner as tot ptr+ return r+ where joiner [] _ _ = return ()+ joiner (v:cs) _ p = do+ let n = dim v+ unsafeWith v $ \pb -> copyArray p pb n+ joiner cs 0 (advancePtr p n)+++{- | Extract consecutive subvectors of the given sizes.++>>> takesV [3,4] (linspace 10 (1,10::Double))+[[1.0,2.0,3.0],[4.0,5.0,6.0,7.0]]+it :: [Vector Double]++-}+takesV :: Storable t => [Int] -> Vector t -> [Vector t]+takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)+ | otherwise = go ms w+ where go [] _ = []+ go (n:ns) v = subVector 0 n v+ : go ns (subVector n (dim v - n) v)++---------------------------------------------------------------++-- | transforms a complex vector into a real vector with alternating real and imaginary parts+asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a+asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)+ where (fp,i,n) = unsafeToForeignPtr v++-- | transforms a real vector into a complex vector with alternating real and imaginary parts+asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)+asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)+ where (fp,i,n) = unsafeToForeignPtr v++--------------------------------------------------------------------------------+++-- | map on Vectors+mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b+mapVector f v = unsafePerformIO $ do+ w <- createVector (dim v)+ unsafeWith v $ \p ->+ unsafeWith w $ \q -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff p k+ pokeElemOff q k (f x)+ go (k-1)+ go (dim v -1)+ return w+{-# INLINE mapVector #-}++-- | zipWith for Vectors+zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c+zipVectorWith f u v = unsafePerformIO $ do+ let n = min (dim u) (dim v)+ w <- createVector n+ unsafeWith u $ \pu ->+ unsafeWith v $ \pv ->+ unsafeWith w $ \pw -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff pu k+ y <- peekElemOff pv k+ pokeElemOff pw k (f x y)+ go (k-1)+ go (n -1)+ return w+{-# INLINE zipVectorWith #-}++-- | unzipWith for Vectors+unzipVectorWith :: (Storable (a,b), Storable c, Storable d)+ => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)+unzipVectorWith f u = unsafePerformIO $ do+ let n = dim u+ v <- createVector n+ w <- createVector n+ unsafeWith u $ \pu ->+ unsafeWith v $ \pv ->+ unsafeWith w $ \pw -> do+ let go (-1) = return ()+ go !k = do z <- peekElemOff pu k+ let (x,y) = f z+ pokeElemOff pv k x+ pokeElemOff pw k y+ go (k-1)+ go (n-1)+ return (v,w)+{-# INLINE unzipVectorWith #-}++foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b+foldVector f x v = unsafePerformIO $+ unsafeWith v $ \p -> do+ let go (-1) s = return s+ go !k !s = do y <- peekElemOff p k+ go (k-1::Int) (f y s)+ go (dim v -1) x+{-# INLINE foldVector #-}++-- the zero-indexed index is passed to the folding function+foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b+foldVectorWithIndex f x v = unsafePerformIO $+ unsafeWith v $ \p -> do+ let go (-1) s = return s+ go !k !s = do y <- peekElemOff p k+ go (k-1::Int) (f k y s)+ go (dim v -1) x+{-# INLINE foldVectorWithIndex #-}++foldLoop :: (Int -> t -> t) -> t -> Int -> t+foldLoop f s0 d = go (d - 1) s0+ where+ go 0 s = f (0::Int) s+ go !j !s = go (j - 1) (f j s)++foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t+foldVectorG f s0 v = foldLoop g s0 (dim v)+ where g !k !s = f k (safeRead v . flip peekElemOff) s+ {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)+{-# INLINE foldVectorG #-}++-------------------------------------------------------------------++-- | monadic map over Vectors+-- the monad @m@ must be strict+mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)+mapVectorM f v = do+ w <- return $! unsafePerformIO $! createVector (dim v)+ mapVectorM' w 0 (dim v -1)+ return w+ where mapVectorM' w' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f x+ return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f x+ _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ mapVectorM' w' (k+1) t+{-# INLINE mapVectorM #-}++-- | monadic map over Vectors+mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()+mapVectorM_ f v = do+ mapVectorM' 0 (dim v -1)+ where mapVectorM' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ f x+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ _ <- f x+ mapVectorM' (k+1) t+{-# INLINE mapVectorM_ #-}++-- | monadic map over Vectors with the zero-indexed index passed to the mapping function+-- the monad @m@ must be strict+mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)+mapVectorWithIndexM f v = do+ w <- return $! unsafePerformIO $! createVector (dim v)+ mapVectorM' w 0 (dim v -1)+ return w+ where mapVectorM' w' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f k x+ return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ y <- f k x+ _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y+ mapVectorM' w' (k+1) t+{-# INLINE mapVectorWithIndexM #-}++-- | monadic map over Vectors with the zero-indexed index passed to the mapping function+mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()+mapVectorWithIndexM_ f v = do+ mapVectorM' 0 (dim v -1)+ where mapVectorM' !k !t+ | k == t = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ f k x+ | otherwise = do+ x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k+ _ <- f k x+ mapVectorM' (k+1) t+{-# INLINE mapVectorWithIndexM_ #-}+++mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b+--mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])+mapVectorWithIndex f v = unsafePerformIO $ do+ w <- createVector (dim v)+ unsafeWith v $ \p ->+ unsafeWith w $ \q -> do+ let go (-1) = return ()+ go !k = do x <- peekElemOff p k+ pokeElemOff q k (f k x)+ go (k-1)+ go (dim v -1)+ return w+{-# INLINE mapVectorWithIndex #-}++--------------------------------------------------------------------------------++++-- a 64K cache, with a Double taking 13 bytes in Bytestring,+-- implies a chunk size of 5041+chunk :: Int+chunk = 5000++chunks :: Int -> [Int]+chunks d = let c = d `div` chunk+ m = d `mod` chunk+ in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk)++putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM ()+putVector v = mapM_ put $! toList v++getVector :: (Storable a, Binary a) => Int -> Get (Vector a)+getVector d = do+ xs <- replicateM d get+ return $! fromList xs++--------------------------------------------------------------------------------++toByteString :: Storable t => Vector t -> BS.ByteString+toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v)+ where+ (fp,o,_n) = unsafeToForeignPtr v+ sz = sizeOf (v@>0)+++fromByteString :: Storable t => BS.ByteString -> Vector t+fromByteString (BS.PS fp o n) = r+ where+ r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n'+ n' = n `div` sz+ sz = sizeOf (r@>0)++--------------------------------------------------------------------------------++instance (Binary a, Storable a) => Binary (Vector a) where++ put v = do+ let d = dim v+ put d+ mapM_ putVector $! takesV (chunks d) v++ -- put = put . v2bs++ get = do+ d <- get+ vs <- mapM getVector $ chunks d+ return $! vjoin vs++ -- get = fmap bs2v get++++-------------------------------------------------------------------++{- | creates a Vector of the specified length using the supplied function to+ to map the index to the value at that index.++@> buildVector 4 fromIntegral+4 |> [0.0,1.0,2.0,3.0]@++-}+buildVector :: Storable a => Int -> (Int -> a) -> Vector a+buildVector len f =+ fromList $ map f [0 .. (len - 1)]+++-- | zip for Vectors+zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b)+zipVector = zipVectorWith (,)++-- | unzip for Vectors+unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b)+unzipVector = unzipVectorWith id++-------------------------------------------------------------------
+ src/Internal/Vectorized.hs view
@@ -0,0 +1,557 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Numeric.Vectorized+-- Copyright : (c) Alberto Ruiz 2007-15+-- License : BSD3+-- Maintainer : Alberto Ruiz+-- Stability : provisional+--+-- Low level interface to vector operations.+--+-----------------------------------------------------------------------------++module Internal.Vectorized where++import Internal.Vector+import Internal.Devel+import Data.Complex+import Foreign.Marshal.Alloc(free,malloc)+import Foreign.Marshal.Array(newArray,copyArray)+import Foreign.Ptr(Ptr)+import Foreign.Storable(peek,Storable)+import Foreign.C.Types+import Foreign.C.String+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(when)++infixr 1 #+(#) :: TransArray c => c -> (b -> IO r) -> TransRaw c b -> IO r+a # b = applyRaw a b+{-# INLINE (#) #-}++(#!) :: (TransArray c, TransArray c1) => c1 -> c -> TransRaw c1 (TransRaw c (IO r)) -> IO r+a #! b = a # b # id+{-# INLINE (#!) #-}++fromei :: Enum a => a -> CInt+fromei x = fromIntegral (fromEnum x) :: CInt++data FunCodeV = Sin+ | Cos+ | Tan+ | Abs+ | ASin+ | ACos+ | ATan+ | Sinh+ | Cosh+ | Tanh+ | ASinh+ | ACosh+ | ATanh+ | Exp+ | Log+ | Sign+ | Sqrt+ deriving Enum++data FunCodeSV = Scale+ | Recip+ | AddConstant+ | Negate+ | PowSV+ | PowVS+ | ModSV+ | ModVS+ deriving Enum++data FunCodeVV = Add+ | Sub+ | Mul+ | Div+ | Pow+ | ATan2+ | Mod+ deriving Enum++data FunCodeS = Norm2+ | AbsSum+ | MaxIdx+ | Max+ | MinIdx+ | Min+ deriving Enum++------------------------------------------------------------------++-- | sum of elements+sumF :: Vector Float -> Float+sumF = sumg c_sumF++-- | sum of elements+sumR :: Vector Double -> Double+sumR = sumg c_sumR++-- | sum of elements+sumQ :: Vector (Complex Float) -> Complex Float+sumQ = sumg c_sumQ++-- | sum of elements+sumC :: Vector (Complex Double) -> Complex Double+sumC = sumg c_sumC++sumI :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr I -> I :> Ok)+ , TransArray c+ , Storable a+ )+ => I -> c -> a+sumI m = sumg (c_sumI m)++sumL :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr Z -> Z :> Ok)+ , TransArray c+ , Storable a+ ) => Z -> c -> a+sumL m = sumg (c_sumL m)++sumg :: (TransArray c, Storable a) => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a+sumg f x = unsafePerformIO $ do+ r <- createVector 1+ (x #! r) f #| "sum"+ return $ r @> 0++type TVV t = t :> t :> Ok++foreign import ccall unsafe "sumF" c_sumF :: TVV Float+foreign import ccall unsafe "sumR" c_sumR :: TVV Double+foreign import ccall unsafe "sumQ" c_sumQ :: TVV (Complex Float)+foreign import ccall unsafe "sumC" c_sumC :: TVV (Complex Double)+foreign import ccall unsafe "sumI" c_sumI :: I -> TVV I+foreign import ccall unsafe "sumL" c_sumL :: Z -> TVV Z++-- | product of elements+prodF :: Vector Float -> Float+prodF = prodg c_prodF++-- | product of elements+prodR :: Vector Double -> Double+prodR = prodg c_prodR++-- | product of elements+prodQ :: Vector (Complex Float) -> Complex Float+prodQ = prodg c_prodQ++-- | product of elements+prodC :: Vector (Complex Double) -> Complex Double+prodC = prodg c_prodC++prodI :: I-> Vector I -> I+prodI = prodg . c_prodI++prodL :: Z-> Vector Z -> Z+prodL = prodg . c_prodL++prodg :: (TransArray c, Storable a)+ => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a+prodg f x = unsafePerformIO $ do+ r <- createVector 1+ (x #! r) f #| "prod"+ return $ r @> 0+++foreign import ccall unsafe "prodF" c_prodF :: TVV Float+foreign import ccall unsafe "prodR" c_prodR :: TVV Double+foreign import ccall unsafe "prodQ" c_prodQ :: TVV (Complex Float)+foreign import ccall unsafe "prodC" c_prodC :: TVV (Complex Double)+foreign import ccall unsafe "prodI" c_prodI :: I -> TVV I+foreign import ccall unsafe "prodL" c_prodL :: Z -> TVV Z++------------------------------------------------------------------++toScalarAux :: (Enum a, TransArray c, Storable a1)+ => (CInt -> TransRaw c (CInt -> Ptr a1 -> IO CInt)) -> a -> c -> a1+toScalarAux fun code v = unsafePerformIO $ do+ r <- createVector 1+ (v #! r) (fun (fromei code)) #|"toScalarAux"+ return (r @> 0)+++vectorMapAux :: (Enum a, Storable t, Storable a1)+ => (CInt -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt)+ -> a -> Vector t -> Vector a1+vectorMapAux fun code v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) (fun (fromei code)) #|"vectorMapAux"+ return r++vectorMapValAux :: (Enum a, Storable a2, Storable t, Storable a1)+ => (CInt -> Ptr a2 -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt)+ -> a -> a2 -> Vector t -> Vector a1+vectorMapValAux fun code val v = unsafePerformIO $ do+ r <- createVector (dim v)+ pval <- newArray [val]+ (v #! r) (fun (fromei code) pval) #|"vectorMapValAux"+ free pval+ return r++vectorZipAux :: (Enum a, TransArray c, Storable t, Storable a1)+ => (CInt -> CInt -> Ptr t -> TransRaw c (CInt -> Ptr a1 -> IO CInt))+ -> a -> Vector t -> c -> Vector a1+vectorZipAux fun code u v = unsafePerformIO $ do+ r <- createVector (dim u)+ (u # v #! r) (fun (fromei code)) #|"vectorZipAux"+ return r++---------------------------------------------------------------------++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarR :: FunCodeS -> Vector Double -> Double+toScalarR oper = toScalarAux c_toScalarR (fromei oper)++foreign import ccall unsafe "toScalarR" c_toScalarR :: CInt -> TVV Double++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarF :: FunCodeS -> Vector Float -> Float+toScalarF oper = toScalarAux c_toScalarF (fromei oper)++foreign import ccall unsafe "toScalarF" c_toScalarF :: CInt -> TVV Float++-- | obtains different functions of a vector: only norm1, norm2+toScalarC :: FunCodeS -> Vector (Complex Double) -> Double+toScalarC oper = toScalarAux c_toScalarC (fromei oper)++foreign import ccall unsafe "toScalarC" c_toScalarC :: CInt -> Complex Double :> Double :> Ok++-- | obtains different functions of a vector: only norm1, norm2+toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float+toScalarQ oper = toScalarAux c_toScalarQ (fromei oper)++foreign import ccall unsafe "toScalarQ" c_toScalarQ :: CInt -> Complex Float :> Float :> Ok++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarI :: FunCodeS -> Vector CInt -> CInt+toScalarI oper = toScalarAux c_toScalarI (fromei oper)++foreign import ccall unsafe "toScalarI" c_toScalarI :: CInt -> TVV CInt++-- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.+toScalarL :: FunCodeS -> Vector Z -> Z+toScalarL oper = toScalarAux c_toScalarL (fromei oper)++foreign import ccall unsafe "toScalarL" c_toScalarL :: CInt -> TVV Z+++------------------------------------------------------------------++-- | map of real vectors with given function+vectorMapR :: FunCodeV -> Vector Double -> Vector Double+vectorMapR = vectorMapAux c_vectorMapR++foreign import ccall unsafe "mapR" c_vectorMapR :: CInt -> TVV Double++-- | map of complex vectors with given function+vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double)+vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper)++foreign import ccall unsafe "mapC" c_vectorMapC :: CInt -> TVV (Complex Double)++-- | map of real vectors with given function+vectorMapF :: FunCodeV -> Vector Float -> Vector Float+vectorMapF = vectorMapAux c_vectorMapF++foreign import ccall unsafe "mapF" c_vectorMapF :: CInt -> TVV Float++-- | map of real vectors with given function+vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float)+vectorMapQ = vectorMapAux c_vectorMapQ++foreign import ccall unsafe "mapQ" c_vectorMapQ :: CInt -> TVV (Complex Float)++-- | map of real vectors with given function+vectorMapI :: FunCodeV -> Vector CInt -> Vector CInt+vectorMapI = vectorMapAux c_vectorMapI++foreign import ccall unsafe "mapI" c_vectorMapI :: CInt -> TVV CInt++-- | map of real vectors with given function+vectorMapL :: FunCodeV -> Vector Z -> Vector Z+vectorMapL = vectorMapAux c_vectorMapL++foreign import ccall unsafe "mapL" c_vectorMapL :: CInt -> TVV Z++-------------------------------------------------------------------++-- | map of real vectors with given function+vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double+vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper)++foreign import ccall unsafe "mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV Double++-- | map of complex vectors with given function+vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double)+vectorMapValC = vectorMapValAux c_vectorMapValC++foreign import ccall unsafe "mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TVV (Complex Double)++-- | map of real vectors with given function+vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float+vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper)++foreign import ccall unsafe "mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TVV Float++-- | map of complex vectors with given function+vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float)+vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper)++foreign import ccall unsafe "mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TVV (Complex Float)++-- | map of real vectors with given function+vectorMapValI :: FunCodeSV -> CInt -> Vector CInt -> Vector CInt+vectorMapValI oper = vectorMapValAux c_vectorMapValI (fromei oper)++foreign import ccall unsafe "mapValI" c_vectorMapValI :: CInt -> Ptr CInt -> TVV CInt++-- | map of real vectors with given function+vectorMapValL :: FunCodeSV -> Z -> Vector Z -> Vector Z+vectorMapValL oper = vectorMapValAux c_vectorMapValL (fromei oper)++foreign import ccall unsafe "mapValL" c_vectorMapValL :: CInt -> Ptr Z -> TVV Z+++-------------------------------------------------------------------++type TVVV t = t :> t :> t :> Ok++-- | elementwise operation on real vectors+vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double+vectorZipR = vectorZipAux c_vectorZipR++foreign import ccall unsafe "zipR" c_vectorZipR :: CInt -> TVVV Double++-- | elementwise operation on complex vectors+vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double)+vectorZipC = vectorZipAux c_vectorZipC++foreign import ccall unsafe "zipC" c_vectorZipC :: CInt -> TVVV (Complex Double)++-- | elementwise operation on real vectors+vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float+vectorZipF = vectorZipAux c_vectorZipF++foreign import ccall unsafe "zipF" c_vectorZipF :: CInt -> TVVV Float++-- | elementwise operation on complex vectors+vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float)+vectorZipQ = vectorZipAux c_vectorZipQ++foreign import ccall unsafe "zipQ" c_vectorZipQ :: CInt -> TVVV (Complex Float)++-- | elementwise operation on CInt vectors+vectorZipI :: FunCodeVV -> Vector CInt -> Vector CInt -> Vector CInt+vectorZipI = vectorZipAux c_vectorZipI++foreign import ccall unsafe "zipI" c_vectorZipI :: CInt -> TVVV CInt++-- | elementwise operation on CInt vectors+vectorZipL :: FunCodeVV -> Vector Z -> Vector Z -> Vector Z+vectorZipL = vectorZipAux c_vectorZipL++foreign import ccall unsafe "zipL" c_vectorZipL :: CInt -> TVVV Z++--------------------------------------------------------------------------------++foreign import ccall unsafe "vectorScan" c_vectorScan+ :: CString -> Ptr CInt -> Ptr (Ptr Double) -> IO CInt++vectorScan :: FilePath -> IO (Vector Double)+vectorScan s = do+ pp <- malloc+ pn <- malloc+ cs <- newCString s+ ok <- c_vectorScan cs pn pp+ when (not (ok == 0)) $+ error ("vectorScan: file \"" ++ s ++"\" not found")+ n <- fromIntegral <$> peek pn+ p <- peek pp+ v <- createVector n+ free pn+ free cs+ unsafeWith v $ \pv -> copyArray pv p n+ free p+ free pp+ return v++--------------------------------------------------------------------------------++type Seed = Int++data RandDist = Uniform -- ^ uniform distribution in [0,1)+ | Gaussian -- ^ normal distribution with mean zero and standard deviation one+ deriving Enum++-- | Obtains a vector of pseudorandom elements (use randomIO to get a random seed).+randomVector :: Seed+ -> RandDist -- ^ distribution+ -> Int -- ^ vector size+ -> Vector Double+randomVector seed dist n = unsafePerformIO $ do+ r <- createVector n+ (r # id) (c_random_vector (fi seed) ((fi.fromEnum) dist)) #|"randomVector"+ return r++foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> Double :> Ok++--------------------------------------------------------------------------------++roundVector :: Vector Double -> Vector Double+roundVector v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) c_round_vector #|"roundVector"+ return r++foreign import ccall unsafe "round_vector" c_round_vector :: TVV Double++--------------------------------------------------------------------------------++-- |+-- >>> range 5+-- [0,1,2,3,4]+-- it :: Vector I+--+range :: Int -> Vector I+range n = unsafePerformIO $ do+ r <- createVector n+ (r # id) c_range_vector #|"range"+ return r++foreign import ccall unsafe "range_vector" c_range_vector :: CInt :> Ok+++float2DoubleV :: Vector Float -> Vector Double+float2DoubleV = tog c_float2double++double2FloatV :: Vector Double -> Vector Float+double2FloatV = tog c_double2float++double2IntV :: Vector Double -> Vector CInt+double2IntV = tog c_double2int++int2DoubleV :: Vector CInt -> Vector Double+int2DoubleV = tog c_int2double++double2longV :: Vector Double -> Vector Z+double2longV = tog c_double2long++long2DoubleV :: Vector Z -> Vector Double+long2DoubleV = tog c_long2double+++float2IntV :: Vector Float -> Vector CInt+float2IntV = tog c_float2int++int2floatV :: Vector CInt -> Vector Float+int2floatV = tog c_int2float++int2longV :: Vector I -> Vector Z+int2longV = tog c_int2long++long2intV :: Vector Z -> Vector I+long2intV = tog c_long2int+++tog :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+tog f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"tog"+ return r++foreign import ccall unsafe "float2double" c_float2double :: Float :> Double :> Ok+foreign import ccall unsafe "double2float" c_double2float :: Double :> Float :> Ok+foreign import ccall unsafe "int2double" c_int2double :: CInt :> Double :> Ok+foreign import ccall unsafe "double2int" c_double2int :: Double :> CInt :> Ok+foreign import ccall unsafe "long2double" c_long2double :: Z :> Double :> Ok+foreign import ccall unsafe "double2long" c_double2long :: Double :> Z :> Ok+foreign import ccall unsafe "int2float" c_int2float :: CInt :> Float :> Ok+foreign import ccall unsafe "float2int" c_float2int :: Float :> CInt :> Ok+foreign import ccall unsafe "int2long" c_int2long :: I :> Z :> Ok+foreign import ccall unsafe "long2int" c_long2int :: Z :> I :> Ok+++---------------------------------------------------------------++stepg :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+stepg f v = unsafePerformIO $ do+ r <- createVector (dim v)+ (v #! r) f #|"step"+ return r++stepD :: Vector Double -> Vector Double+stepD = stepg c_stepD++stepF :: Vector Float -> Vector Float+stepF = stepg c_stepF++stepI :: Vector CInt -> Vector CInt+stepI = stepg c_stepI++stepL :: Vector Z -> Vector Z+stepL = stepg c_stepL+++foreign import ccall unsafe "stepF" c_stepF :: TVV Float+foreign import ccall unsafe "stepD" c_stepD :: TVV Double+foreign import ccall unsafe "stepI" c_stepI :: TVV CInt+foreign import ccall unsafe "stepL" c_stepL :: TVV Z++--------------------------------------------------------------------------------++conjugateAux :: (Storable t, Storable a)+ => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a+conjugateAux fun x = unsafePerformIO $ do+ v <- createVector (dim x)+ (x #! v) fun #|"conjugateAux"+ return v++conjugateQ :: Vector (Complex Float) -> Vector (Complex Float)+conjugateQ = conjugateAux c_conjugateQ+foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TVV (Complex Float)++conjugateC :: Vector (Complex Double) -> Vector (Complex Double)+conjugateC = conjugateAux c_conjugateC+foreign import ccall unsafe "conjugateC" c_conjugateC :: TVV (Complex Double)++--------------------------------------------------------------------------------++cloneVector :: Storable t => Vector t -> IO (Vector t)+cloneVector v = do+ let n = dim v+ r <- createVector n+ let f _ s _ d = copyArray d s n >> return 0+ (v #! r) f #|"cloneVector"+ return r++--------------------------------------------------------------------------------++constantAux :: (Storable a1, Storable a)+ => (Ptr a1 -> CInt -> Ptr a -> IO CInt) -> a1 -> Int -> Vector a+constantAux fun x n = unsafePerformIO $ do+ v <- createVector n+ px <- newArray [x]+ (v # id) (fun px) #|"constantAux"+ free px+ return v++type TConst t = Ptr t -> t :> Ok++foreign import ccall unsafe "constantF" cconstantF :: TConst Float+foreign import ccall unsafe "constantR" cconstantR :: TConst Double+foreign import ccall unsafe "constantQ" cconstantQ :: TConst (Complex Float)+foreign import ccall unsafe "constantC" cconstantC :: TConst (Complex Double)+foreign import ccall unsafe "constantI" cconstantI :: TConst CInt+foreign import ccall unsafe "constantL" cconstantL :: TConst Z++----------------------------------------------------------------------
− src/Numeric/Chain.hs
@@ -1,144 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.Chain--- Copyright : (c) Vivian McPhail 2010--- License : BSD3------ Maintainer : Vivian McPhail <haskell.vivian.mcphail <at> gmail.com>--- Stability : provisional--- Portability : portable------ optimisation of association order for chains of matrix multiplication-----------------------------------------------------------------------------------module Numeric.Chain (- optimiseMult,- ) where--import Data.Maybe--import Data.Packed.Matrix-import Data.Packed.Internal.Numeric--import qualified Data.Array.IArray as A--------------------------------------------------------------------------------{- | - Provide optimal association order for a chain of matrix multiplications - and apply the multiplications.-- The algorithm is the well-known O(n\^3) dynamic programming algorithm- that builds a pyramid of optimal associations.--> m1, m2, m3, m4 :: Matrix Double-> m1 = (10><15) [1..]-> m2 = (15><20) [1..]-> m3 = (20><5) [1..]-> m4 = (5><10) [1..]--> >>> optimiseMult [m1,m2,m3,m4]--will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@--The naive left-to-right multiplication would take @4500@ scalar multiplications-whereas the optimised version performs @2750@ scalar multiplications. The complexity-in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions,-5 lookups, 2 updates) + a constant (= three table allocations)--}-optimiseMult :: Product t => [Matrix t] -> Matrix t-optimiseMult = chain---------------------------------------------------------------------------------type Matrices a = A.Array Int (Matrix a)-type Sizes = A.Array Int (Int,Int)-type Cost = A.Array Int (A.Array Int (Maybe Int))-type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))--update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a)-update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])]--newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int))-newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]- where subArray i = A.listArray (1,i) (repeat Nothing)--newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int))))-newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n]- where subArray i = A.listArray (1,i) (repeat Nothing)--matricesToSizes :: [Matrix a] -> Sizes-matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms--chain :: Product a => [Matrix a] -> Matrix a-chain [] = error "chain: zero matrices to multiply"-chain [m] = m-chain [ml,mr] = ml `multiply` mr-chain ms = let ln = length ms- ma = A.listArray (1,ln) ms- mz = matricesToSizes ms- i = chain_cost mz- in chain_paren (ln,ln) i ma--chain_cost :: Sizes -> Indexes-chain_cost mz = let (_,u) = A.bounds mz- cost = newWorkSpaceCost u- ixes = newWorkSpaceIndexes u- (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u)- in i--chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)-chain_cost' sci@(mz,cost,ixes) (r,c) - | c == 1 = let cost' = update cost (r,c) (Just 0)- ixes' = update ixes (r,c) (Just ((r,c),(r,c)))- in (mz,cost',ixes')- | otherwise = minimum_cost sci (r,c)--minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes)-minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu)--smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes)-smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) =- let op_cost = fromJust ((cost A.! lr) A.! lc)- + fromJust ((cost A.! rr) A.! rc)- + fst (mz A.! (lr-lc+1))- * snd (mz A.! lc)- * snd (mz A.! rr)- cost' = (cost A.! r) A.! c- in case cost' of- Nothing -> let cost'' = update cost (r,c) (Just op_cost)- ixes'' = update ixes (r,c) (Just ix)- in (mz,cost'',ixes'')- Just ct -> if op_cost < ct then- let cost'' = update cost (r,c) (Just op_cost)- ixes'' = update ixes (r,c) (Just ix)- in (mz,cost'',ixes'')- else (mz,cost,ixes)- --fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)]- in map (partner (r,c)) fs'--partner (r,c) (a,b) = ((r-b, c-b), (a,b))--order 0 = []-order n = order (n-1) ++ zip (repeat n) [1..n]--chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a-chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c- in if lr == rr && lc == rc then (ma A.! lr)- else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) ------------------------------------------------------------------------------{- TESTS---- optimal association is ((m1*(m2*m3))*m4)-m1, m2, m3, m4 :: Matrix Double-m1 = (10><15) [1..]-m2 = (15><20) [1..]-m3 = (20><5) [1..]-m4 = (5><10) [1..]---}-
− src/Numeric/Container.hs
@@ -1,49 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module Numeric.Container(- module Data.Packed,- constant,- linspace,- diag,- ident,- ctrans,- Container(scaleRecip, addConstant,add, sub, mul, divide, equal),- scalar,- conj,- scale,- arctan2,- cmap,- Konst(..),- Build(..),- atIndex,- minIndex, maxIndex, minElement, maxElement,- sumElements, prodElements,- step, cond, find, assoc, accum,- Element(..),- Product(..), dot, udot,- optimiseMult,- mXm, mXv, vXm, (<.>),- Mul(..),- LSDiv, (<\>),- outer, kronecker,- RandDist(..),- randomVector, gaussianSample, uniformSample,- meanCov,- Convert(..),- Complexable,- RealElement,- RealOf, ComplexOf, SingleOf, DoubleOf, IndexOf,- module Data.Complex,- dispf, disps, dispcf, vecdisp, latexFormat, format,- loadMatrix, saveMatrix, readMatrix-) where---import Data.Packed.Numeric-import Data.Packed-import Data.Packed.Internal(constantD)-import Data.Complex--constant :: Element a => a -> Int -> Vector a-constant = constantD-
− src/Numeric/Conversion.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module : Numeric.Conversion--- Copyright : (c) Alberto Ruiz 2010--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Conversion routines----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}---module Numeric.Conversion (- Complexable(..), RealElement,- module Data.Complex-) where--import Data.Packed.Internal.Vector-import Data.Packed.Internal.Matrix-import Data.Complex-import Control.Arrow((***))------------------------------------------------------------------------- | Supported single-double precision type pairs-class (Element s, Element d) => Precision s d | s -> d, d -> s where- double2FloatG :: Vector d -> Vector s- float2DoubleG :: Vector s -> Vector d--instance Precision Float Double where- double2FloatG = double2FloatV- float2DoubleG = float2DoubleV--instance Precision (Complex Float) (Complex Double) where- double2FloatG = asComplex . double2FloatV . asReal- float2DoubleG = asComplex . float2DoubleV . asReal---- | Supported real types-class (Element t, Element (Complex t), RealFloat t--- , RealOf t ~ t, RealOf (Complex t) ~ t- )- => RealElement t--instance RealElement Double-instance RealElement Float----- | Structures that may contain complex numbers-class Complexable c where- toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e)- fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e)- comp' :: (RealElement e) => c e -> c (Complex e)- single' :: Precision a b => c b -> c a- double' :: Precision a b => c a -> c b---instance Complexable Vector where- toComplex' = toComplexV- fromComplex' = fromComplexV- comp' v = toComplex' (v,constantD 0 (dim v))- single' = double2FloatG- double' = float2DoubleG----- | creates a complex vector from vectors with real and imaginary parts-toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a)-toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i]---- | the inverse of 'toComplex'-fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a)-fromComplexV z = (r,i) where- [r,i] = toColumns $ reshape 2 $ asReal z---instance Complexable Matrix where- toComplex' = uncurry $ liftMatrix2 $ curry toComplex'- fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z- where c = cols z- comp' = liftMatrix comp'- single' = liftMatrix single'- double' = liftMatrix double'-
src/Numeric/LinearAlgebra.hs view
@@ -1,22 +1,269 @@---------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra-Copyright : (c) Alberto Ruiz 2006-14+Copyright : (c) Alberto Ruiz 2006-15 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional --}----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-} +-}+----------------------------------------------------------------------------- module Numeric.LinearAlgebra (- module Numeric.Container,- module Numeric.LinearAlgebra.Algorithms++ -- * Basic types and data manipulation+ -- | This package works with 2D ('Matrix') and 1D ('Vector')+ -- arrays of real ('R') or complex ('C') double precision numbers.+ -- Single precision and machine integers are also supported for+ -- basic arithmetic and data manipulation.+ module Numeric.LinearAlgebra.Data,++ -- * Numeric classes+ -- |+ -- The standard numeric classes are defined elementwise (commonly referred to+ -- as the Hadamard product or the Schur product):+ --+ -- >>> vector [1,2,3] * vector [3,0,-2]+ -- [3.0,0.0,-6.0]+ -- it :: Vector R+ --+ -- >>> matrix 3 [1..9] * ident 3+ -- (3><3)+ -- [ 1.0, 0.0, 0.0+ -- , 0.0, 5.0, 0.0+ -- , 0.0, 0.0, 9.0 ]++ -- * Autoconformable dimensions+ -- |+ -- In most operations, single-element vectors and matrices+ -- (created from numeric literals or using 'scalar'), and matrices+ -- with just one row or column, automatically+ -- expand to match the dimensions of the other operand:+ --+ -- >>> 5 + 2*ident 3 :: Matrix Double+ -- (3><3)+ -- [ 7.0, 5.0, 5.0+ -- , 5.0, 7.0, 5.0+ -- , 5.0, 5.0, 7.0 ]+ --+ -- >>> (4><3) [1..] + row [10,20,30]+ -- (4><3)+ -- [ 11.0, 22.0, 33.0+ -- , 14.0, 25.0, 36.0+ -- , 17.0, 28.0, 39.0+ -- , 20.0, 31.0, 42.0 ]+ --++ -- * Products+ -- ** Dot+ dot, (<.>),+ -- ** Matrix-vector+ (#>), (<#), (!#>),+ -- ** Matrix-matrix+ (<>),+ -- | The matrix product is also implemented in the "Data.Monoid" instance, where+ -- single-element matrices (created from numeric literals or using 'scalar')+ -- are used for scaling.+ --+ -- >>> import Data.Monoid as M+ -- >>> let m = matrix 3 [1..6]+ -- >>> m M.<> 2 M.<> diagl[0.5,1,0]+ -- (2><3)+ -- [ 1.0, 4.0, 0.0+ -- , 4.0, 10.0, 0.0 ]+ --+ -- 'mconcat' uses 'optimiseMult' to get the optimal association order.+++ -- ** Other+ outer, kronecker, cross,+ scale, add,+ sumElements, prodElements,++ -- * Linear systems+ -- ** General+ (<\>),+ linearSolveLS,+ linearSolveSVD,+ -- ** Determined+ linearSolve,+ luSolve, luPacked,+ luSolve', luPacked',+ -- ** Symmetric indefinite+ ldlSolve, ldlPacked,+ -- ** Positive definite+ cholSolve,+ -- ** Triangular+ UpLo(..),+ triSolve,+ -- ** Tridiagonal+ triDiagSolve,+ -- ** Sparse+ cgSolve,+ cgSolve',++ -- * Inverse and pseudoinverse+ inv, pinv, pinvTol,++ -- * Determinant and rank+ rcond, rank,+ det, invlndet,++ -- * Norms+ Normed(..),+ norm_Frob, norm_nuclear,++ -- * Nullspace and range+ orth,+ nullspace, null1, null1sym,++ -- * Singular value decomposition+ svd,+ thinSVD,+ compactSVD,+ compactSVDTol,+ singularValues,+ leftSV, rightSV,++ -- * Eigendecomposition+ eig, geig, eigSH,+ eigenvalues, geigenvalues, eigenvaluesSH,+ geigSH,++ -- * QR+ qr, thinQR, rq, thinRQ, qrRaw, qrgr,++ -- * Cholesky+ chol, mbChol,++ -- * LU+ lu, luFact,++ -- * Hessenberg+ hess,++ -- * Schur+ schur,++ -- * Matrix functions+ expm,+ sqrtm,+ matFunc,++ -- * Correlation and convolution+ corr, conv, corrMin, corr2, conv2,++ -- * Random arrays++ Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample,++ -- * Misc+ meanCov, rowOuters, pairwiseD2, normalize, peps, relativeError, magnit,+ haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv,+ iC, sym, mTm, trustSym, unSym,+ -- * Auxiliary classes+ Element, Container, Product, Numeric, LSDiv, Herm,+ Complexable, RealElement,+ RealOf, ComplexOf, SingleOf, DoubleOf,+ IndexOf,+ Field, Linear(), Additive(),+ Transposable,+ LU(..),+ LDL(..),+ QR(..),+ CGState(..),+ Testable(..) ) where -import Numeric.Container-import Numeric.LinearAlgebra.Algorithms+import Numeric.LinearAlgebra.Data+ import Numeric.Matrix() import Numeric.Vector()+import Internal.Matrix+import Internal.Container hiding ((<>))+import Internal.Numeric hiding (mul)+import Internal.Algorithms hiding (linearSolve,Normed,orth,luPacked',linearSolve',luSolve',ldlPacked')+import qualified Internal.Algorithms as A+import Internal.Util+import Internal.Random+import Internal.Sparse((!#>))+import Internal.CG+import Internal.Conversion+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif++{- | dense matrix product++>>> let a = (3><5) [1..]+>>> a+(3><5)+ [ 1.0, 2.0, 3.0, 4.0, 5.0+ , 6.0, 7.0, 8.0, 9.0, 10.0+ , 11.0, 12.0, 13.0, 14.0, 15.0 ]++>>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0]+>>> b+(5><2)+ [ 1.0, 3.0+ , 0.0, 2.0+ , -1.0, 5.0+ , 7.0, 7.0+ , 6.0, 0.0 ]++>>> a <> b+(3><2)+ [ 56.0, 50.0+ , 121.0, 135.0+ , 186.0, 220.0 ]++-}+(<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t+(<>) = mXm+infixr 8 <>+++{- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.++@+a = (2><2)+ [ 1.0, 2.0+ , 3.0, 5.0 ]+@++@+b = (2><3)+ [ 6.0, 1.0, 10.0+ , 15.0, 3.0, 26.0 ]+@++>>> linearSolve a b+Just (2><3)+ [ -1.4802973661668753e-15, 0.9999999999999997, 1.999999999999997+ , 3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ]++>>> let Just x = it+>>> disp 5 x+2x3+-0.00000 1.00000 2.00000+ 3.00000 0.00000 4.00000++>>> a <> x+(2><3)+ [ 6.0, 1.0, 10.0+ , 15.0, 3.0, 26.0 ]++-}+linearSolve m b = A.mbLinearSolve m b++-- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'.+nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m)++-- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'.+orth m = orthSVD (Left (1*eps)) m (leftSV m)
− src/Numeric/LinearAlgebra/Algorithms.hs
@@ -1,961 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeFamilies #-}--------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Algorithms-Copyright : (c) Alberto Ruiz 2006-14-License : BSD3-Maintainer : Alberto Ruiz-Stability : provisional--High level generic interface to common matrix computations.--Specific functions for particular base types can also be explicitly-imported from "Numeric.LinearAlgebra.LAPACK".---}-{-# OPTIONS_HADDOCK hide #-}--------------------------------------------------------------------------------module Numeric.LinearAlgebra.Algorithms (--- * Supported types- Field(),--- * Linear Systems- linearSolve,- mbLinearSolve,- luSolve,- cholSolve,- linearSolveLS,- linearSolveSVD,- inv, pinv, pinvTol,- det, invlndet,- rank, rcond,--- * Matrix factorizations--- ** Singular value decomposition- svd,- fullSVD,- thinSVD,- compactSVD,- singularValues,- leftSV, rightSV,--- ** Eigensystems- eig, eigSH, eigSH',- eigenvalues, eigenvaluesSH, eigenvaluesSH',- geigSH',--- ** QR- qr, rq, qrRaw, qrgr,--- ** Cholesky- chol, cholSH, mbCholSH,--- ** Hessenberg- hess,--- ** Schur- schur,--- ** LU- lu, luPacked,--- * Matrix functions- expm,- sqrtm,- matFunc,--- * Nullspace- nullspacePrec,- nullVector,- nullspaceSVD,- orthSVD,- orth,--- * Norms- Normed(..), NormType(..),- relativeError', relativeError,--- * Misc- eps, peps, i,--- * Util- haussholder,- unpackQR, unpackHess,- ranksv-) where---import Data.Packed-import Numeric.LinearAlgebra.LAPACK as LAPACK-import Data.List(foldl1')-import Data.Array-import Data.Packed.Internal.Numeric-import Data.Packed.Internal(shSize)---{- | Generic linear algebra functions for double precision real and complex matrices.--(Single precision data can be converted using 'single' and 'double').---}-class (Product t,- Convert t,- Container Vector t,- Container Matrix t,- Normed Matrix t,- Normed Vector t,- Floating t,- RealOf t ~ Double) => Field t where- svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t)- thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t)- sv' :: Matrix t -> Vector Double- luPacked' :: Matrix t -> (Matrix t, [Int])- luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t- mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t)- linearSolve' :: Matrix t -> Matrix t -> Matrix t- cholSolve' :: Matrix t -> Matrix t -> Matrix t- linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t- linearSolveLS' :: Matrix t -> Matrix t -> Matrix t- eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double))- eigSH'' :: Matrix t -> (Vector Double, Matrix t)- eigOnly :: Matrix t -> Vector (Complex Double)- eigOnlySH :: Matrix t -> Vector Double- cholSH' :: Matrix t -> Matrix t- mbCholSH' :: Matrix t -> Maybe (Matrix t)- qr' :: Matrix t -> (Matrix t, Vector t)- qrgr' :: Int -> (Matrix t, Vector t) -> Matrix t- hess' :: Matrix t -> (Matrix t, Matrix t)- schur' :: Matrix t -> (Matrix t, Matrix t)---instance Field Double where- svd' = svdRd- thinSVD' = thinSVDRd- sv' = svR- luPacked' = luR- luSolve' (l_u,perm) = lusR l_u perm- linearSolve' = linearSolveR -- (luSolve . luPacked) ??- mbLinearSolve' = mbLinearSolveR- cholSolve' = cholSolveR- linearSolveLS' = linearSolveLSR- linearSolveSVD' = linearSolveSVDR Nothing- eig' = eigR- eigSH'' = eigS- eigOnly = eigOnlyR- eigOnlySH = eigOnlyS- cholSH' = cholS- mbCholSH' = mbCholS- qr' = qrR- qrgr' = qrgrR- hess' = unpackHess hessR- schur' = schurR--instance Field (Complex Double) where-#ifdef NOZGESDD- svd' = svdC- thinSVD' = thinSVDC-#else- svd' = svdCd- thinSVD' = thinSVDCd-#endif- sv' = svC- luPacked' = luC- luSolve' (l_u,perm) = lusC l_u perm- linearSolve' = linearSolveC- mbLinearSolve' = mbLinearSolveC- cholSolve' = cholSolveC- linearSolveLS' = linearSolveLSC- linearSolveSVD' = linearSolveSVDC Nothing- eig' = eigC- eigOnly = eigOnlyC- eigSH'' = eigH- eigOnlySH = eigOnlyH- cholSH' = cholH- mbCholSH' = mbCholH- qr' = qrC- qrgr' = qrgrC- hess' = unpackHess hessC- schur' = schurC------------------------------------------------------------------square m = rows m == cols m--vertical m = rows m >= cols m--exactHermitian m = m `equal` ctrans m------------------------------------------------------------------{- | Full singular value decomposition.--@-a = (5><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0- , 7.0, 8.0, 9.0- , 10.0, 11.0, 12.0- , 13.0, 14.0, 15.0 ] :: Matrix Double-@-->>> let (u,s,v) = svd a-->>> disp 3 u-5x5--0.101 0.768 0.614 0.028 -0.149--0.249 0.488 -0.503 0.172 0.646--0.396 0.208 -0.405 -0.660 -0.449--0.543 -0.072 -0.140 0.693 -0.447--0.690 -0.352 0.433 -0.233 0.398-->>> s-fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15]-->>> disp 3 v-3x3--0.519 -0.751 0.408--0.576 -0.046 -0.816--0.632 0.659 0.408-->>> let d = diagRect 0 s 5 3->>> disp 3 d-5x3-35.183 0.000 0.000- 0.000 1.477 0.000- 0.000 0.000 0.000- 0.000 0.000 0.000-->>> disp 3 $ u <> d <> tr v-5x3- 1.000 2.000 3.000- 4.000 5.000 6.000- 7.000 8.000 9.000-10.000 11.000 12.000-13.000 14.000 15.000---}-svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-svd = {-# SCC "svd" #-} svd'--{- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@.--If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> tr v@.--@-a = (5><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0- , 7.0, 8.0, 9.0- , 10.0, 11.0, 12.0- , 13.0, 14.0, 15.0 ] :: Matrix Double-@-->>> let (u,s,v) = thinSVD a-->>> disp 3 u-5x3--0.101 0.768 0.614--0.249 0.488 -0.503--0.396 0.208 -0.405--0.543 -0.072 -0.140--0.690 -0.352 0.433-->>> s-fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15]-->>> disp 3 v-3x3--0.519 -0.751 0.408--0.576 -0.046 -0.816--0.632 0.659 0.408-->>> disp 3 $ u <> diag s <> tr v-5x3- 1.000 2.000 3.000- 4.000 5.000 6.000- 7.000 8.000 9.000-10.000 11.000 12.000-13.000 14.000 15.000---}-thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-thinSVD = {-# SCC "thinSVD" #-} thinSVD'---- | Singular values only.-singularValues :: Field t => Matrix t -> Vector Double-singularValues = {-# SCC "singularValues" #-} sv'---- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values.------ If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> tr v@.-fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t)-fullSVD m = (u,d,v) where- (u,s,v) = svd m- d = diagRect 0 s r c- r = rows m- c = cols m--{- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors.--@-a = (5><3)- [ 1.0, 2.0, 3.0- , 4.0, 5.0, 6.0- , 7.0, 8.0, 9.0- , 10.0, 11.0, 12.0- , 13.0, 14.0, 15.0 ] :: Matrix Double-@-->>> let (u,s,v) = compactSVD a-->>> disp 3 u-5x2--0.101 0.768--0.249 0.488--0.396 0.208--0.543 -0.072--0.690 -0.352-->>> s-fromList [35.18264833189422,1.4769076999800903]-->>> disp 3 u-5x2--0.101 0.768--0.249 0.488--0.396 0.208--0.543 -0.072--0.690 -0.352-->>> disp 3 $ u <> diag s <> tr v-5x3- 1.000 2.000 3.000- 4.000 5.000 6.000- 7.000 8.000 9.000-10.000 11.000 12.000-13.000 14.000 15.000---}-compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t)-compactSVD m = (u', subVector 0 d s, v') where- (u,s,v) = thinSVD m- d = rankSVD (1*eps) m s `max` 1- u' = takeColumns d u- v' = takeColumns d v----- | Singular values and all right singular vectors (as columns).-rightSV :: Field t => Matrix t -> (Vector Double, Matrix t)-rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v)- | otherwise = let (_,s,v) = svd m in (s,v)---- | Singular values and all left singular vectors (as columns).-leftSV :: Field t => Matrix t -> (Matrix t, Vector Double)-leftSV m | vertical m = let (u,s,_) = svd m in (u,s)- | otherwise = let (u,s,_) = thinSVD m in (u,s)--------------------------------------------------------------------- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'.-luPacked :: Field t => Matrix t -> (Matrix t, [Int])-luPacked = {-# SCC "luPacked" #-} luPacked'---- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'.-luSolve :: Field t => (Matrix t, [Int]) -> Matrix t -> Matrix t-luSolve = {-# SCC "luSolve" #-} luSolve'---- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.--- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system.-linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolve = {-# SCC "linearSolve" #-} linearSolve'---- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. -mbLinearSolve :: Field t => Matrix t -> Matrix t -> Maybe (Matrix t)-mbLinearSolve = {-# SCC "linearSolve" #-} mbLinearSolve'---- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'.-cholSolve :: Field t => Matrix t -> Matrix t -> Matrix t-cholSolve = {-# SCC "cholSolve" #-} cholSolve'---- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value.-linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD'----- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'.-linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t-linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS'------------------------------------------------------------------{- | Eigenvalues (not ordered) and eigenvectors (as columns) of a general square matrix.--If @(s,v) = eig m@ then @m \<> v == v \<> diag s@--@-a = (3><3)- [ 3, 0, -2- , 4, 5, -1- , 3, 1, 0 ] :: Matrix Double-@-->>> let (l, v) = eig a-->>> putStr . dispcf 3 . asRow $ l-1x3-1.925+1.523i 1.925-1.523i 4.151-->>> putStr . dispcf 3 $ v-3x3--0.455+0.365i -0.455-0.365i 0.181- 0.603 0.603 -0.978- 0.033+0.543i 0.033-0.543i -0.104-->>> putStr . dispcf 3 $ complex a <> v-3x3--1.432+0.010i -1.432-0.010i 0.753- 1.160+0.918i 1.160-0.918i -4.059--0.763+1.096i -0.763-1.096i -0.433-->>> putStr . dispcf 3 $ v <> diag l-3x3--1.432+0.010i -1.432-0.010i 0.753- 1.160+0.918i 1.160-0.918i -4.059--0.763+1.096i -0.763-1.096i -0.433---}-eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double))-eig = {-# SCC "eig" #-} eig'---- | Eigenvalues (not ordered) of a general square matrix.-eigenvalues :: Field t => Matrix t -> Vector (Complex Double)-eigenvalues = {-# SCC "eigenvalues" #-} eigOnly---- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t)-eigSH' = {-# SCC "eigSH'" #-} eigSH''---- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-eigenvaluesSH' :: Field t => Matrix t -> Vector Double-eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH--{- | Eigenvalues and eigenvectors (as columns) of a complex hermitian or real symmetric matrix, in descending order.--If @(s,v) = eigSH m@ then @m == v \<> diag s \<> tr v@--@-a = (3><3)- [ 1.0, 2.0, 3.0- , 2.0, 4.0, 5.0- , 3.0, 5.0, 6.0 ]-@-->>> let (l, v) = eigSH a-->>> l-fromList [11.344814282762075,0.17091518882717918,-0.5157294715892575]-->>> disp 3 $ v <> diag l <> tr v-3x3-1.000 2.000 3.000-2.000 4.000 5.000-3.000 5.000 6.000---}-eigSH :: Field t => Matrix t -> (Vector Double, Matrix t)-eigSH m | exactHermitian m = eigSH' m- | otherwise = error "eigSH requires complex hermitian or real symmetric matrix"---- | Eigenvalues (in descending order) of a complex hermitian or real symmetric matrix.-eigenvaluesSH :: Field t => Matrix t -> Vector Double-eigenvaluesSH m | exactHermitian m = eigenvaluesSH' m- | otherwise = error "eigenvaluesSH requires complex hermitian or real symmetric matrix"-------------------------------------------------------------------- | QR factorization.------ If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular.-qr :: Field t => Matrix t -> (Matrix t, Matrix t)-qr = {-# SCC "qr" #-} unpackQR . qr'--qrRaw m = qr' m--{- | generate a matrix with k orthogonal columns from the output of qrRaw--}-qrgr n (a,t)- | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)"- | otherwise = qrgr' n (a,t)---- | RQ factorization.------ If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular.-rq :: Field t => Matrix t -> (Matrix t, Matrix t)-rq m = {-# SCC "rq" #-} (r,q) where- (q',r') = qr $ trans $ rev1 m- r = rev2 (trans r')- q = rev2 (trans q')- rev1 = flipud . fliprl- rev2 = fliprl . flipud---- | Hessenberg factorization.------ If @(p,h) = hess m@ then @m == p \<> h \<> ctrans p@, where p is unitary--- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal).-hess :: Field t => Matrix t -> (Matrix t, Matrix t)-hess = hess'---- | Schur factorization.------ If @(u,s) = schur m@ then @m == u \<> s \<> ctrans u@, where u is unitary--- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is--- upper triangular in 2x2 blocks.------ \"Anything that the Jordan decomposition can do, the Schur decomposition--- can do better!\" (Van Loan)-schur :: Field t => Matrix t -> (Matrix t, Matrix t)-schur = schur'----- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'.-mbCholSH :: Field t => Matrix t -> Maybe (Matrix t)-mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH'---- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part.-cholSH :: Field t => Matrix t -> Matrix t-cholSH = {-# SCC "cholSH" #-} cholSH'---- | Cholesky factorization of a positive definite hermitian or symmetric matrix.------ If @c = chol m@ then @c@ is upper triangular and @m == ctrans c \<> c@.-chol :: Field t => Matrix t -> Matrix t-chol m | exactHermitian m = cholSH m- | otherwise = error "chol requires positive definite complex hermitian or real symmetric matrix"----- | Joint computation of inverse and logarithm of determinant of a square matrix.-invlndet :: Field t- => Matrix t- -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det))-invlndet m | square m = (im,(ladm,sdm))- | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix"- where- lp@(lup,perm) = luPacked m- s = signlp (rows m) perm- dg = toList $ takeDiag $ lup- ladm = sum $ map (log.abs) dg- sdm = s* product (map signum dg)- im = luSolve lp (ident (rows m))----- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'.-det :: Field t => Matrix t -> t-det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup)- | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix"- where (lup,perm) = luPacked m- s = signlp (rows m) perm---- | Explicit LU factorization of a general matrix.------ If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular,--- u is upper triangular, p is a permutation matrix and s is the signature of the permutation.-lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t)-lu = luFact . luPacked---- | Inverse of a square matrix. See also 'invlndet'.-inv :: Field t => Matrix t -> Matrix t-inv m | square m = m `linearSolve` ident (rows m)- | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix"----- | Pseudoinverse of a general matrix with default tolerance ('pinvTol' 1, similar to GNU-Octave).-pinv :: Field t => Matrix t -> Matrix t-pinv = pinvTol 1--{- | @pinvTol r@ computes the pseudoinverse of a matrix with tolerance @tol=r*g*eps*(max rows cols)@, where g is the greatest singular value.--@-m = (3><3) [ 1, 0, 0- , 0, 1, 0- , 0, 0, 1e-10] :: Matrix Double-@-->>> pinv m-1. 0. 0.-0. 1. 0.-0. 0. 10000000000.-->>> pinvTol 1E8 m-1. 0. 0.-0. 1. 0.-0. 0. 1.---}--pinvTol :: Field t => Double -> Matrix t -> Matrix t-pinvTol t m = conj v' `mXm` diag s' `mXm` ctrans u' where- (u,s,v) = thinSVD m- sl@(g:_) = toList s- s' = real . fromList . map rec $ sl- rec x = if x <= g*tol then x else 1/x- tol = (fromIntegral (max r c) * g * t * eps)- r = rows m- c = cols m- d = dim s- u' = takeColumns d u- v' = takeColumns d v----- | Numeric rank of a matrix from the SVD decomposition.-rankSVD :: Element t- => Double -- ^ numeric zero (e.g. 1*'eps')- -> Matrix t -- ^ input matrix m- -> Vector Double -- ^ 'sv' of m- -> Int -- ^ rank of m-rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s)---- | Numeric rank of a matrix from its singular values.-ranksv :: Double -- ^ numeric zero (e.g. 1*'eps')- -> Int -- ^ maximum dimension of the matrix- -> [Double] -- ^ singular values- -> Int -- ^ rank of m-ranksv teps maxdim s = k where- g = maximum s- tol = fromIntegral maxdim * g * teps- s' = filter (>tol) s- k = if g > teps then length s' else 0---- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave).-eps :: Double-eps = 2.22044604925031e-16----- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1-peps :: RealFloat x => x-peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x)----- | The imaginary unit: @i = 0.0 :+ 1.0@-i :: Complex Double-i = 0:+1----------------------------------------------------------------------------- | The nullspace of a matrix from its precomputed SVD decomposition.-nullspaceSVD :: Field t- => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),- -- or Right \"theoretical\" matrix rank.- -> Matrix t -- ^ input matrix m- -> (Vector Double, Matrix t) -- ^ 'rightSV' of m- -> Matrix t -- ^ nullspace-nullspaceSVD hint a (s,v) = vs where- tol = case hint of- Left t -> t- _ -> eps- k = case hint of- Right t -> t- _ -> rankSVD tol a s- vs = conj (dropColumns k v)----- | The nullspace of a matrix. See also 'nullspaceSVD'.-nullspacePrec :: Field t- => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps')- -> Matrix t -- ^ input matrix- -> [Vector t] -- ^ list of unitary vectors spanning the nullspace-nullspacePrec t m = toColumns $ nullspaceSVD (Left (t*eps)) m (rightSV m)---- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision.-nullVector :: Field t => Matrix t -> Vector t-nullVector = last . nullspacePrec 1---- | The range space a matrix from its precomputed SVD decomposition.-orthSVD :: Field t- => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'),- -- or Right \"theoretical\" matrix rank.- -> Matrix t -- ^ input matrix m- -> (Matrix t, Vector Double) -- ^ 'leftSV' of m- -> Matrix t -- ^ orth-orthSVD hint a (v,s) = vs where- tol = case hint of- Left t -> t- _ -> eps- k = case hint of- Right t -> t- _ -> rankSVD tol a s- vs = takeColumns k v---orth :: Field t => Matrix t -> [Vector t]--- ^ Return an orthonormal basis of the range space of a matrix-orth m = take r $ toColumns u- where- (u,s,_) = compactSVD m- r = ranksv eps (max (rows m) (cols m)) (toList s)------------------------------------------------------------------------------ many thanks, quickcheck!--haussholder :: (Field a) => a -> Vector a -> Matrix a-haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w))- where w = asColumn v---zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs)- where xs = toList v--zt 0 v = v-zt k v = vjoin [subVector 0 (dim v - k) v, konst' 0 k]---unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t)-unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r)- where cs = toColumns pq- m = rows pq- n = cols pq- mn = min m n- r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs- vs = zipWith zh [1..mn] cs- hs = zipWith haussholder (toList tau) vs- q = foldl1' mXm hs--unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t)-unpackHess hf m- | rows m == 1 = ((1><1)[1],m)- | otherwise = (uH . hf) m--uH (pq, tau) = (p,h)- where cs = toColumns pq- m = rows pq- n = cols pq- mn = min m n- h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs- vs = zipWith zh [2..mn] cs- hs = zipWith haussholder (toList tau) vs- p = foldl1' mXm hs-------------------------------------------------------------------------------- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values.-rcond :: Field t => Matrix t -> Double-rcond m = last s / head s- where s = toList (singularValues m)---- | Number of linearly independent rows or columns. See also 'ranksv'-rank :: Field t => Matrix t -> Int-rank m = rankSVD eps m (singularValues m)--{--expm' m = case diagonalize (complex m) of- Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v- Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices"- where exp = vectorMapC Exp--}--diagonalize m = if rank v == n- then Just (l,v)- else Nothing- where n = rows m- (l,v) = if exactHermitian m- then let (l',v') = eigSH m in (real l', v')- else eig m---- | Generic matrix functions for diagonalizable matrices. For instance:------ @logm = matFunc log@----matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-matFunc f m = case diagonalize m of- Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v- Nothing -> error "Sorry, matFunc requires a diagonalizable matrix"------------------------------------------------------------------golubeps :: Integer -> Integer -> Double-golubeps p q = a * fromIntegral b / fromIntegral c where- a = 2^^(3-p-q)- b = fact p * fact q- c = fact (p+q) * fact (p+q+1)- fact n = product [1..n]--epslist :: [(Int,Double)]-epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]]--geps delta = head [ k | (k,g) <- epslist, g<delta]---{- | Matrix exponential. It uses a direct translation of Algorithm 11.3.1 in Golub & Van Loan,- based on a scaled Pade approximation.--}-expm :: Field t => Matrix t -> Matrix t-expm = expGolub--expGolub :: Field t => Matrix t -> Matrix t-expGolub m = iterate msq f !! j- where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m- a = m */ fromIntegral ((2::Int)^j)- q = geps eps -- 7 steps- eye = ident (rows m)- work (k,c,x,n,d) = (k',c',x',n',d')- where k' = k+1- c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k)- x' = a <> x- n' = n |+| (c' .* x')- d' = d |+| (((-1)^k * c') .* x')- (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q- f = linearSolve df nf- msq x = x <> x-- (<>) = multiply- v */ x = scale (recip x) v- (.*) = scale- (|+|) = add------------------------------------------------------------------{- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia.-It only works with invertible matrices that have a real solution. For diagonalizable matrices you can try @matFunc sqrt@.--@m = (2><2) [4,9- ,0,4] :: Matrix Double@-->>> sqrtm m-(2><2)- [ 2.0, 2.25- , 0.0, 2.0 ]---}-sqrtm :: Field t => Matrix t -> Matrix t-sqrtm = sqrtmInv--sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x))- where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a- | otherwise = fixedPoint (b:rest)- fixedPoint _ = error "fixedpoint with impossible inputs"- f (y,z) = (0.5 .* (y |+| inv z),- 0.5 .* (inv y |+| z))- (.*) = scale- (|+|) = add- (|-|) = sub----------------------------------------------------------------------signlp r vals = foldl f 1 (zip [0..r-1] vals)- where f s (a,b) | a /= b = -s- | otherwise = s--swap (arr,s) (a,b) | a /= b = (arr // [(a, arr!b),(b,arr!a)],-s)- | otherwise = (arr,s)--fixPerm r vals = (fromColumns $ elems res, sign)- where v = [0..r-1]- s = toColumns (ident r)- (res,sign) = foldl swap (listArray (0,r-1) s, 1) (zip v vals)--triang r c h v = (r><c) [el s t | s<-[0..r-1], t<-[0..c-1]]- where el p q = if q-p>=h then v else 1 - v--luFact (l_u,perm) | r <= c = (l ,u ,p, s)- | otherwise = (l',u',p, s)- where- r = rows l_u- c = cols l_u- tu = triang r c 0 1- tl = triang r c 0 0- l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst' 1 r) r r- u = l_u |*| tu- (p,s) = fixPerm r perm- l' = (l_u |*| tl) |+| diagRect 0 (konst' 1 c) r c- u' = takeRows c (l_u |*| tu)- (|+|) = add- (|*|) = mul-------------------------------------------------------------------------------data NormType = Infinity | PNorm1 | PNorm2 | Frobenius--class (RealFloat (RealOf t)) => Normed c t where- pnorm :: NormType -> c t -> RealOf t--instance Normed Vector Double where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = norm2--instance Normed Vector (Complex Double) where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2--instance Normed Vector Float where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2--instance Normed Vector (Complex Float) where- pnorm PNorm1 = norm1- pnorm PNorm2 = norm2- pnorm Infinity = normInf- pnorm Frobenius = pnorm PNorm2---instance Normed Matrix Double where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = (@>0) . singularValues- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix (Complex Double) where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = (@>0) . singularValues- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix Float where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = realToFrac . (@>0) . singularValues . double- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten--instance Normed Matrix (Complex Float) where- pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns- pnorm PNorm2 = realToFrac . (@>0) . singularValues . double- pnorm Infinity = pnorm PNorm1 . trans- pnorm Frobenius = pnorm PNorm2 . flatten---- | Approximate number of common digits in the maximum element.-relativeError' :: (Normed c t, Container c t) => c t -> c t -> Int-relativeError' x y = dig (norm (x `sub` y) / norm x)- where norm = pnorm Infinity- dig r = round $ -logBase 10 (realToFrac r :: Double)---relativeError :: (Normed c t, Num (c t)) => NormType -> c t -> c t -> Double-relativeError t a b = realToFrac r- where- norm = pnorm t- na = norm a- nb = norm b- nab = norm (a-b)- mx = max na nb- mn = min na nb- r = if mn < peps- then mx- else nab/mx----------------------------------------------------------------------------- | Generalized symmetric positive definite eigensystem Av = lBv,--- for A and B symmetric, B positive definite (conditions not checked).-geigSH' :: Field t- => Matrix t -- ^ A- -> Matrix t -- ^ B- -> (Vector Double, Matrix t)-geigSH' a b = (l,v')- where- u = cholSH b- iu = inv u- c = ctrans iu <> a <> iu- (l,v) = eigSH' c- v' = iu <> v- (<>) = mXm-
src/Numeric/LinearAlgebra/Data.hs view
@@ -1,83 +1,121 @@+{-# LANGUAGE TypeOperators #-}+ -------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Data-Copyright : (c) Alberto Ruiz 2014+Copyright : (c) Alberto Ruiz 2015 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -Basic data processing.+This module provides functions for creation and manipulation of vectors and matrices, IO, and other utilities. -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Data( + -- * Elements+ R,C,I,Z,type(./.),+ -- * Vector- -- | 1D arrays are storable vectors from the vector package.- - vector, (|>),+ {- | 1D arrays are storable vectors directly reexported from the vector package.+ -} + fromList, toList, (|>), vector, range, idxs,+ -- * Matrix- - matrix, (><), tr,- ++ {- | The main data type of hmatrix is a 2D dense array defined on top of+ a storable vector. The internal representation is suitable for direct+ interface with standard numeric libraries.+ -}++ (><), matrix, tr, tr',++ -- * Dimensions++ size, rows, cols,++ -- * Conversion from\/to lists++ fromLists, toLists,+ row, col,++ -- * Conversions vector\/matrix++ flatten, reshape, asRow, asColumn,+ fromRows, toRows, fromColumns, toColumns,+ -- * Indexing- - size,++ atIndex, Indexable(..),- + -- * Construction- scalar, Konst(..), Build(..), assoc, accum, linspace, -- ones, zeros,+ scalar, Konst(..), Build(..), assoc, accum, linspace, -- ones, zeros, -- * Diagonal ident, diag, diagl, diagRect, takeDiag, - -- * Data manipulation- fromList, toList, subVector, takesV, vjoin,- flatten, reshape, asRow, asColumn, row, col,- fromRows, toRows, fromColumns, toColumns, fromLists, toLists, fromArray2D,- takeRows, dropRows, takeColumns, dropColumns, subMatrix, (?), (¿), fliprl, flipud,- + -- * Vector extraction+ subVector, takesV, vjoin,++ -- * Matrix extraction+ Extractor(..), (??),++ (?), (¿), fliprl, flipud,++ subMatrix, takeRows, dropRows, takeColumns, dropColumns,++ remap,+ -- * Block matrix- fromBlocks, (¦), (——), diagBlock, repmat, toBlocks, toBlocksEvery,+ fromBlocks, (|||), (===), diagBlock, repmat, toBlocks, toBlocksEvery, -- * Mapping functions- conj, cmap, step, cond,- + conj, cmap, cmod,++ step, cond,+ -- * Find elements- find, maxIndex, minIndex, maxElement, minElement, atIndex,- sortVector,+ find, maxIndex, minIndex, maxElement, minElement,+ sortVector, sortIndex, -- * Sparse AssocMatrix, toDense, mkSparse, mkDiagR, mkDense,- + -- * IO disp, loadMatrix, loadMatrix', saveMatrix, latexFormat, dispf, disps, dispcf, format, dispDots, dispBlanks, dispShort,--- * Conversion+-- * Element conversion Convert(..), roundVector,+ fromInt,toInt,fromZ,toZ, -- * Misc arctan2,- rows, cols, separable,-+ fromArray2D, module Data.Complex,-+ Mod, Vector, Matrix, GMatrix, nRows, nCols ) where -import Data.Packed.Vector-import Data.Packed.Matrix-import Data.Packed.Numeric-import Numeric.LinearAlgebra.Util hiding ((&),(#))+import Internal.Vector+import Internal.Vectorized+import Internal.Matrix hiding (size)+import Internal.Element+import Internal.IO+import Internal.Numeric+import Internal.Container+import Internal.Util hiding ((&)) import Data.Complex-import Numeric.Sparse+import Internal.Sparse+import Internal.Modular
src/Numeric/LinearAlgebra/Devel.hs view
@@ -12,28 +12,29 @@ -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Devel(- -- * FFI helpers- -- | Sample usage, to upload a perspective matrix to a shader.- --- -- @ glUniformMatrix4fv 0 1 (fromIntegral gl_TRUE) \`appMatrix\` perspective 0.01 100 (pi\/2) (4\/3)- -- @- module Data.Packed.Foreign,- -- * FFI tools- -- | Illustrative usage examples can be found- -- in the @examples\/devel@ folder included in the package.- module Data.Packed.Development,+ -- | See @examples/devel@ in the repository. + createVector, createMatrix,+ TransArray(..),+ MatrixOrder(..), orderOf, cmat, fmat,+ matrixFromVector,+ unsafeFromForeignPtr,+ unsafeToForeignPtr,+ check, (//), (#|),+ at', atM', fi, ti,+ -- * ST -- | In-place manipulation inside the ST monad.- -- See examples\/inplace.hs in the distribution.- + -- See @examples/inplace.hs@ in the repository.+ -- ** Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- ** Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix,+ mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..), -- ** Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector,@@ -50,17 +51,18 @@ liftMatrix, liftMatrix2, liftMatrix2Auto, -- * Sparse representation- CSR(..), fromCSR, mkCSR,+ CSR(..), fromCSR, mkCSR, impureCSR, GMatrix(..), -- * Misc- toByteString, fromByteString+ toByteString, fromByteString, showInternal, reorderVector ) where -import Data.Packed.Foreign-import Data.Packed.Development-import Data.Packed.ST-import Data.Packed-import Numeric.Sparse+import Internal.Devel+import Internal.ST+import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Sparse
src/Numeric/LinearAlgebra/HMatrix.hs view
@@ -1,4 +1,5 @@------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+-------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.HMatrix Copyright : (c) Alberto Ruiz 2006-14@@ -6,230 +7,30 @@ Maintainer : Alberto Ruiz Stability : provisional --}-------------------------------------------------------------------------------module Numeric.LinearAlgebra.HMatrix (-- -- * Basic types and data processing- module Numeric.LinearAlgebra.Data,-- -- * Arithmetic and numeric classes- -- |- -- The standard numeric classes are defined elementwise:- --- -- >>> vector [1,2,3] * vector [3,0,-2]- -- fromList [3.0,0.0,-6.0]- --- -- >>> matrix 3 [1..9] * ident 3- -- (3><3)- -- [ 1.0, 0.0, 0.0- -- , 0.0, 5.0, 0.0- -- , 0.0, 0.0, 9.0 ]- --- -- In arithmetic operations single-element vectors and matrices- -- (created from numeric literals or using 'scalar') automatically- -- expand to match the dimensions of the other operand:- --- -- >>> 5 + 2*ident 3 :: Matrix Double- -- (3><3)- -- [ 7.0, 5.0, 5.0- -- , 5.0, 7.0, 5.0- -- , 5.0, 5.0, 7.0 ]- --- -- >>> matrix 3 [1..9] + matrix 1 [10,20,30]- -- (3><3)- -- [ 11.0, 12.0, 13.0- -- , 24.0, 25.0, 26.0- -- , 37.0, 38.0, 39.0 ]- ---- -- * Products- -- ** dot- dot, (<·>),- -- ** matrix-vector- app, (#>), (!#>),- -- ** matrix-matrix- mul, (<>),- -- | The matrix product is also implemented in the "Data.Monoid" instance, where- -- single-element matrices (created from numeric literals or using 'scalar')- -- are used for scaling.- --- -- >>> import Data.Monoid as M- -- >>> let m = matrix 3 [1..6]- -- >>> m M.<> 2 M.<> diagl[0.5,1,0]- -- (2><3)- -- [ 1.0, 4.0, 0.0- -- , 4.0, 10.0, 0.0 ]- --- -- 'mconcat' uses 'optimiseMult' to get the optimal association order.--- -- ** other- outer, kronecker, cross,- scale,- sumElements, prodElements,-- -- * Linear Systems- (<\>),- linearSolve,- linearSolveLS,- linearSolveSVD,- luSolve,- cholSolve,- cgSolve,- cgSolve',-- -- * Inverse and pseudoinverse- inv, pinv, pinvTol,-- -- * Determinant and rank- rcond, rank,- det, invlndet,-- -- * Norms- Normed(..),- norm_Frob, norm_nuclear,-- -- * Nullspace and range- orth,- nullspace, null1, null1sym,-- -- * SVD- svd,- thinSVD,- compactSVD,- singularValues,- leftSV, rightSV,-- -- * Eigensystems- eig, eigSH, eigSH',- eigenvalues, eigenvaluesSH, eigenvaluesSH',- geigSH',-- -- * QR- qr, rq, qrRaw, qrgr,-- -- * Cholesky- chol, cholSH, mbCholSH,-- -- * Hessenberg- hess,-- -- * Schur- schur,-- -- * LU- lu, luPacked,-- -- * Matrix functions- expm,- sqrtm,- matFunc,-- -- * Correlation and convolution- corr, conv, corrMin, corr2, conv2,-- -- * Random arrays+compatibility with previous version, to be removed - Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample,+-}+-------------------------------------------------------------------------------- - -- * Misc- meanCov, peps, relativeError, haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv,- ℝ,ℂ,iC,- -- * Auxiliary classes- Element, Container, Product, Numeric, LSDiv,- Complexable, RealElement,- RealOf, ComplexOf, SingleOf, DoubleOf,- IndexOf,- Field,--- Normed,- Transposable,- CGState(..),- Testable(..)+module Numeric.LinearAlgebra.HMatrix (+ module Numeric.LinearAlgebra,+ (¦),(——),ℝ,ℂ,(<·>),app,mul, cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH' ) where -import Numeric.LinearAlgebra.Data--import Numeric.Matrix()-import Numeric.Vector()-import Data.Packed.Numeric hiding ((<>), mul)-import Numeric.LinearAlgebra.Algorithms hiding (linearSolve,Normed,orth)-import qualified Numeric.LinearAlgebra.Algorithms as A-import Numeric.LinearAlgebra.Util-import Numeric.LinearAlgebra.Random-import Numeric.Sparse((!#>))-import Numeric.LinearAlgebra.Util.CG--{- | infix synonym of 'mul'-->>> let a = (3><5) [1..]->>> a-(3><5)- [ 1.0, 2.0, 3.0, 4.0, 5.0- , 6.0, 7.0, 8.0, 9.0, 10.0- , 11.0, 12.0, 13.0, 14.0, 15.0 ]-->>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0]->>> b-(5><2)- [ 1.0, 3.0- , 0.0, 2.0- , -1.0, 5.0- , 7.0, 7.0- , 6.0, 0.0 ]+import Numeric.LinearAlgebra+import Internal.Util+import Internal.Algorithms(cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH')+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif ->>> a <> b-(3><2)- [ 56.0, 50.0- , 121.0, 135.0- , 186.0, 220.0 ]+infixr 8 <·>+(<·>) :: Numeric t => Vector t -> Vector t -> t+(<·>) = dot --}-(<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t-(<>) = mXm-infixr 8 <>+app :: Numeric t => Matrix t -> Vector t -> Vector t+app m v = m #> v --- | dense matrix product mul :: Numeric t => Matrix t -> Matrix t -> Matrix t-mul = mXm---{- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'.--@-a = (2><2)- [ 1.0, 2.0- , 3.0, 5.0 ]-@--@-b = (2><3)- [ 6.0, 1.0, 10.0- , 15.0, 3.0, 26.0 ]-@-->>> linearSolve a b-Just (2><3)- [ -1.4802973661668753e-15, 0.9999999999999997, 1.999999999999997- , 3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ]-->>> let Just x = it->>> disp 5 x-2x3--0.00000 1.00000 2.00000- 3.00000 0.00000 4.00000-->>> a <> x-(2><3)- [ 6.0, 1.0, 10.0- , 15.0, 3.0, 26.0 ]---}-linearSolve m b = A.mbLinearSolve m b---- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'.-nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m)---- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'.-orth m = orthSVD (Left (1*eps)) m (leftSV m)+mul a b = a <> b
− src/Numeric/LinearAlgebra/LAPACK.hs
@@ -1,560 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.LinearAlgebra.LAPACK--- Copyright : (c) Alberto Ruiz 2006-14--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Functional interface to selected LAPACK functions (<http://www.netlib.org/lapack>).----------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}---module Numeric.LinearAlgebra.LAPACK (- -- * Matrix product- multiplyR, multiplyC, multiplyF, multiplyQ,- -- * Linear systems- linearSolveR, linearSolveC,- mbLinearSolveR, mbLinearSolveC,- lusR, lusC,- cholSolveR, cholSolveC,- linearSolveLSR, linearSolveLSC,- linearSolveSVDR, linearSolveSVDC,- -- * SVD- svR, svRd, svC, svCd,- svdR, svdRd, svdC, svdCd,- thinSVDR, thinSVDRd, thinSVDC, thinSVDCd,- rightSVR, rightSVC, leftSVR, leftSVC,- -- * Eigensystems- eigR, eigC, eigS, eigS', eigH, eigH',- eigOnlyR, eigOnlyC, eigOnlyS, eigOnlyH,- -- * LU- luR, luC,- -- * Cholesky- cholS, cholH, mbCholS, mbCholH,- -- * QR- qrR, qrC, qrgrR, qrgrC,- -- * Hessenberg- hessR, hessC,- -- * Schur- schurR, schurC-) where--import Data.Packed.Development-import Data.Packed-import Data.Packed.Internal-import Numeric.Conversion--import Foreign.Ptr(nullPtr)-import Foreign.C.Types-import Control.Monad(when)-import System.IO.Unsafe(unsafePerformIO)---------------------------------------------------------------------------------------foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM-foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TCMCMCM-foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TFMFMFM-foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TQMQMQM--isT Matrix{order = ColumnMajor} = 0-isT Matrix{order = RowMajor} = 1--tt x@Matrix{order = ColumnMajor} = x-tt x@Matrix{order = RowMajor} = trans x--multiplyAux f st a b = unsafePerformIO $ do- when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++- show (rows a,cols a) ++ " x " ++ show (rows b, cols b)- s <- createMatrix ColumnMajor (rows a) (cols b)- app3 (f (isT a) (isT b)) mat (tt a) mat (tt b) mat s st- return s---- | Matrix product based on BLAS's /dgemm/.-multiplyR :: Matrix Double -> Matrix Double -> Matrix Double-multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b---- | Matrix product based on BLAS's /zgemm/.-multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-multiplyC a b = multiplyAux zgemmc "zgemmc" a b---- | Matrix product based on BLAS's /sgemm/.-multiplyF :: Matrix Float -> Matrix Float -> Matrix Float-multiplyF a b = multiplyAux sgemmc "sgemmc" a b---- | Matrix product based on BLAS's /cgemm/.-multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float)-multiplyQ a b = multiplyAux cgemmc "cgemmc" a b--------------------------------------------------------------------------------foreign import ccall unsafe "svd_l_R" dgesvd :: TMMVM-foreign import ccall unsafe "svd_l_C" zgesvd :: TCMCMVCM-foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TMMVM-foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TCMCMVCM---- | Full SVD of a real matrix using LAPACK's /dgesvd/.-svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-svdR = svdAux dgesvd "svdR" . fmat---- | Full SVD of a real matrix using LAPACK's /dgesdd/.-svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-svdRd = svdAux dgesdd "svdRdd" . fmat---- | Full SVD of a complex matrix using LAPACK's /zgesvd/.-svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-svdC = svdAux zgesvd "svdC" . fmat---- | Full SVD of a complex matrix using LAPACK's /zgesdd/.-svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-svdCd = svdAux zgesdd "svdCdd" . fmat--svdAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r r- s <- createVector (min r c)- v <- createMatrix ColumnMajor c c- app4 f mat x mat u vec s mat v st- return (u,s,trans v)- where r = rows x- c = cols x----- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'.-thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-thinSVDR = thinSVDAux dgesvd "thinSVDR" . fmat---- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'.-thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-thinSVDC = thinSVDAux zgesvd "thinSVDC" . fmat---- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'.-thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double)-thinSVDRd = thinSVDAux dgesdd "thinSVDRdd" . fmat---- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'.-thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double))-thinSVDCd = thinSVDAux zgesdd "thinSVDCdd" . fmat--thinSVDAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r q- s <- createVector q- v <- createMatrix ColumnMajor q c- app4 f mat x mat u vec s mat v st- return (u,s,trans v)- where r = rows x- c = cols x- q = min r c----- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'.-svR :: Matrix Double -> Vector Double-svR = svAux dgesvd "svR" . fmat---- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'.-svC :: Matrix (Complex Double) -> Vector Double-svC = svAux zgesvd "svC" . fmat---- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'.-svRd :: Matrix Double -> Vector Double-svRd = svAux dgesdd "svRd" . fmat---- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'.-svCd :: Matrix (Complex Double) -> Vector Double-svCd = svAux zgesdd "svCd" . fmat--svAux f st x = unsafePerformIO $ do- s <- createVector q- app2 g mat x vec s st- return s- where r = rows x- c = cols x- q = min r c- g ra ca pa nb pb = f ra ca pa 0 0 nullPtr nb pb 0 0 nullPtr----- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'.-rightSVR :: Matrix Double -> (Vector Double, Matrix Double)-rightSVR = rightSVAux dgesvd "rightSVR" . fmat---- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'.-rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-rightSVC = rightSVAux zgesvd "rightSVC" . fmat--rightSVAux f st x = unsafePerformIO $ do- s <- createVector q- v <- createMatrix ColumnMajor c c- app3 g mat x vec s mat v st- return (s,trans v)- where r = rows x- c = cols x- q = min r c- g ra ca pa = f ra ca pa 0 0 nullPtr----- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'.-leftSVR :: Matrix Double -> (Matrix Double, Vector Double)-leftSVR = leftSVAux dgesvd "leftSVR" . fmat---- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'.-leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double)-leftSVC = leftSVAux zgesvd "leftSVC" . fmat--leftSVAux f st x = unsafePerformIO $ do- u <- createMatrix ColumnMajor r r- s <- createVector q- app3 g mat x mat u vec s st- return (u,s)- where r = rows x- c = cols x- q = min r c- g ra ca pa ru cu pu nb pb = f ra ca pa ru cu pu nb pb 0 0 nullPtr---------------------------------------------------------------------------------foreign import ccall unsafe "eig_l_R" dgeev :: TMMCVM-foreign import ccall unsafe "eig_l_C" zgeev :: TCMCMCVCM-foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> TMVM-foreign import ccall unsafe "eig_l_H" zheev :: CInt -> TCMVCM--eigAux f st m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 g mat m vec l mat v st- return (l,v)- where r = rows m- g ra ca pa = f ra ca pa 0 0 nullPtr----- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/.--- The eigenvectors are the columns of v. The eigenvalues are not sorted.-eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double))-eigC = eigAux zgeev "eigC" . fmat--eigOnlyAux f st m = unsafePerformIO $ do- l <- createVector r- app2 g mat m vec l st- return l- where r = rows m- g ra ca pa nl pl = f ra ca pa 0 0 nullPtr nl pl 0 0 nullPtr---- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'.--- The eigenvalues are not sorted.-eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double)-eigOnlyC = eigOnlyAux zgeev "eigOnlyC" . fmat---- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/.--- The eigenvectors are the columns of v. The eigenvalues are not sorted.-eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double))-eigR m = (s', v'')- where (s,v) = eigRaux (fmat m)- s' = fixeig1 s- v' = toRows $ trans v- v'' = fromColumns $ fixeig (toList s') v'--eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double)-eigRaux m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 g mat m vec l mat v "eigR"- return (l,v)- where r = rows m- g ra ca pa = dgeev ra ca pa 0 0 nullPtr--fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s))- where r = dim s--fixeig [] _ = []-fixeig [_] [v] = [comp' v]-fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs)- | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1, mapVector negate v2) : fixeig r vs- | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs)-fixeig _ _ = error "fixeig with impossible inputs"----- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'.--- The eigenvalues are not sorted.-eigOnlyR :: Matrix Double -> Vector (Complex Double)-eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR" . fmat----------------------------------------------------------------------------------eigSHAux f st m = unsafePerformIO $ do- l <- createVector r- v <- createMatrix ColumnMajor r r- app3 f mat m vec l mat v st- return (l,v)- where r = rows m---- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/.--- The eigenvectors are the columns of v.--- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order).-eigS :: Matrix Double -> (Vector Double, Matrix Double)-eigS m = (s', fliprl v)- where (s,v) = eigS' (fmat m)- s' = fromList . reverse . toList $ s---- | 'eigS' in ascending order-eigS' :: Matrix Double -> (Vector Double, Matrix Double)-eigS' = eigSHAux (dsyev 1) "eigS'" . fmat---- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/.--- The eigenvectors are the columns of v.--- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order).-eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-eigH m = (s', fliprl v)- where (s,v) = eigH' (fmat m)- s' = fromList . reverse . toList $ s---- | 'eigH' in ascending order-eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double))-eigH' = eigSHAux (zheev 1) "eigH'" . fmat----- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'.--- The eigenvalues are sorted in descending order.-eigOnlyS :: Matrix Double -> Vector Double-eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'" . fmat---- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'.--- The eigenvalues are sorted in descending order.-eigOnlyH :: Matrix (Complex Double) -> Vector Double-eigOnlyH = vrev . fst. eigSHAux (zheev 0) "eigH'" . fmat--vrev = flatten . flipud . reshape 1--------------------------------------------------------------------------------foreign import ccall unsafe "linearSolveR_l" dgesv :: TMMM-foreign import ccall unsafe "linearSolveC_l" zgesv :: TCMCMCM-foreign import ccall unsafe "cholSolveR_l" dpotrs :: TMMM-foreign import ccall unsafe "cholSolveC_l" zpotrs :: TCMCMCM--linearSolveSQAux g f st a b- | n1==n2 && n1==r = unsafePerformIO . g $ do- s <- createMatrix ColumnMajor r c- app3 f mat a mat b mat s st- return s- | otherwise = error $ st ++ " of nonsquare matrix"- where n1 = rows a- n2 = cols a- r = rows b- c = cols b---- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'.-linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double-linearSolveR a b = linearSolveSQAux id dgesv "linearSolveR" (fmat a) (fmat b)--mbLinearSolveR :: Matrix Double -> Matrix Double -> Maybe (Matrix Double)-mbLinearSolveR a b = linearSolveSQAux mbCatch dgesv "linearSolveR" (fmat a) (fmat b)----- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'.-linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-linearSolveC a b = linearSolveSQAux id zgesv "linearSolveC" (fmat a) (fmat b)--mbLinearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Maybe (Matrix (Complex Double))-mbLinearSolveC a b = linearSolveSQAux mbCatch zgesv "linearSolveC" (fmat a) (fmat b)---- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'.-cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double-cholSolveR a b = linearSolveSQAux id dpotrs "cholSolveR" (fmat a) (fmat b)---- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'.-cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-cholSolveC a b = linearSolveSQAux id zpotrs "cholSolveC" (fmat a) (fmat b)--------------------------------------------------------------------------------------foreign import ccall unsafe "linearSolveLSR_l" dgels :: TMMM-foreign import ccall unsafe "linearSolveLSC_l" zgels :: TCMCMCM-foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> TMMM-foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> TCMCMCM--linearSolveAux f st a b = unsafePerformIO $ do- r <- createMatrix ColumnMajor (max m n) nrhs- app3 f mat a mat b mat r st- return r- where m = rows a- n = cols a- nrhs = cols b---- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'.-linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double-linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux dgels "linearSolverLSR" (fmat a) (fmat b)---- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'.-linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double)-linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux zgels "linearSolveLSC" (fmat a) (fmat b)---- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.-linearSolveSVDR :: Maybe Double -- ^ rcond- -> Matrix Double -- ^ coefficient matrix- -> Matrix Double -- ^ right hand sides (as columns)- -> Matrix Double -- ^ solution vectors (as columns)-linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux (dgelss rcond) "linearSolveSVDR" (fmat a) (fmat b)-linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) (fmat a) (fmat b)---- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used.-linearSolveSVDC :: Maybe Double -- ^ rcond- -> Matrix (Complex Double) -- ^ coefficient matrix- -> Matrix (Complex Double) -- ^ right hand sides (as columns)- -> Matrix (Complex Double) -- ^ solution vectors (as columns)-linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $- linearSolveAux (zgelss rcond) "linearSolveSVDC" (fmat a) (fmat b)-linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) (fmat a) (fmat b)--------------------------------------------------------------------------------------foreign import ccall unsafe "chol_l_H" zpotrf :: TCMCM-foreign import ccall unsafe "chol_l_S" dpotrf :: TMM--cholAux f st a = do- r <- createMatrix ColumnMajor n n- app2 f mat a mat r st- return r- where n = rows a---- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/.-cholH :: Matrix (Complex Double) -> Matrix (Complex Double)-cholH = unsafePerformIO . cholAux zpotrf "cholH" . fmat---- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/.-cholS :: Matrix Double -> Matrix Double-cholS = unsafePerformIO . cholAux dpotrf "cholS" . fmat---- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version).-mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double))-mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH" . fmat---- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version).-mbCholS :: Matrix Double -> Maybe (Matrix Double)-mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS" . fmat--------------------------------------------------------------------------------------foreign import ccall unsafe "qr_l_R" dgeqr2 :: TMVM-foreign import ccall unsafe "qr_l_C" zgeqr2 :: TCMCVCM---- | QR factorization of a real matrix, using LAPACK's /dgeqr2/.-qrR :: Matrix Double -> (Matrix Double, Vector Double)-qrR = qrAux dgeqr2 "qrR" . fmat---- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/.-qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))-qrC = qrAux zgeqr2 "qrC" . fmat--qrAux f st a = unsafePerformIO $ do- r <- createMatrix ColumnMajor m n- tau <- createVector mn- app3 f mat a vec tau mat r st- return (r,tau)- where- m = rows a- n = cols a- mn = min m n--foreign import ccall unsafe "c_dorgqr" dorgqr :: TMVM-foreign import ccall unsafe "c_zungqr" zungqr :: TCMCVCM---- | build rotation from reflectors-qrgrR :: Int -> (Matrix Double, Vector Double) -> Matrix Double-qrgrR = qrgrAux dorgqr "qrgrR"--- | build rotation from reflectors-qrgrC :: Int -> (Matrix (Complex Double), Vector (Complex Double)) -> Matrix (Complex Double)-qrgrC = qrgrAux zungqr "qrgrC"--qrgrAux f st n (a, tau) = unsafePerformIO $ do- res <- createMatrix ColumnMajor (rows a) n- app3 f mat (fmat a) vec (subVector 0 n tau') mat res st- return res- where- tau' = vjoin [tau, constantD 0 n]--------------------------------------------------------------------------------------foreign import ccall unsafe "hess_l_R" dgehrd :: TMVM-foreign import ccall unsafe "hess_l_C" zgehrd :: TCMCVCM---- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/.-hessR :: Matrix Double -> (Matrix Double, Vector Double)-hessR = hessAux dgehrd "hessR" . fmat---- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/.-hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double))-hessC = hessAux zgehrd "hessC" . fmat--hessAux f st a = unsafePerformIO $ do- r <- createMatrix ColumnMajor m n- tau <- createVector (mn-1)- app3 f mat a vec tau mat r st- return (r,tau)- where m = rows a- n = cols a- mn = min m n--------------------------------------------------------------------------------------foreign import ccall unsafe "schur_l_R" dgees :: TMMM-foreign import ccall unsafe "schur_l_C" zgees :: TCMCMCM---- | Schur factorization of a square real matrix, using LAPACK's /dgees/.-schurR :: Matrix Double -> (Matrix Double, Matrix Double)-schurR = schurAux dgees "schurR" . fmat---- | Schur factorization of a square complex matrix, using LAPACK's /zgees/.-schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double))-schurC = schurAux zgees "schurC" . fmat--schurAux f st a = unsafePerformIO $ do- u <- createMatrix ColumnMajor n n- s <- createMatrix ColumnMajor n n- app3 f mat a mat u mat s st- return (u,s)- where n = rows a--------------------------------------------------------------------------------------foreign import ccall unsafe "lu_l_R" dgetrf :: TMVM-foreign import ccall unsafe "lu_l_C" zgetrf :: TCMVCM---- | LU factorization of a general real matrix, using LAPACK's /dgetrf/.-luR :: Matrix Double -> (Matrix Double, [Int])-luR = luAux dgetrf "luR" . fmat---- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/.-luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int])-luC = luAux zgetrf "luC" . fmat--luAux f st a = unsafePerformIO $ do- lu <- createMatrix ColumnMajor n m- piv <- createVector (min n m)- app3 f mat a vec piv mat lu st- return (lu, map (pred.round) (toList piv))- where n = rows a- m = cols a--------------------------------------------------------------------------------------type TW a = CInt -> PD -> a-type TQ a = CInt -> CInt -> PC -> a--foreign import ccall unsafe "luS_l_R" dgetrs :: TMVMM-foreign import ccall unsafe "luS_l_C" zgetrs :: TQ (TW (TQ (TQ (IO CInt))))---- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/.-lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double-lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv (fmat b)---- | Solve a real linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/.-lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double)-lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv (fmat b)--lusAux f st a piv b- | n1==n2 && n2==n =unsafePerformIO $ do- x <- createMatrix ColumnMajor n m- app4 f mat a vec piv' mat b mat x st- return x- | otherwise = error $ st ++ " on LU factorization of nonsquare matrix"- where n1 = rows a- n2 = cols a- n = rows b- m = cols b- piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double-
− src/Numeric/LinearAlgebra/Random.hs
@@ -1,81 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.LinearAlgebra.Random--- Copyright : (c) Alberto Ruiz 2009-14--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Random vectors and matrices.-----------------------------------------------------------------------------------module Numeric.LinearAlgebra.Random (- Seed,- RandDist(..),- randomVector,- gaussianSample,- uniformSample,- rand, randn-) where--import Numeric.Vectorized-import Data.Packed-import Data.Packed.Internal.Numeric-import Numeric.LinearAlgebra.Algorithms-import System.Random(randomIO)----- | Obtains a matrix whose rows are pseudorandom samples from a multivariate--- Gaussian distribution.-gaussianSample :: Seed- -> Int -- ^ number of rows- -> Vector Double -- ^ mean vector- -> Matrix Double -- ^ covariance matrix- -> Matrix Double -- ^ result-gaussianSample seed n med cov = m where- c = dim med- meds = konst' 1 n `outer` med- rs = reshape c $ randomVector seed Gaussian (c * n)- m = rs `mXm` cholSH cov `add` meds---- | Obtains a matrix whose rows are pseudorandom samples from a multivariate--- uniform distribution.-uniformSample :: Seed- -> Int -- ^ number of rows- -> [(Double,Double)] -- ^ ranges for each column- -> Matrix Double -- ^ result-uniformSample seed n rgs = m where- (as,bs) = unzip rgs- a = fromList as- cs = zipWith subtract as bs- d = dim a- dat = toRows $ reshape n $ randomVector seed Uniform (n*d)- am = konst' 1 n `outer` a- m = fromColumns (zipWith scale cs dat) `add` am---- | pseudorandom matrix with uniform elements between 0 and 1-randm :: RandDist- -> Int -- ^ rows- -> Int -- ^ columns- -> IO (Matrix Double)-randm d r c = do- seed <- randomIO- return (reshape c $ randomVector seed d (r*c))---- | pseudorandom matrix with uniform elements between 0 and 1-rand :: Int -> Int -> IO (Matrix Double)-rand = randm Uniform--{- | pseudorandom matrix with normal elements-->>> disp 3 =<< randn 3 5-3x5-0.386 -1.141 0.491 -0.510 1.512-0.069 -0.919 1.022 -0.181 0.745-0.313 -0.670 -0.097 -1.575 -0.583---}-randn :: Int -> Int -> IO (Matrix Double)-randn = randm Gaussian-
src/Numeric/LinearAlgebra/Static.hs view
@@ -1,5 +1,4 @@-#if __GLASGOW_HASKELL__ >= 708-+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -13,9 +12,10 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Numeric.LinearAlgebra.Static@@ -25,19 +25,19 @@ Experimental interface with statically checked dimensions. -This module is under active development and the interface is subject to changes.+See code examples at http://dis.um.es/~alberto/hmatrix/static.html. -} module Numeric.LinearAlgebra.Static( -- * Vector- ℝ, R,+ ℝ, R, vec2, vec3, vec4, (&), (#), split, headTail, vector, linspace, range, dim, -- * Matrix L, Sq, build,- row, col, (¦),(——), splitRows, splitCols,+ row, col, (|||),(===), splitRows, splitCols, unrow, uncol, tr, eye,@@ -45,45 +45,63 @@ blockAt, matrix, -- * Complex- C, M, Her, her, 𝑖,+ ℂ, C, M, Her, her, 𝑖,+ toComplex,+ fromComplex,+ complex,+ real,+ imag,+ sqMagnitude,+ magnitude, -- * Products- (<>),(#>),(<·>),+ (<>),(#>),(<.>), -- * Linear Systems linSolve, (<\>), -- * Factorizations svd, withCompactSVD, svdTall, svdFlat, Eigen(..),- withNullspace, qr,+ withNullspace, withOrth, qr, chol,+ -- * Norms+ Normed(..),+ -- * Random arrays+ Seed, RandDist(..),+ randomVector, rand, randn, gaussianSample, uniformSample, -- * Misc- mean,+ mean, meanCov, Disp(..), Domain(..),- withVector, withMatrix,- toRows, toColumns,- Sized(..), Diag(..), Sym, sym, mTm, unSym+ withVector, withMatrix, exactLength, exactDims,+ toRows, toColumns, withRows, withColumns,+ Sized(..), Diag(..), Sym, sym, mTm, unSym, (<·>) ) where import GHC.TypeLits-import Numeric.LinearAlgebra.HMatrix hiding (- (<>),(#>),(<·>),Konst(..),diag, disp,(¦),(——),+import Numeric.LinearAlgebra hiding (+ (<>),(#>),(<.>),Konst(..),diag, disp,(===),(|||), row,col,vector,matrix,linspace,toRows,toColumns,- (<\>),fromList,takeDiag,svd,eig,eigSH,eigSH',- eigenvalues,eigenvaluesSH,eigenvaluesSH',build,- qr,size,app,mul,dot)-import qualified Numeric.LinearAlgebra.HMatrix as LA-import Data.Proxy(Proxy)-import Numeric.LinearAlgebra.Static.Internal+ (<\>),fromList,takeDiag,svd,eig,eigSH,+ eigenvalues,eigenvaluesSH,build,+ qr,size,dot,chol,range,R,C,sym,mTm,unSym,+ randomVector,rand,randn,gaussianSample,uniformSample,meanCov,+ toComplex, fromComplex, complex, real, magnitude+ )+import qualified Numeric.LinearAlgebra as LA+import qualified Numeric.LinearAlgebra.Devel as LA+import Data.Proxy(Proxy(..))+import Internal.Static import Control.Arrow((***))----+import Text.Printf+import Data.Type.Equality ((:~:)(Refl))+import qualified Data.Bifunctor as BF (first)+#if MIN_VERSION_base(4,11,0)+import Prelude hiding ((<>))+#endif ud1 :: R n -> Vector ℝ ud1 (R (Dim v)) = v infixl 4 &-(&) :: forall n . (KnownNat n, 1 <= n)+(&) :: forall n . KnownNat n => R n -> ℝ -> R (n+1) u & x = u # (konst x :: R 1) @@ -171,22 +189,23 @@ uncol v = unrow . tr $ v -infixl 2 ——-(——) :: (KnownNat r1, KnownNat r2, KnownNat c) => L r1 c -> L r2 c -> L (r1+r2) c-a —— b = mkL (extract a LA.—— extract b)+infixl 2 ===+(===) :: (KnownNat r1, KnownNat r2, KnownNat c) => L r1 c -> L r2 c -> L (r1+r2) c+a === b = mkL (extract a LA.=== extract b) -infixl 3 ¦--- (¦) :: (KnownNat r, KnownNat c1, KnownNat c2) => L r c1 -> L r c2 -> L r (c1+c2)-a ¦ b = tr (tr a —— tr b)+infixl 3 |||+-- (|||) :: (KnownNat r, KnownNat c1, KnownNat c2) => L r c1 -> L r c2 -> L r (c1+c2)+a ||| b = tr (tr a === tr b) type Sq n = L n n --type CSq n = CL n n -type GL = (KnownNat n, KnownNat m) => L m n-type GSq = KnownNat n => Sq n +type GL = forall n m . (KnownNat n, KnownNat m) => L m n+type GSq = forall n . KnownNat n => Sq n+ isKonst :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ,(Int,Int)) isKonst s@(unwrap -> x) | singleM x = Just (x `atIndex` (0,0), (size s))@@ -210,9 +229,13 @@ infixr 8 <·>-(<·>) :: R n -> R n -> ℝ+(<·>) :: KnownNat n => R n -> R n -> ℝ (<·>) = dotR +infixr 8 <.>+(<.>) :: KnownNat n => R n -> R n -> ℝ+(<.>) = dotR+ -------------------------------------------------------------------------------- class Diag m d | m -> d@@ -220,21 +243,39 @@ takeDiag :: m -> d -instance forall n . (KnownNat n) => Diag (L n n) (R n)+instance KnownNat n => Diag (L n n) (R n) where- takeDiag m = mkR (LA.takeDiag (extract m))+ takeDiag x = mkR (LA.takeDiag (extract x)) -instance forall m n . (KnownNat m, KnownNat n, m <= n+1) => Diag (L m n) (R m)+instance KnownNat n => Diag (M n n) (C n) where- takeDiag m = mkR (LA.takeDiag (extract m))+ takeDiag x = mkC (LA.takeDiag (extract x)) +-------------------------------------------------------------------------------- -instance forall m n . (KnownNat m, KnownNat n, n <= m+1) => Diag (L m n) (R n)- where- takeDiag m = mkR (LA.takeDiag (extract m)) +toComplex :: KnownNat n => (R n, R n) -> C n+toComplex (r,i) = mkC $ LA.toComplex (ud1 r, ud1 i) +fromComplex :: KnownNat n => C n -> (R n, R n)+fromComplex (C (Dim v)) = let (r,i) = LA.fromComplex v in (mkR r, mkR i)++complex :: KnownNat n => R n -> C n+complex r = mkC $ LA.toComplex (ud1 r, LA.konst 0 (size r))++real :: KnownNat n => C n -> R n+real = fst . fromComplex++imag :: KnownNat n => C n -> R n +imag = snd . fromComplex++sqMagnitude :: KnownNat n => C n -> R n+sqMagnitude c = let (r,i) = fromComplex c in r**2 + i**2++magnitude :: KnownNat n => C n -> R n+magnitude = sqrt . sqMagnitude+ -------------------------------------------------------------------------------- linSolve :: (KnownNat m, KnownNat n) => L m m -> L m n -> Maybe (L m n)@@ -291,13 +332,27 @@ her m = Her $ (m + LA.tr m)/2 +instance (KnownNat n) => Disp (Sym n)+ where+ disp n (Sym x) = do+ let a = extract x+ let su = LA.dispf n a+ printf "Sym %d" (cols a) >> putStr (dropWhile (/='\n') $ su) +instance (KnownNat n) => Disp (Her n)+ where+ disp n (Her x) = do+ let a = extract x+ let su = LA.dispcf n a+ printf "Her %d" (cols a) >> putStr (dropWhile (/='\n') $ su)++ instance KnownNat n => Eigen (Sym n) (R n) (L n n) where- eigenvalues (Sym (extract -> m)) = mkR . LA.eigenvaluesSH' $ m+ eigenvalues (Sym (extract -> m)) = mkR . LA.eigenvaluesSH . LA.trustSym $ m eigensystem (Sym (extract -> m)) = (mkR l, mkL v) where- (l,v) = LA.eigSH' m+ (l,v) = LA.eigSH . LA.trustSym $ m instance KnownNat n => Eigen (Sq n) (C n) (M n n) where@@ -306,6 +361,9 @@ where (l,v) = LA.eig m +chol :: KnownNat n => Sym n -> Sq n+chol (extract . unSym -> m) = mkL $ LA.chol $ LA.trustSym m+ -------------------------------------------------------------------------------- withNullspace@@ -318,6 +376,15 @@ Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k) +withOrth+ :: forall m n z . (KnownNat m, KnownNat n)+ => L m n+ -> (forall k. (KnownNat k) => L n k -> z)+ -> z+withOrth (LA.orth . extract -> a) f =+ case someNatVal $ fromIntegral $ cols a of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k) withCompactSVD :: forall m n z . (KnownNat m, KnownNat n)@@ -348,7 +415,7 @@ headTail :: (KnownNat n, 1<=n) => R n -> (ℝ, R (n-1))-headTail = ((!0) . extract *** id) . split+headTail = ((! 0) . extract *** id) . split splitRows :: forall p m n . (KnownNat p, KnownNat m, KnownNat n, p<=m) => L m n -> (L p n, L (m-p) n)@@ -364,11 +431,31 @@ toRows :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R n] toRows (LA.toRows . extract -> vs) = map mkR vs +withRows+ :: forall n z . KnownNat n+ => [R n]+ -> (forall m . KnownNat m => L m n -> z)+ -> z+withRows (LA.fromRows . map extract -> m) f =+ case someNatVal $ fromIntegral $ LA.rows m of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy m)) -> f (mkL m :: L m n) toColumns :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R m] toColumns (LA.toColumns . extract -> vs) = map mkR vs +withColumns+ :: forall m z . KnownNat m+ => [R m]+ -> (forall n . KnownNat n => L m n -> z)+ -> z+withColumns (LA.fromColumns . map extract -> m) f =+ case someNatVal $ fromIntegral $ LA.cols m of+ Nothing -> error "static/dynamic mismatch"+ Just (SomeNat (_ :: Proxy n)) -> f (mkL m :: L m n) ++ -------------------------------------------------------------------------------- build@@ -391,6 +478,15 @@ Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> f (mkR v :: R m) +-- | Useful for constraining two dependently typed vectors to match each+-- other in length when they are unknown at compile-time.+exactLength+ :: forall n m . (KnownNat n, KnownNat m)+ => R m+ -> Maybe (R n)+exactLength v = do+ Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy m)+ return $ mkR (unwrap v) withMatrix :: forall z@@ -406,6 +502,64 @@ Just (SomeNat (_ :: Proxy n)) -> f (mkL a :: L m n) +-- | Useful for constraining two dependently typed matrices to match each+-- other in dimensions when they are unknown at compile-time.+exactDims+ :: forall n m j k . (KnownNat n, KnownNat m, KnownNat j, KnownNat k)+ => L m n+ -> Maybe (L j k)+exactDims m = do+ Refl <- sameNat (Proxy :: Proxy m) (Proxy :: Proxy j)+ Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy k)+ return $ mkL (unwrap m)++randomVector+ :: forall n . KnownNat n+ => Seed+ -> RandDist+ -> R n+randomVector s d = mkR (LA.randomVector s d+ (fromInteger (natVal (Proxy :: Proxy n)))+ )++rand+ :: forall m n . (KnownNat m, KnownNat n)+ => IO (L m n)+rand = mkL <$> LA.rand (fromInteger (natVal (Proxy :: Proxy m)))+ (fromInteger (natVal (Proxy :: Proxy n)))++randn+ :: forall m n . (KnownNat m, KnownNat n)+ => IO (L m n)+randn = mkL <$> LA.randn (fromInteger (natVal (Proxy :: Proxy m)))+ (fromInteger (natVal (Proxy :: Proxy n)))++gaussianSample+ :: forall m n . (KnownNat m, KnownNat n)+ => Seed+ -> R n+ -> Sym n+ -> L m n+gaussianSample s (extract -> mu) (Sym (extract -> sigma)) =+ mkL $ LA.gaussianSample s (fromInteger (natVal (Proxy :: Proxy m)))+ mu (LA.trustSym sigma)++uniformSample+ :: forall m n . (KnownNat m, KnownNat n)+ => Seed+ -> R n -- ^ minimums of each row+ -> R n -- ^ maximums of each row+ -> L m n+uniformSample s (extract -> mins) (extract -> maxs) =+ mkL $ LA.uniformSample s (fromInteger (natVal (Proxy :: Proxy m)))+ (zip (LA.toList mins) (LA.toList maxs))++meanCov+ :: forall m n . (KnownNat m, KnownNat n, 1 <= m)+ => L m n+ -> (R n, Sym n)+meanCov (extract -> vs) = mkR *** (Sym . mkL . LA.unSym) $ LA.meanCov vs+ -------------------------------------------------------------------------------- class Domain field vec mat | mat -> vec field, vec -> mat field, field -> mat vec@@ -415,6 +569,15 @@ dot :: forall n . (KnownNat n) => vec n -> vec n -> field cross :: vec 3 -> vec 3 -> vec 3 diagR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => field -> vec k -> mat m n+ dvmap :: forall n. KnownNat n => (field -> field) -> vec n -> vec n+ dmmap :: forall n m. (KnownNat m, KnownNat n) => (field -> field) -> mat n m -> mat n m+ outer :: forall n m. (KnownNat m, KnownNat n) => vec n -> vec m -> mat n m+ zipWithVector :: forall n. KnownNat n => (field -> field -> field) -> vec n -> vec n -> vec n+ det :: forall n. KnownNat n => mat n n -> field+ invlndet :: forall n. KnownNat n => mat n n -> (mat n n, (field, field))+ expm :: forall n. KnownNat n => mat n n -> mat n n+ sqrtm :: forall n. KnownNat n => mat n n -> mat n n+ inv :: forall n. KnownNat n => mat n n -> mat n n instance Domain ℝ R L@@ -424,6 +587,15 @@ dot = dotR cross = crossR diagR = diagRectR+ dvmap = mapR+ dmmap = mapL+ outer = outerR+ zipWithVector = zipWithR+ det = detL+ invlndet = invlndetL+ expm = expmL+ sqrtm = sqrtmL+ inv = invL instance Domain ℂ C M where@@ -432,6 +604,15 @@ dot = dotC cross = crossC diagR = diagRectC+ dvmap = mapC+ dmmap = mapM'+ outer = outerC+ zipWithVector = zipWithC+ det = detM+ invlndet = invlndetM+ expm = expmM+ sqrtm = sqrtmM+ inv = invM -------------------------------------------------------------------------------- @@ -446,9 +627,9 @@ a' = subVector 0 n a b' = subVector 0 n b -mulR (isDiag -> Just (0,a,_)) (extract -> b) = mkL (asColumn a * takeRows (LA.size a) b)+-- mulR (isDiag -> Just (0,a,_)) (extract -> b) = mkL (asColumn a * takeRows (LA.size a) b) -mulR (extract -> a) (isDiag -> Just (0,b,_)) = mkL (takeColumns (LA.size b) a * asRow b)+-- mulR (extract -> a) (isDiag -> Just (0,b,_)) = mkL (takeColumns (LA.size b) a * asRow b) mulR a b = mkL (extract a LA.<> extract b) @@ -458,10 +639,8 @@ appR m v = mkR (extract m LA.#> extract v) -dotR :: R n -> R n -> ℝ-dotR (ud1 -> u) (ud1 -> v)- | singleV u || singleV v = sumElements (u * v)- | otherwise = udot u v+dotR :: KnownNat n => R n -> R n -> ℝ+dotR (extract -> u) (extract -> v) = LA.dot u v crossR :: R 3 -> R 3 -> R 3@@ -471,6 +650,33 @@ z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 +outerR :: (KnownNat m, KnownNat n) => R n -> R m -> L n m+outerR (extract -> x) (extract -> y) = mkL (LA.outer x y)++mapR :: KnownNat n => (ℝ -> ℝ) -> R n -> R n+mapR f (unwrap -> v) = mkR (LA.cmap f v)++zipWithR :: KnownNat n => (ℝ -> ℝ -> ℝ) -> R n -> R n -> R n+zipWithR f (extract -> x) (extract -> y) = mkR (LA.zipVectorWith f x y)++mapL :: (KnownNat n, KnownNat m) => (ℝ -> ℝ) -> L n m -> L n m+mapL f = overMatL' (LA.cmap f)++detL :: KnownNat n => Sq n -> ℝ+detL = LA.det . unwrap++invlndetL :: KnownNat n => Sq n -> (L n n, (ℝ, ℝ))+invlndetL = BF.first mkL . LA.invlndet . unwrap++expmL :: KnownNat n => Sq n -> Sq n+expmL = overMatL' LA.expm++sqrtmL :: KnownNat n => Sq n -> Sq n+sqrtmL = overMatL' LA.sqrtm++invL :: KnownNat n => Sq n -> Sq n+invL = overMatL' LA.inv+ -------------------------------------------------------------------------------- mulC :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => M m k -> M k n -> M m n@@ -484,9 +690,9 @@ a' = subVector 0 n a b' = subVector 0 n b -mulC (isDiagC -> Just (0,a,_)) (extract -> b) = mkM (asColumn a * takeRows (LA.size a) b)+-- mulC (isDiagC -> Just (0,a,_)) (extract -> b) = mkM (asColumn a * takeRows (LA.size a) b) -mulC (extract -> a) (isDiagC -> Just (0,b,_)) = mkM (takeColumns (LA.size b) a * asRow b)+-- mulC (extract -> a) (isDiagC -> Just (0,b,_)) = mkM (takeColumns (LA.size b) a * asRow b) mulC a b = mkM (extract a LA.<> extract b) @@ -497,9 +703,7 @@ dotC :: KnownNat n => C n -> C n -> ℂ-dotC (unwrap -> u) (unwrap -> v)- | singleV u || singleV v = sumElements (conj u * v)- | otherwise = u LA.<·> v+dotC (extract -> u) (extract -> v) = LA.dot u v crossC :: C 3 -> C 3 -> C 3@@ -509,6 +713,33 @@ z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 +outerC :: (KnownNat m, KnownNat n) => C n -> C m -> M n m+outerC (extract -> x) (extract -> y) = mkM (LA.outer x y)++mapC :: KnownNat n => (ℂ -> ℂ) -> C n -> C n+mapC f (unwrap -> v) = mkC (LA.cmap f v)++zipWithC :: KnownNat n => (ℂ -> ℂ -> ℂ) -> C n -> C n -> C n+zipWithC f (extract -> x) (extract -> y) = mkC (LA.zipVectorWith f x y)++mapM' :: (KnownNat n, KnownNat m) => (ℂ -> ℂ) -> M n m -> M n m+mapM' f = overMatM' (LA.cmap f)++detM :: KnownNat n => M n n -> ℂ+detM = LA.det . unwrap++invlndetM :: KnownNat n => M n n -> (M n n, (ℂ, ℂ))+invlndetM = BF.first mkM . LA.invlndet . unwrap++expmM :: KnownNat n => M n n -> M n n+expmM = overMatM' LA.expm++sqrtmM :: KnownNat n => M n n -> M n n+sqrtmM = overMatM' LA.sqrtm++invM :: KnownNat n => M n n -> M n n+invM = overMatM' LA.inv+ -------------------------------------------------------------------------------- diagRectR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℝ -> R k -> L m n@@ -587,12 +818,12 @@ where q = tm :: L 10 3 - thingD = vjoin [ud1 u, 1] LA.<·> tr m LA.#> m LA.#> ud1 v+ thingD = vjoin [ud1 u, 1] LA.<.> tr m LA.#> m LA.#> ud1 v where m = LA.matrix 3 [1..30] precS = (1::Double) + (2::Double) * ((1 :: R 3) * (u & 6)) <·> konst 2 #> v- precD = 1 + 2 * vjoin[ud1 u, 6] LA.<·> LA.konst 2 (LA.size (ud1 u) +1, LA.size (ud1 v)) LA.#> ud1 v+ precD = 1 + 2 * vjoin[ud1 u, 6] LA.<.> LA.konst 2 (LA.size (ud1 u) +1, LA.size (ud1 v)) LA.#> ud1 v splittest@@ -615,23 +846,67 @@ where checkT _ = test -#else+-------------------------------------------------------------------------------- -{- |-Module : Numeric.LinearAlgebra.Static-Copyright : (c) Alberto Ruiz 2014-License : BSD3-Stability : experimental+instance KnownNat n => Normed (R n)+ where+ norm_0 v = norm_0 (extract v)+ norm_1 v = norm_1 (extract v)+ norm_2 v = norm_2 (extract v)+ norm_Inf v = norm_Inf (extract v) -Experimental interface with statically checked dimensions.+instance (KnownNat m, KnownNat n) => Normed (L m n)+ where+ norm_0 m = norm_0 (extract m)+ norm_1 m = norm_1 (extract m)+ norm_2 m = norm_2 (extract m)+ norm_Inf m = norm_Inf (extract m) -This module requires GHC >= 7.8+mkSym f = Sym . f . unSym+mkSym2 f x y = Sym (f (unSym x) (unSym y)) --}+instance KnownNat n => Num (Sym n)+ where+ (+) = mkSym2 (+)+ (*) = mkSym2 (*)+ (-) = mkSym2 (-)+ abs = mkSym abs+ signum = mkSym signum+ negate = mkSym negate+ fromInteger = Sym . fromInteger -module Numeric.LinearAlgebra.Static-{-# WARNING "This module requires GHC >= 7.8" #-}-where+instance KnownNat n => Fractional (Sym n)+ where+ fromRational = Sym . fromRational+ (/) = mkSym2 (/) -#endif+instance KnownNat n => Floating (Sym n)+ where+ sin = mkSym sin+ cos = mkSym cos+ tan = mkSym tan+ asin = mkSym asin+ acos = mkSym acos+ atan = mkSym atan+ sinh = mkSym sinh+ cosh = mkSym cosh+ tanh = mkSym tanh+ asinh = mkSym asinh+ acosh = mkSym acosh+ atanh = mkSym atanh+ exp = mkSym exp+ log = mkSym log+ sqrt = mkSym sqrt+ (**) = mkSym2 (**)+ pi = Sym pi +instance KnownNat n => Additive (Sym n) where+ add = (+)++instance KnownNat n => Transposable (Sym n) (Sym n) where+ tr = id+ tr' = id++instance KnownNat n => Transposable (Her n) (Her n) where+ tr = id+ tr' (Her m) = Her (tr' m)
− src/Numeric/LinearAlgebra/Static/Internal.hs
@@ -1,521 +0,0 @@-#if __GLASGOW_HASKELL__ >= 708--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}--{- |-Module : Numeric.LinearAlgebra.Static.Internal-Copyright : (c) Alberto Ruiz 2006-14-License : BSD3-Stability : provisional---}--module Numeric.LinearAlgebra.Static.Internal where---import GHC.TypeLits-import qualified Numeric.LinearAlgebra.HMatrix as LA-import Numeric.LinearAlgebra.HMatrix hiding (konst,size)-import Data.Packed as D-import Data.Packed.ST-import Data.Proxy(Proxy)-import Foreign.Storable(Storable)-import Text.Printf------------------------------------------------------------------------------------newtype Dim (n :: Nat) t = Dim t- deriving Show--lift1F- :: (c t -> c t)- -> Dim n (c t) -> Dim n (c t)-lift1F f (Dim v) = Dim (f v)--lift2F- :: (c t -> c t -> c t)- -> Dim n (c t) -> Dim n (c t) -> Dim n (c t)-lift2F f (Dim u) (Dim v) = Dim (f u v)------------------------------------------------------------------------------------newtype R n = R (Dim n (Vector ℝ))- deriving (Num,Fractional,Floating)--newtype C n = C (Dim n (Vector ℂ))- deriving (Num,Fractional,Floating)--newtype L m n = L (Dim m (Dim n (Matrix ℝ)))--newtype M m n = M (Dim m (Dim n (Matrix ℂ)))---mkR :: Vector ℝ -> R n-mkR = R . Dim--mkC :: Vector ℂ -> C n-mkC = C . Dim--mkL :: Matrix ℝ -> L m n-mkL x = L (Dim (Dim x))--mkM :: Matrix ℂ -> M m n-mkM x = M (Dim (Dim x))------------------------------------------------------------------------------------type V n t = Dim n (Vector t)--ud :: Dim n (Vector t) -> Vector t-ud (Dim v) = v--mkV :: forall (n :: Nat) t . t -> Dim n t-mkV = Dim---vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t)- => V n t -> V m t -> V (n+m) t-(ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v'])- where- du = fromIntegral . natVal $ (undefined :: Proxy n)- dv = fromIntegral . natVal $ (undefined :: Proxy m)- u' | du > 1 && LA.size u == 1 = LA.konst (u D.@> 0) du- | otherwise = u- v' | dv > 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv- | otherwise = v---gvec2 :: Storable t => t -> t -> V 2 t-gvec2 a b = mkV $ runSTVector $ do- v <- newUndefinedVector 2- writeVector v 0 a- writeVector v 1 b- return v--gvec3 :: Storable t => t -> t -> t -> V 3 t-gvec3 a b c = mkV $ runSTVector $ do- v <- newUndefinedVector 3- writeVector v 0 a- writeVector v 1 b- writeVector v 2 c- return v---gvec4 :: Storable t => t -> t -> t -> t -> V 4 t-gvec4 a b c d = mkV $ runSTVector $ do- v <- newUndefinedVector 4- writeVector v 0 a- writeVector v 1 b- writeVector v 2 c- writeVector v 3 d- return v---gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t-gvect st xs'- | ok = mkV v- | not (null rest) && null (tail rest) = abort (show xs')- | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")- | otherwise = abort (show xs)- where- (xs,rest) = splitAt d xs'- ok = LA.size v == d && null rest- v = LA.fromList xs- d = fromIntegral . natVal $ (undefined :: Proxy n)- abort info = error $ st++" "++show d++" can't be created from elements "++info-------------------------------------------------------------------------------------type GM m n t = Dim m (Dim n (Matrix t))---gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t-gmat st xs'- | ok = Dim (Dim x)- | not (null rest) && null (tail rest) = abort (show xs')- | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]")- | otherwise = abort (show xs)- where- (xs,rest) = splitAt (m'*n') xs'- v = LA.fromList xs- x = reshape n' v- ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n'))- m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int- n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int- abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info------------------------------------------------------------------------------------class Num t => Sized t s d | s -> t, s -> d- where- konst :: t -> s- unwrap :: s -> d t- fromList :: [t] -> s- extract :: s -> d t- create :: d t -> Maybe s- size :: s -> IndexOf d--singleV v = LA.size v == 1-singleM m = rows m == 1 && cols m == 1---instance forall n. KnownNat n => Sized ℂ (C n) Vector- where- size _ = fromIntegral . natVal $ (undefined :: Proxy n)- konst x = mkC (LA.scalar x)- unwrap (C (Dim v)) = v- fromList xs = C (gvect "C" xs)- extract s@(unwrap -> v)- | singleV v = LA.konst (v!0) (size s)- | otherwise = v- create v- | LA.size v == size r = Just r- | otherwise = Nothing- where- r = mkC v :: C n---instance forall n. KnownNat n => Sized ℝ (R n) Vector- where- size _ = fromIntegral . natVal $ (undefined :: Proxy n)- konst x = mkR (LA.scalar x)- unwrap (R (Dim v)) = v- fromList xs = R (gvect "R" xs)- extract s@(unwrap -> v)- | singleV v = LA.konst (v!0) (size s)- | otherwise = v- create v- | LA.size v == size r = Just r- | otherwise = Nothing- where- r = mkR v :: R n----instance forall m n . (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix- where- size _ = ((fromIntegral . natVal) (undefined :: Proxy m)- ,(fromIntegral . natVal) (undefined :: Proxy n))- konst x = mkL (LA.scalar x)- fromList xs = L (gmat "L" xs)- unwrap (L (Dim (Dim m))) = m- extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n'- extract s@(unwrap -> a)- | singleM a = LA.konst (a `atIndex` (0,0)) (size s)- | otherwise = a- create x- | LA.size x == size r = Just r- | otherwise = Nothing- where- r = mkL x :: L m n---instance forall m n . (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix- where- size _ = ((fromIntegral . natVal) (undefined :: Proxy m)- ,(fromIntegral . natVal) (undefined :: Proxy n))- konst x = mkM (LA.scalar x)- fromList xs = M (gmat "M" xs)- unwrap (M (Dim (Dim m))) = m- extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n'- extract s@(unwrap -> a)- | singleM a = LA.konst (a `atIndex` (0,0)) (size s)- | otherwise = a- create x- | LA.size x == size r = Just r- | otherwise = Nothing- where- r = mkM x :: M m n------------------------------------------------------------------------------------instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m)- where- tr a@(isDiag -> Just _) = mkL (extract a)- tr (extract -> a) = mkL (tr a)--instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m)- where- tr a@(isDiagC -> Just _) = mkM (extract a)- tr (extract -> a) = mkM (tr a)------------------------------------------------------------------------------------isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int))-isDiag (L x) = isDiagg x--isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int))-isDiagC (M x) = isDiagg x---isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int))-isDiagg (Dim (Dim x))- | singleM x = Nothing- | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n'))- | otherwise = Nothing- where- m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int- n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int- v = flatten x- z = v `atIndex` 0- y = subVector 1 (LA.size v-1) v- ny = LA.size y- zeros = LA.konst 0 (max 0 (min m' n' - ny))- yz = vjoin [y,zeros]------------------------------------------------------------------------------------instance forall n . KnownNat n => Show (R n)- where- show s@(R (Dim v))- | singleV v = "("++show (v!0)++" :: R "++show d++")"- | otherwise = "(vector"++ drop 8 (show v)++" :: R "++show d++")"- where- d = size s--instance forall n . KnownNat n => Show (C n)- where- show s@(C (Dim v))- | singleV v = "("++show (v!0)++" :: C "++show d++")"- | otherwise = "(vector"++ drop 8 (show v)++" :: C "++show d++")"- where- d = size s--instance forall m n . (KnownNat m, KnownNat n) => Show (L m n)- where- show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (drop 9 $ show y) m' n'- show s@(L (Dim (Dim x)))- | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n'- | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: L "++show m'++" "++show n'++")"- where- (m',n') = size s--instance forall m n . (KnownNat m, KnownNat n) => Show (M m n)- where- show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (drop 9 $ show y) m' n'- show s@(M (Dim (Dim x)))- | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n'- | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: M "++show m'++" "++show n'++")"- where- (m',n') = size s------------------------------------------------------------------------------------instance forall n t . (Num (Vector t), Numeric t )=> Num (Dim n (Vector t))- where- (+) = lift2F (+)- (*) = lift2F (*)- (-) = lift2F (-)- abs = lift1F abs- signum = lift1F signum- negate = lift1F negate- fromInteger x = Dim (fromInteger x)--instance (Num (Vector t), Num (Matrix t), Numeric t) => Fractional (Dim n (Vector t))- where- fromRational x = Dim (fromRational x)- (/) = lift2F (/)--instance (Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where- sin = lift1F sin- cos = lift1F cos- tan = lift1F tan- asin = lift1F asin- acos = lift1F acos- atan = lift1F atan- sinh = lift1F sinh- cosh = lift1F cosh- tanh = lift1F tanh- asinh = lift1F asinh- acosh = lift1F acosh- atanh = lift1F atanh- exp = lift1F exp- log = lift1F log- sqrt = lift1F sqrt- (**) = lift2F (**)- pi = Dim pi---instance (Num (Matrix t), Numeric t) => Num (Dim m (Dim n (Matrix t)))- where- (+) = (lift2F . lift2F) (+)- (*) = (lift2F . lift2F) (*)- (-) = (lift2F . lift2F) (-)- abs = (lift1F . lift1F) abs- signum = (lift1F . lift1F) signum- negate = (lift1F . lift1F) negate- fromInteger x = Dim (Dim (fromInteger x))--instance (Num (Vector t), Num (Matrix t), Numeric t) => Fractional (Dim m (Dim n (Matrix t)))- where- fromRational x = Dim (Dim (fromRational x))- (/) = (lift2F.lift2F) (/)--instance (Num (Vector t), Floating (Matrix t), Numeric t) => Floating (Dim m (Dim n (Matrix t))) where- sin = (lift1F . lift1F) sin- cos = (lift1F . lift1F) cos- tan = (lift1F . lift1F) tan- asin = (lift1F . lift1F) asin- acos = (lift1F . lift1F) acos- atan = (lift1F . lift1F) atan- sinh = (lift1F . lift1F) sinh- cosh = (lift1F . lift1F) cosh- tanh = (lift1F . lift1F) tanh- asinh = (lift1F . lift1F) asinh- acosh = (lift1F . lift1F) acosh- atanh = (lift1F . lift1F) atanh- exp = (lift1F . lift1F) exp- log = (lift1F . lift1F) log- sqrt = (lift1F . lift1F) sqrt- (**) = (lift2F . lift2F) (**)- pi = Dim (Dim pi)-------------------------------------------------------------------------------------adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b-adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b))-adaptDiag f a b = f a b--isFull m = isDiag m == Nothing && not (singleM (unwrap m))---lift1L f (L v) = L (f v)-lift2L f (L a) (L b) = L (f a b)-lift2LD f = adaptDiag (lift2L f)---instance (KnownNat n, KnownNat m) => Num (L n m)- where- (+) = lift2LD (+)- (*) = lift2LD (*)- (-) = lift2LD (-)- abs = lift1L abs- signum = lift1L signum- negate = lift1L negate- fromInteger = L . Dim . Dim . fromInteger--instance (KnownNat n, KnownNat m) => Fractional (L n m)- where- fromRational = L . Dim . Dim . fromRational- (/) = lift2LD (/)--instance (KnownNat n, KnownNat m) => Floating (L n m) where- sin = lift1L sin- cos = lift1L cos- tan = lift1L tan- asin = lift1L asin- acos = lift1L acos- atan = lift1L atan- sinh = lift1L sinh- cosh = lift1L cosh- tanh = lift1L tanh- asinh = lift1L asinh- acosh = lift1L acosh- atanh = lift1L atanh- exp = lift1L exp- log = lift1L log- sqrt = lift1L sqrt- (**) = lift2LD (**)- pi = konst pi------------------------------------------------------------------------------------adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b-adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b))-adaptDiagC f a b = f a b--isFullC m = isDiagC m == Nothing && not (singleM (unwrap m))--lift1M f (M v) = M (f v)-lift2M f (M a) (M b) = M (f a b)-lift2MD f = adaptDiagC (lift2M f)--instance (KnownNat n, KnownNat m) => Num (M n m)- where- (+) = lift2MD (+)- (*) = lift2MD (*)- (-) = lift2MD (-)- abs = lift1M abs- signum = lift1M signum- negate = lift1M negate- fromInteger = M . Dim . Dim . fromInteger--instance (KnownNat n, KnownNat m) => Fractional (M n m)- where- fromRational = M . Dim . Dim . fromRational- (/) = lift2MD (/)--instance (KnownNat n, KnownNat m) => Floating (M n m) where- sin = lift1M sin- cos = lift1M cos- tan = lift1M tan- asin = lift1M asin- acos = lift1M acos- atan = lift1M atan- sinh = lift1M sinh- cosh = lift1M cosh- tanh = lift1M tanh- asinh = lift1M asinh- acosh = lift1M acosh- atanh = lift1M atanh- exp = lift1M exp- log = lift1M log- sqrt = lift1M sqrt- (**) = lift2MD (**)- pi = M pi-------------------------------------------------------------------------------------class Disp t- where- disp :: Int -> t -> IO ()---instance (KnownNat m, KnownNat n) => Disp (L m n)- where- disp n x = do- let a = extract x- let su = LA.dispf n a- printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)--instance (KnownNat m, KnownNat n) => Disp (M m n)- where- disp n x = do- let a = extract x- let su = LA.dispcf n a- printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su)---instance KnownNat n => Disp (R n)- where- disp n v = do- let su = LA.dispf n (asRow $ extract v)- putStr "R " >> putStr (tail . dropWhile (/='x') $ su)--instance KnownNat n => Disp (C n)- where- disp n v = do- let su = LA.dispcf n (asRow $ extract v)- putStr "C " >> putStr (tail . dropWhile (/='x') $ su)------------------------------------------------------------------------------------#else--module Numeric.LinearAlgebra.Static.Internal where--#endif-
− src/Numeric/LinearAlgebra/Util.hs
@@ -1,477 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ViewPatterns #-}---------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Util-Copyright : (c) Alberto Ruiz 2013-License : BSD3-Maintainer : Alberto Ruiz-Stability : provisional---}-------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Numeric.LinearAlgebra.Util(-- -- * Convenience functions- vector, matrix,- disp,- formatSparse,- approxInt,- dispDots,- dispBlanks,- formatShort,- dispShort,- zeros, ones,- diagl,- row,- col,- (&), (¦), (——), (#),- (?), (¿),- Indexable(..), size,- Numeric,- rand, randn,- cross,- norm,- ℕ,ℤ,ℝ,ℂ,iC,- Normed(..), norm_Frob, norm_nuclear,- unitary,- mt,- (~!~),- pairwiseD2,- rowOuters,- null1,- null1sym,- -- * Convolution- -- ** 1D- corr, conv, corrMin,- -- ** 2D- corr2, conv2, separable,- -- * Tools for the Kronecker product- --- -- | (see A. Fusiello, A matter of notation: Several uses of the Kronecker product in- -- 3d computer vision, Pattern Recognition Letters 28 (15) (2007) 2127-2132)-- --- -- | @`vec` (a \<> x \<> b) == ('trans' b ` 'kronecker' ` a) \<> 'vec' x@- vec,- vech,- dup,- vtrans-) where--import Data.Packed.Numeric-import Numeric.LinearAlgebra.Algorithms hiding (i,Normed)---import qualified Numeric.LinearAlgebra.Algorithms as A-import Numeric.Matrix()-import Numeric.Vector()-import Numeric.LinearAlgebra.Random-import Numeric.LinearAlgebra.Util.Convolution-import Control.Monad(when)-import Text.Printf-import Data.List.Split(splitOn)-import Data.List(intercalate)--type ℝ = Double-type ℕ = Int-type ℤ = Int-type ℂ = Complex Double---- | imaginary unit-iC :: ℂ-iC = 0:+1--{- | create a real vector-->>> vector [1..5]-fromList [1.0,2.0,3.0,4.0,5.0]---}-vector :: [ℝ] -> Vector ℝ-vector = fromList--{- | create a real matrix-->>> matrix 5 [1..15]-(3><5)- [ 1.0, 2.0, 3.0, 4.0, 5.0- , 6.0, 7.0, 8.0, 9.0, 10.0- , 11.0, 12.0, 13.0, 14.0, 15.0 ]---}-matrix- :: Int -- ^ columns- -> [ℝ] -- ^ elements- -> Matrix ℝ-matrix c = reshape c . fromList---{- | print a real matrix with given number of digits after the decimal point-->>> disp 5 $ ident 2 / 3-2x2-0.33333 0.00000-0.00000 0.33333---}-disp :: Int -> Matrix Double -> IO ()--disp n = putStr . dispf n---{- | create a real diagonal matrix from a list-->>> diagl [1,2,3]-(3><3)- [ 1.0, 0.0, 0.0- , 0.0, 2.0, 0.0- , 0.0, 0.0, 3.0 ]---}-diagl :: [Double] -> Matrix Double-diagl = diag . fromList---- | a real matrix of zeros-zeros :: Int -- ^ rows- -> Int -- ^ columns- -> Matrix Double-zeros r c = konst 0 (r,c)---- | a real matrix of ones-ones :: Int -- ^ rows- -> Int -- ^ columns- -> Matrix Double-ones r c = konst 1 (r,c)---- | concatenation of real vectors-infixl 3 &-(&) :: Vector Double -> Vector Double -> Vector Double-a & b = vjoin [a,b]--{- | horizontal concatenation of real matrices-- (unicode 0x00a6, broken bar)-->>> ident 3 ¦ konst 7 (3,4)-(3><7)- [ 1.0, 0.0, 0.0, 7.0, 7.0, 7.0, 7.0- , 0.0, 1.0, 0.0, 7.0, 7.0, 7.0, 7.0- , 0.0, 0.0, 1.0, 7.0, 7.0, 7.0, 7.0 ]---}-infixl 3 ¦-(¦) :: Matrix Double -> Matrix Double -> Matrix Double-a ¦ b = fromBlocks [[a,b]]---- | vertical concatenation of real matrices------ (unicode 0x2014, em dash)-(——) :: Matrix Double -> Matrix Double -> Matrix Double-infixl 2 ——-a —— b = fromBlocks [[a],[b]]--(#) :: Matrix Double -> Matrix Double -> Matrix Double-infixl 2 #-a # b = fromBlocks [[a],[b]]---- | create a single row real matrix from a list-row :: [Double] -> Matrix Double-row = asRow . fromList---- | create a single column real matrix from a list-col :: [Double] -> Matrix Double-col = asColumn . fromList--{- | extract rows-->>> (20><4) [1..] ? [2,1,1]-(3><4)- [ 9.0, 10.0, 11.0, 12.0- , 5.0, 6.0, 7.0, 8.0- , 5.0, 6.0, 7.0, 8.0 ]---}-infixl 9 ?-(?) :: Element t => Matrix t -> [Int] -> Matrix t-(?) = flip extractRows--{- | extract columns--(unicode 0x00bf, inverted question mark, Alt-Gr ?)-->>> (3><4) [1..] ¿ [3,0]-(3><2)- [ 4.0, 1.0- , 8.0, 5.0- , 12.0, 9.0 ]---}-infixl 9 ¿-(¿) :: Element t => Matrix t -> [Int] -> Matrix t-(¿)= flip extractColumns---cross :: Vector Double -> Vector Double -> Vector Double--- ^ cross product (for three-element real vectors)-cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3]- | otherwise = error $ "cross ("++show x++") ("++show y++")"- where- [x1,x2,x3] = toList x- [y1,y2,y3] = toList y- z1 = x2*y3-x3*y2- z2 = x3*y1-x1*y3- z3 = x1*y2-x2*y1--norm :: Vector Double -> Double--- ^ 2-norm of real vector-norm = pnorm PNorm2--class Normed a- where- norm_0 :: a -> ℝ- norm_1 :: a -> ℝ- norm_2 :: a -> ℝ- norm_Inf :: a -> ℝ---instance Normed (Vector ℝ)- where- norm_0 v = sumElements (step (abs v - scalar (eps*normInf v)))- norm_1 = pnorm PNorm1- norm_2 = pnorm PNorm2- norm_Inf = pnorm Infinity--instance Normed (Vector ℂ)- where- norm_0 v = sumElements (step (fst (fromComplex (abs v)) - scalar (eps*normInf v)))- norm_1 = pnorm PNorm1- norm_2 = pnorm PNorm2- norm_Inf = pnorm Infinity--instance Normed (Matrix ℝ)- where- norm_0 = norm_0 . flatten- norm_1 = pnorm PNorm1- norm_2 = pnorm PNorm2- norm_Inf = pnorm Infinity--instance Normed (Matrix ℂ)- where- norm_0 = norm_0 . flatten- norm_1 = pnorm PNorm1- norm_2 = pnorm PNorm2- norm_Inf = pnorm Infinity---norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> ℝ-norm_Frob = norm_2 . flatten--norm_nuclear :: Field t => Matrix t -> ℝ-norm_nuclear = sumElements . singularValues----- | Obtains a vector in the same direction with 2-norm=1-unitary :: Vector Double -> Vector Double-unitary v = v / scalar (norm v)----- | trans . inv-mt :: Matrix Double -> Matrix Double-mt = trans . inv-----------------------------------------------------------------------------------{- |-->>> size $ fromList[1..10::Double]-10->>> size $ (2><5)[1..10::Double]-(2,5)---}-size :: Container c t => c t -> IndexOf c-size = size'--{- |-->>> vect [1..10] ! 3-4.0-->>> mat 5 [1..15] ! 1-fromList [6.0,7.0,8.0,9.0,10.0]-->>> mat 5 [1..15] ! 1 ! 3-9.0---}-class Indexable c t | c -> t , t -> c- where- infixl 9 !- (!) :: c -> Int -> t--instance Indexable (Vector Double) Double- where- (!) = (@>)--instance Indexable (Vector Float) Float- where- (!) = (@>)--instance Indexable (Vector (Complex Double)) (Complex Double)- where- (!) = (@>)--instance Indexable (Vector (Complex Float)) (Complex Float)- where- (!) = (@>)--instance Element t => Indexable (Matrix t) (Vector t)- where- m!j = subVector (j*c) c (flatten m)- where- c = cols m-------------------------------------------------------------------------------------- | Matrix of pairwise squared distances of row vectors--- (using the matrix product trick in blog.smola.org)-pairwiseD2 :: Matrix Double -> Matrix Double -> Matrix Double-pairwiseD2 x y | ok = x2 `outer` oy + ox `outer` y2 - 2* x <> trans y- | otherwise = error $ "pairwiseD2 with different number of columns: "- ++ show (size x) ++ ", " ++ show (size y)- where- ox = one (rows x)- oy = one (rows y)- oc = one (cols x)- one k = konst 1 k- x2 = x * x <> oc- y2 = y * y <> oc- ok = cols x == cols y-------------------------------------------------------------------------------------- | outer products of rows-rowOuters :: Matrix Double -> Matrix Double -> Matrix Double-rowOuters a b = a' * b'- where- a' = kronecker a (ones 1 (cols b))- b' = kronecker (ones 1 (cols a)) b-------------------------------------------------------------------------------------- | solution of overconstrained homogeneous linear system-null1 :: Matrix Double -> Vector Double-null1 = last . toColumns . snd . rightSV---- | solution of overconstrained homogeneous symmetric linear system-null1sym :: Matrix Double -> Vector Double-null1sym = last . toColumns . snd . eigSH'------------------------------------------------------------------------------------vec :: Element t => Matrix t -> Vector t--- ^ stacking of columns-vec = flatten . trans---vech :: Element t => Matrix t -> Vector t--- ^ half-vectorization (of the lower triangular part)-vech m = vjoin . zipWith f [0..] . toColumns $ m- where- f k v = subVector k (dim v - k) v---dup :: (Num t, Num (Vector t), Element t) => Int -> Matrix t--- ^ duplication matrix (@'dup' k \<> 'vech' m == 'vec' m@, for symmetric m of 'dim' k)-dup k = trans $ fromRows $ map f es- where- rs = zip [0..] (toRows (ident (k^(2::Int))))- es = [(i,j) | j <- [0..k-1], i <- [0..k-1], i>=j ]- f (i,j) | i == j = g (k*j + i)- | otherwise = g (k*j + i) + g (k*i + j)- g j = v- where- Just v = lookup j rs---vtrans :: Element t => Int -> Matrix t -> Matrix t--- ^ generalized \"vector\" transposition: @'vtrans' 1 == 'trans'@, and @'vtrans' ('rows' m) m == 'asColumn' ('vec' m)@-vtrans p m | r == 0 = fromBlocks . map (map asColumn . takesV (replicate q p)) . toColumns $ m- | otherwise = error $ "vtrans " ++ show p ++ " of matrix with " ++ show (rows m) ++ " rows"- where- (q,r) = divMod (rows m) p------------------------------------------------------------------------------------infixl 0 ~!~-c ~!~ msg = when c (error msg)------------------------------------------------------------------------------------formatSparse :: String -> String -> String -> Int -> Matrix Double -> String--formatSparse zeroI _zeroF sep _ (approxInt -> Just m) = format sep f m- where- f 0 = zeroI- f x = printf "%.0f" x--formatSparse zeroI zeroF sep n m = format sep f m- where- f x | abs (x::Double) < 2*peps = zeroI++zeroF- | abs (fromIntegral (round x::Int) - x) / abs x < 2*peps- = printf ("%.0f."++replicate n ' ') x- | otherwise = printf ("%."++show n++"f") x--approxInt m- | norm_Inf (v - vi) < 2*peps * norm_Inf v = Just (reshape (cols m) vi)- | otherwise = Nothing- where- v = flatten m- vi = roundVector v--dispDots n = putStr . formatSparse "." (replicate n ' ') " " n--dispBlanks n = putStr . formatSparse "" "" " " n--formatShort sep fmt maxr maxc m = auxm4- where- (rm,cm) = size m- (r1,r2,r3)- | rm <= maxr = (rm,0,0)- | otherwise = (maxr-3,rm-maxr+1,2)- (c1,c2,c3)- | cm <= maxc = (cm,0,0)- | otherwise = (maxc-3,cm-maxc+1,2)- [ [a,_,b]- ,[_,_,_]- ,[c,_,d]] = toBlocks [r1,r2,r3]- [c1,c2,c3] m- auxm = fromBlocks [[a,b],[c,d]]- auxm2- | cm > maxc = format "|" fmt auxm- | otherwise = format sep fmt auxm- auxm3- | cm > maxc = map (f . splitOn "|") (lines auxm2)- | otherwise = (lines auxm2)- f items = intercalate sep (take (maxc-3) items) ++ " .. " ++- intercalate sep (drop (maxc-3) items)- auxm4- | rm > maxr = unlines (take (maxr-3) auxm3 ++ vsep : drop (maxr-3) auxm3)- | otherwise = unlines auxm3- vsep = map g (head auxm3)- g '.' = ':'- g _ = ' '---dispShort :: Int -> Int -> Int -> Matrix Double -> IO ()-dispShort maxr maxc dec m =- printf "%dx%d\n%s" (rows m) (cols m) (formatShort " " fmt maxr maxc m)- where- fmt = printf ("%."++show dec ++"f")-
− src/Numeric/LinearAlgebra/Util/CG.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}--module Numeric.LinearAlgebra.Util.CG(- cgSolve, cgSolve',- CGState(..), R, V-) where--import Data.Packed.Numeric-import Numeric.Sparse-import Numeric.Vector()-import Numeric.LinearAlgebra.Algorithms(linearSolveLS, relativeError, NormType(..))-import Control.Arrow((***))--{--import Util.Misc(debug, debugMat)--(//) :: Show a => a -> String -> a-infix 0 // -- , ///-a // b = debug b id a--(///) :: V -> String -> V-infix 0 ///-v /// b = debugMat b 2 asRow v--}--type R = Double-type V = Vector R--data CGState = CGState- { cgp :: V -- ^ conjugate gradient- , cgr :: V -- ^ residual- , cgr2 :: R -- ^ squared norm of residual- , cgx :: V -- ^ current solution- , cgdx :: R -- ^ normalized size of correction- }--cg :: Bool -> (V -> V) -> (V -> V) -> CGState -> CGState-cg sym at a (CGState p r r2 x _) = CGState p' r' r'2 x' rdx- where- ap1 = a p- ap | sym = ap1- | otherwise = at ap1- pap | sym = p <·> ap1- | otherwise = norm2 ap1 ** 2- alpha = r2 / pap- dx = scale alpha p- x' = x + dx- r' = r - scale alpha ap- r'2 = r' <·> r'- beta = r'2 / r2- p' = r' + scale beta p-- rdx = norm2 dx / max 1 (norm2 x)--conjugrad- :: Bool -> GMatrix -> V -> V -> R -> R -> [CGState]-conjugrad sym a b = solveG (tr a !#>) (a !#>) (cg sym) b--solveG- :: (V -> V) -> (V -> V)- -> ((V -> V) -> (V -> V) -> CGState -> CGState)- -> V- -> V- -> R -> R- -> [CGState]-solveG mat ma meth rawb x0' ϵb ϵx- = takeUntil ok . iterate (meth mat ma) $ CGState p0 r0 r20 x0 1- where- a = mat . ma- b = mat rawb- x0 = if x0' == 0 then konst 0 (dim b) else x0'- r0 = b - a x0- r20 = r0 <·> r0- p0 = r0- nb2 = b <·> b- ok CGState {..}- = cgr2 <nb2*ϵb**2- || cgdx < ϵx---takeUntil :: (a -> Bool) -> [a] -> [a]-takeUntil q xs = a++ take 1 b- where- (a,b) = break q xs--cgSolve- :: Bool -- ^ is symmetric- -> GMatrix -- ^ coefficient matrix- -> Vector Double -- ^ right-hand side- -> Vector Double -- ^ solution-cgSolve sym a b = cgx $ last $ cgSolve' sym 1E-4 1E-3 n a b 0- where- n = max 10 (round $ sqrt (fromIntegral (dim b) :: Double))--cgSolve'- :: Bool -- ^ symmetric- -> R -- ^ relative tolerance for the residual (e.g. 1E-4)- -> R -- ^ relative tolerance for δx (e.g. 1E-3)- -> Int -- ^ maximum number of iterations- -> GMatrix -- ^ coefficient matrix- -> V -- ^ initial solution- -> V -- ^ right-hand side- -> [CGState] -- ^ solution-cgSolve' sym er es n a b x = take n $ conjugrad sym a b x er es-------------------------------------------------------------------------------------instance Testable GMatrix- where- checkT _ = (ok,info)- where- sma = convo2 20 3- x1 = vect [1..20]- x2 = vect [1..40]- sm = mkSparse sma- dm = toDense sma-- s1 = sm !#> x1- d1 = dm #> x1-- s2 = tr sm !#> x2- d2 = tr dm #> x2-- sdia = mkDiagR 40 20 (vect [1..10])- s3 = sdia !#> x1- s4 = tr sdia !#> x2- ddia = diagRect 0 (vect [1..10]) 40 20- d3 = ddia #> x1- d4 = tr ddia #> x2-- v = testb 40- s5 = cgSolve False sm v- d5 = denseSolve dm v-- info = do- print sm- disp (toDense sma)- print s1; print d1- print s2; print d2- print s3; print d3- print s4; print d4- print s5; print d5- print $ relativeError Infinity s5 d5-- ok = s1==d1- && s2==d2- && s3==d3- && s4==d4- && relativeError Infinity s5 d5 < 1E-10-- disp = putStr . dispf 2-- vect = fromList :: [Double] -> Vector Double-- convomat :: Int -> Int -> AssocMatrix- convomat n k = [ ((i,j `mod` n),1) | i<-[0..n-1], j <- [i..i+k-1]]-- convo2 :: Int -> Int -> AssocMatrix- convo2 n k = m1 ++ m2- where- m1 = convomat n k- m2 = map (((+n) *** id) *** id) m1- - testb n = vect $ take n $ cycle ([0..10]++[9,8..1])- - denseSolve a = flatten . linearSolveLS a . asColumn-- -- mkDiag v = mkDiagR (dim v) (dim v) v-
− src/Numeric/LinearAlgebra/Util/Convolution.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-------------------------------------------------------------------------------{- |-Module : Numeric.LinearAlgebra.Util.Convolution-Copyright : (c) Alberto Ruiz 2012-License : BSD3-Maintainer : Alberto Ruiz-Stability : provisional---}-------------------------------------------------------------------------------{-# OPTIONS_HADDOCK hide #-}--module Numeric.LinearAlgebra.Util.Convolution(- corr, conv, corrMin,- corr2, conv2, separable-) where--import Data.Packed.Numeric---vectSS :: Element t => Int -> Vector t -> Matrix t-vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ]---corr- :: (Container Vector t, Product t)- => Vector t -- ^ kernel- -> Vector t -- ^ source- -> Vector t-{- ^ correlation-->>> corr (fromList[1,2,3]) (fromList [1..10])-fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0]---}-corr ker v- | dim ker == 0 = konst 0 (dim v)- | dim ker <= dim v = vectSS (dim ker) v <> ker- | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")"---conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t-{- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product)-->>> conv (fromList[1,1]) (fromList [-1,1])-fromList [-1.0,0.0,1.0]---}-conv ker v- | dim ker == 0 = konst 0 (dim v)- | otherwise = corr ker' v'- where- ker' = (flatten.fliprl.asRow) ker- v' = vjoin [z,v,z]- z = konst 0 (dim ker -1)--corrMin :: (Container Vector t, RealElement t, Product t)- => Vector t- -> Vector t- -> Vector t--- ^ similar to 'corr', using 'min' instead of (*)-corrMin ker v- | dim ker == 0 = error "corrMin: empty kernel"- | otherwise = minEvery ss (asRow ker) <> ones- where- minEvery a b = cond a b a a b- ss = vectSS (dim ker) v- ones = konst 1 (dim ker)----matSS :: Element t => Int -> Matrix t -> [Matrix t]-matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ]- where- v = flatten m- c = cols m- r = rows m- n = dr*c---{- | 2D correlation (without padding)-->>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double)-8x8-3 2 1 0 0 0 0 0-2 3 2 1 0 0 0 0-1 2 3 2 1 0 0 0-0 1 2 3 2 1 0 0-0 0 1 2 3 2 1 0-0 0 0 1 2 3 2 1-0 0 0 0 1 2 3 2-0 0 0 0 0 1 2 3---}-corr2 :: Product a => Matrix a -> Matrix a -> Matrix a-corr2 ker mat = dims- . concatMap (map (udot ker' . flatten) . matSS c . trans)- . matSS r $ mat- where- r = rows ker- c = cols ker- ker' = flatten (trans ker)- rr = rows mat - r + 1- rc = cols mat - c + 1- dims | rr > 0 && rc > 0 = (rr >< rc)- | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")"- sz m = show (rows m)++"x"++show (cols m)--- TODO check empty kernel--{- | 2D convolution-->>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double)-12x12-1 1 1 0 0 0 0 0 0 0 0 0-1 2 2 1 0 0 0 0 0 0 0 0-1 2 3 2 1 0 0 0 0 0 0 0-0 1 2 3 2 1 0 0 0 0 0 0-0 0 1 2 3 2 1 0 0 0 0 0-0 0 0 1 2 3 2 1 0 0 0 0-0 0 0 0 1 2 3 2 1 0 0 0-0 0 0 0 0 1 2 3 2 1 0 0-0 0 0 0 0 0 1 2 3 2 1 0-0 0 0 0 0 0 0 1 2 3 2 1-0 0 0 0 0 0 0 0 1 2 2 1-0 0 0 0 0 0 0 0 0 1 1 1---}-conv2- :: (Num (Matrix a), Product a, Container Vector a)- => Matrix a -- ^ kernel- -> Matrix a -> Matrix a-conv2 k m- | empty = konst 0 (rows m + r -1, cols m + c -1)- | otherwise = corr2 (fliprl . flipud $ k) padded- where- padded = fromBlocks [[z,0,0]- ,[0,m,0]- ,[0,0,z]]- r = rows k- c = cols k- z = konst 0 (r-1,c-1)- empty = r == 0 || c == 0---separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t--- ^ matrix computation implemented as separated vector operations by rows and columns.-separable f = fromColumns . map f . toColumns . fromRows . map f . toRows-
src/Numeric/Matrix.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module : Numeric.Matrix@@ -26,18 +28,24 @@ ------------------------------------------------------------------- -import Data.Packed-import Data.Packed.Internal.Numeric+import Internal.Vector+import Internal.Matrix+import Internal.Element+import Internal.Numeric import qualified Data.Monoid as M import Data.List(partition)-import Numeric.Chain+import qualified Data.Foldable as F+import qualified Data.Semigroup as S+import Internal.Chain+import Foreign.Storable(Storable) + ------------------------------------------------------------------- instance Container Matrix a => Eq (Matrix a) where (==) = equal -instance (Container Matrix a, Num (Vector a)) => Num (Matrix a) where+instance (Container Matrix a, Num a, Num (Vector a)) => Num (Matrix a) where (+) = liftMatrix2Auto (+) (-) = liftMatrix2Auto (-) negate = liftMatrix negate@@ -48,7 +56,7 @@ --------------------------------------------------- -instance (Container Vector a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where+instance (Container Vector a, Fractional a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where fromRational n = (1><1) [fromRational n] (/) = liftMatrix2Auto (/) @@ -75,18 +83,31 @@ -------------------------------------------------------------------------------- +isScalar :: Matrix t -> Bool isScalar m = rows m == 1 && cols m == 1 +adaptScalarM :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2)+ => (t1 -> Matrix t2 -> t)+ -> (Matrix t1 -> Matrix t2 -> t)+ -> (Matrix t1 -> t2 -> t)+ -> Matrix t1+ -> Matrix t2+ -> t adaptScalarM f1 f2 f3 x y | isScalar x = f1 (x @@>(0,0) ) y | isScalar y = f3 x (y @@>(0,0) ) | otherwise = f2 x y +instance (Container Vector t, Eq t, Num (Vector t), Product t) => S.Semigroup (Matrix t)+ where+ (<>) = mappend+ sconcat = mconcat . F.toList+ instance (Container Vector t, Eq t, Num (Vector t), Product t) => M.Monoid (Matrix t) where mempty = 1 mappend = adaptScalarM scale mXm (flip scale)- + mconcat xs = work (partition isScalar xs) where work (ss,[]) = product ss@@ -96,4 +117,3 @@ | otherwise = scale x00 m where x00 = x @@> (0,0)-
− src/Numeric/Sparse.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--module Numeric.Sparse(- GMatrix(..), CSR(..), mkCSR, fromCSR,- mkSparse, mkDiagR, mkDense,- AssocMatrix,- toDense,- gmXv, (!#>)-)where--import Data.Packed.Numeric-import qualified Data.Vector.Storable as V-import Data.Function(on)-import Control.Arrow((***))-import Control.Monad(when)-import Data.List(groupBy, sort)-import Foreign.C.Types(CInt(..))--import Data.Packed.Development-import System.IO.Unsafe(unsafePerformIO)-import Foreign(Ptr)-import Text.Printf(printf)--infixl 0 ~!~-c ~!~ msg = when c (error msg)--type AssocMatrix = [((Int,Int),Double)]--data CSR = CSR- { csrVals :: Vector Double- , csrCols :: Vector CInt- , csrRows :: Vector CInt- , csrNRows :: Int- , csrNCols :: Int- } deriving Show--data CSC = CSC- { cscVals :: Vector Double- , cscRows :: Vector CInt- , cscCols :: Vector CInt- , cscNRows :: Int- , cscNCols :: Int- } deriving Show---mkCSR :: AssocMatrix -> CSR-mkCSR sm' = CSR{..}- where- sm = sort sm'- rws = map ((fromList *** fromList)- . unzip- . map ((succ.fi.snd) *** id)- )- . groupBy ((==) `on` (fst.fst))- $ sm- rszs = map (fi . dim . fst) rws- csrRows = fromList (scanl (+) 1 rszs)- csrVals = vjoin (map snd rws)- csrCols = vjoin (map fst rws)- csrNRows = dim csrRows - 1- csrNCols = fromIntegral (V.maximum csrCols)--{- | General matrix with specialized internal representations for- dense, sparse, diagonal, banded, and constant elements.-->>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]->>> m-SparseR {gmCSR = CSR {csrVals = fromList [1.0,2.0],- csrCols = fromList [1000,2000],- csrRows = fromList [1,2,3],- csrNRows = 2,- csrNCols = 2000},- nRows = 2,- nCols = 2000}-->>> let m = mkDense (mat 2 [1..4])->>> m-Dense {gmDense = (2><2)- [ 1.0, 2.0- , 3.0, 4.0 ], nRows = 2, nCols = 2}---}-data GMatrix- = SparseR- { gmCSR :: CSR- , nRows :: Int- , nCols :: Int- }- | SparseC- { gmCSC :: CSC- , nRows :: Int- , nCols :: Int- }- | Diag- { diagVals :: Vector Double- , nRows :: Int- , nCols :: Int- }- | Dense- { gmDense :: Matrix Double- , nRows :: Int- , nCols :: Int- }--- | Banded- deriving Show---mkDense :: Matrix Double -> GMatrix-mkDense m = Dense{..}- where- gmDense = m- nRows = rows m- nCols = cols m--mkSparse :: AssocMatrix -> GMatrix-mkSparse = fromCSR . mkCSR--fromCSR :: CSR -> GMatrix-fromCSR csr = SparseR {..}- where- gmCSR @ CSR {..} = csr- nRows = csrNRows- nCols = csrNCols---mkDiagR r c v- | dim v <= min r c = Diag{..}- | otherwise = error $ printf "mkDiagR: incorrect sizes (%d,%d) [%d]" r c (dim v)- where- nRows = r- nCols = c- diagVals = v---type IV t = CInt -> Ptr CInt -> t-type V t = CInt -> Ptr Double -> t-type SMxV = V (IV (IV (V (V (IO CInt)))))--gmXv :: GMatrix -> Vector Double -> Vector Double-gmXv SparseR { gmCSR = CSR{..}, .. } v = unsafePerformIO $ do- dim v /= nCols ~!~ printf "gmXv (CSR): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v)- r <- createVector nRows- app5 c_smXv vec csrVals vec csrCols vec csrRows vec v vec r "CSRXv"- return r--gmXv SparseC { gmCSC = CSC{..}, .. } v = unsafePerformIO $ do- dim v /= nCols ~!~ printf "gmXv (CSC): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v)- r <- createVector nRows- app5 c_smTXv vec cscVals vec cscRows vec cscCols vec v vec r "CSCXv"- return r--gmXv Diag{..} v- | dim v == nCols- = vjoin [ subVector 0 (dim diagVals) v `mul` diagVals- , konst 0 (nRows - dim diagVals) ]- | otherwise = error $ printf "gmXv (Diag): incorrect sizes: (%d,%d) [%d] x %d"- nRows nCols (dim diagVals) (dim v)--gmXv Dense{..} v- | dim v == nCols- = mXv gmDense v- | otherwise = error $ printf "gmXv (Dense): incorrect sizes: (%d,%d) x %d"- nRows nCols (dim v)---{- | general matrix - vector product-->>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)]->>> m !#> vector [1..2000]-fromList [1000.0,4000.0]---}-infixr 8 !#>-(!#>) :: GMatrix -> Vector Double -> Vector Double-(!#>) = gmXv------------------------------------------------------------------------------------foreign import ccall unsafe "smXv"- c_smXv :: SMxV--foreign import ccall unsafe "smTXv"- c_smTXv :: SMxV------------------------------------------------------------------------------------toDense :: AssocMatrix -> Matrix Double-toDense asm = assoc (r+1,c+1) 0 asm- where- (r,c) = (maximum *** maximum) . unzip . map fst $ asm---instance Transposable CSR CSC- where- tr (CSR vs cs rs n m) = CSC vs cs rs m n--instance Transposable CSC CSR- where- tr (CSC vs rs cs n m) = CSR vs rs cs m n--instance Transposable GMatrix GMatrix- where- tr (SparseR s n m) = SparseC (tr s) m n- tr (SparseC s n m) = SparseR (tr s) m n- tr (Diag v n m) = Diag v m n- tr (Dense a n m) = Dense (tr a) m n--
src/Numeric/Vector.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+ ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vector@@ -14,17 +17,26 @@ -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Vector'.--- +-- ----------------------------------------------------------------------------- module Numeric.Vector () where -import Numeric.Vectorized-import Data.Packed.Vector-import Data.Packed.Internal.Numeric+import Internal.Vectorized+import Internal.Vector+import Internal.Numeric+import Internal.Conversion+import Foreign.Storable(Storable) ------------------------------------------------------------------- +adaptScalar :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2)+ => (t1 -> Vector t2 -> t)+ -> (Vector t1 -> Vector t2 -> t)+ -> (Vector t1 -> t2 -> t)+ -> Vector t1+ -> Vector t2+ -> t adaptScalar f1 f2 f3 x y | dim x == 1 = f1 (x@>0) y | dim y == 1 = f3 x (y@>0)@@ -32,6 +44,22 @@ ------------------------------------------------------------------ +instance Num (Vector I) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapI Sign+ abs = vectorMapI Abs+ fromInteger = fromList . return . fromInteger++instance Num (Vector Z) where+ (+) = adaptScalar addConstant add (flip addConstant)+ negate = scale (-1)+ (*) = adaptScalar scale mul (flip scale)+ signum = vectorMapL Sign+ abs = vectorMapL Abs+ fromInteger = fromList . return . fromInteger+ instance Num (Vector Float) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1)@@ -66,7 +94,7 @@ --------------------------------------------------- -instance (Container Vector a, Num (Vector a)) => Fractional (Vector a) where+instance (Container Vector a, Num (Vector a), Fractional a) => Fractional (Vector a) where fromRational n = fromList [fromRational n] (/) = adaptScalar f divide g where r `f` v = scaleRecip r v@@ -155,4 +183,3 @@ sqrt = vectorMapQ Sqrt (**) = adaptScalar (vectorMapValQ PowSV) (vectorZipQ Pow) (flip (vectorMapValQ PowVS)) pi = fromList [pi]-
− src/Numeric/Vectorized.hs
@@ -1,365 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Numeric.Vectorized--- Copyright : (c) Alberto Ruiz 2007-14--- License : BSD3--- Maintainer : Alberto Ruiz--- Stability : provisional------ Low level interface to vector operations.-----------------------------------------------------------------------------------module Numeric.Vectorized (- sumF, sumR, sumQ, sumC,- prodF, prodR, prodQ, prodC,- FunCodeS(..), toScalarR, toScalarF, toScalarC, toScalarQ,- FunCodeV(..), vectorMapR, vectorMapC, vectorMapF, vectorMapQ,- FunCodeSV(..), vectorMapValR, vectorMapValC, vectorMapValF, vectorMapValQ,- FunCodeVV(..), vectorZipR, vectorZipC, vectorZipF, vectorZipQ,- vectorScan, saveMatrix,- Seed, RandDist(..), randomVector,- sortVector, roundVector-) where--import Data.Packed.Internal.Common-import Data.Packed.Internal.Signatures-import Data.Packed.Internal.Vector-import Data.Packed.Internal.Matrix--import Data.Complex-import Foreign.Marshal.Alloc(free,malloc)-import Foreign.Marshal.Array(newArray,copyArray)-import Foreign.Ptr(Ptr)-import Foreign.Storable(peek)-import Foreign.C.Types-import Foreign.C.String-import System.IO.Unsafe(unsafePerformIO)--import Control.Monad(when)-import Control.Applicative((<$>))----fromei x = fromIntegral (fromEnum x) :: CInt--data FunCodeV = Sin- | Cos- | Tan- | Abs- | ASin- | ACos- | ATan- | Sinh- | Cosh- | Tanh- | ASinh- | ACosh- | ATanh- | Exp- | Log- | Sign- | Sqrt- deriving Enum--data FunCodeSV = Scale- | Recip- | AddConstant- | Negate- | PowSV- | PowVS- deriving Enum--data FunCodeVV = Add- | Sub- | Mul- | Div- | Pow- | ATan2- deriving Enum--data FunCodeS = Norm2- | AbsSum- | MaxIdx- | Max- | MinIdx- | Min- deriving Enum------------------------------------------------------------------------ | sum of elements-sumF :: Vector Float -> Float-sumF x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumF vec x vec r "sumF"- return $ r @> 0---- | sum of elements-sumR :: Vector Double -> Double-sumR x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumR vec x vec r "sumR"- return $ r @> 0---- | sum of elements-sumQ :: Vector (Complex Float) -> Complex Float-sumQ x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumQ vec x vec r "sumQ"- return $ r @> 0---- | sum of elements-sumC :: Vector (Complex Double) -> Complex Double-sumC x = unsafePerformIO $ do- r <- createVector 1- app2 c_sumC vec x vec r "sumC"- return $ r @> 0--foreign import ccall unsafe "sumF" c_sumF :: TFF-foreign import ccall unsafe "sumR" c_sumR :: TVV-foreign import ccall unsafe "sumQ" c_sumQ :: TQVQV-foreign import ccall unsafe "sumC" c_sumC :: TCVCV---- | product of elements-prodF :: Vector Float -> Float-prodF x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodF vec x vec r "prodF"- return $ r @> 0---- | product of elements-prodR :: Vector Double -> Double-prodR x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodR vec x vec r "prodR"- return $ r @> 0---- | product of elements-prodQ :: Vector (Complex Float) -> Complex Float-prodQ x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodQ vec x vec r "prodQ"- return $ r @> 0---- | product of elements-prodC :: Vector (Complex Double) -> Complex Double-prodC x = unsafePerformIO $ do- r <- createVector 1- app2 c_prodC vec x vec r "prodC"- return $ r @> 0--foreign import ccall unsafe "prodF" c_prodF :: TFF-foreign import ccall unsafe "prodR" c_prodR :: TVV-foreign import ccall unsafe "prodQ" c_prodQ :: TQVQV-foreign import ccall unsafe "prodC" c_prodC :: TCVCV----------------------------------------------------------------------toScalarAux fun code v = unsafePerformIO $ do- r <- createVector 1- app2 (fun (fromei code)) vec v vec r "toScalarAux"- return (r `at` 0)--vectorMapAux fun code v = unsafePerformIO $ do- r <- createVector (dim v)- app2 (fun (fromei code)) vec v vec r "vectorMapAux"- return r--vectorMapValAux fun code val v = unsafePerformIO $ do- r <- createVector (dim v)- pval <- newArray [val]- app2 (fun (fromei code) pval) vec v vec r "vectorMapValAux"- free pval- return r--vectorZipAux fun code u v = unsafePerformIO $ do- r <- createVector (dim u)- app3 (fun (fromei code)) vec u vec v vec r "vectorZipAux"- return r--------------------------------------------------------------------------- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.-toScalarR :: FunCodeS -> Vector Double -> Double-toScalarR oper = toScalarAux c_toScalarR (fromei oper)--foreign import ccall unsafe "toScalarR" c_toScalarR :: CInt -> TVV---- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc.-toScalarF :: FunCodeS -> Vector Float -> Float-toScalarF oper = toScalarAux c_toScalarF (fromei oper)--foreign import ccall unsafe "toScalarF" c_toScalarF :: CInt -> TFF---- | obtains different functions of a vector: only norm1, norm2-toScalarC :: FunCodeS -> Vector (Complex Double) -> Double-toScalarC oper = toScalarAux c_toScalarC (fromei oper)--foreign import ccall unsafe "toScalarC" c_toScalarC :: CInt -> TCVV---- | obtains different functions of a vector: only norm1, norm2-toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float-toScalarQ oper = toScalarAux c_toScalarQ (fromei oper)--foreign import ccall unsafe "toScalarQ" c_toScalarQ :: CInt -> TQVF------------------------------------------------------------------------ | map of real vectors with given function-vectorMapR :: FunCodeV -> Vector Double -> Vector Double-vectorMapR = vectorMapAux c_vectorMapR--foreign import ccall unsafe "mapR" c_vectorMapR :: CInt -> TVV---- | map of complex vectors with given function-vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double)-vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper)--foreign import ccall unsafe "mapC" c_vectorMapC :: CInt -> TCVCV---- | map of real vectors with given function-vectorMapF :: FunCodeV -> Vector Float -> Vector Float-vectorMapF = vectorMapAux c_vectorMapF--foreign import ccall unsafe "mapF" c_vectorMapF :: CInt -> TFF---- | map of real vectors with given function-vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float)-vectorMapQ = vectorMapAux c_vectorMapQ--foreign import ccall unsafe "mapQ" c_vectorMapQ :: CInt -> TQVQV------------------------------------------------------------------------- | map of real vectors with given function-vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double-vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper)--foreign import ccall unsafe "mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV---- | map of complex vectors with given function-vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double)-vectorMapValC = vectorMapValAux c_vectorMapValC--foreign import ccall unsafe "mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TCVCV---- | map of real vectors with given function-vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float-vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper)--foreign import ccall unsafe "mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TFF---- | map of complex vectors with given function-vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float)-vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper)--foreign import ccall unsafe "mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TQVQV------------------------------------------------------------------------- | elementwise operation on real vectors-vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double-vectorZipR = vectorZipAux c_vectorZipR--foreign import ccall unsafe "zipR" c_vectorZipR :: CInt -> TVVV---- | elementwise operation on complex vectors-vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double)-vectorZipC = vectorZipAux c_vectorZipC--foreign import ccall unsafe "zipC" c_vectorZipC :: CInt -> TCVCVCV---- | elementwise operation on real vectors-vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float-vectorZipF = vectorZipAux c_vectorZipF--foreign import ccall unsafe "zipF" c_vectorZipF :: CInt -> TFFF---- | elementwise operation on complex vectors-vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float)-vectorZipQ = vectorZipAux c_vectorZipQ--foreign import ccall unsafe "zipQ" c_vectorZipQ :: CInt -> TQVQVQV------------------------------------------------------------------------------------foreign import ccall unsafe "vectorScan" c_vectorScan- :: CString -> Ptr CInt -> Ptr (Ptr Double) -> IO CInt--vectorScan :: FilePath -> IO (Vector Double)-vectorScan s = do- pp <- malloc- pn <- malloc- cs <- newCString s- ok <- c_vectorScan cs pn pp- when (not (ok == 0)) $- error ("vectorScan: file \"" ++ s ++"\" not found")- n <- fromIntegral <$> peek pn- p <- peek pp- v <- createVector n- free pn- free cs- unsafeWith v $ \pv -> copyArray pv p n- free p- free pp- return v------------------------------------------------------------------------------------foreign import ccall unsafe "saveMatrix" c_saveMatrix- :: CString -> CString -> TM--{- | save a matrix as a 2D ASCII table--}-saveMatrix- :: FilePath- -> String -- ^ \"printf\" format (e.g. \"%.2f\", \"%g\", etc.)- -> Matrix Double- -> IO ()-saveMatrix name format m = do- cname <- newCString name- cformat <- newCString format- app1 (c_saveMatrix cname cformat) mat m "saveMatrix"- free cname- free cformat- return ()------------------------------------------------------------------------------------type Seed = Int--data RandDist = Uniform -- ^ uniform distribution in [0,1)- | Gaussian -- ^ normal distribution with mean zero and standard deviation one- deriving Enum---- | Obtains a vector of pseudorandom elements (use randomIO to get a random seed).-randomVector :: Seed- -> RandDist -- ^ distribution- -> Int -- ^ vector size- -> Vector Double-randomVector seed dist n = unsafePerformIO $ do- r <- createVector n- app1 (c_random_vector (fi seed) ((fi.fromEnum) dist)) vec r "randomVector"- return r--foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> TV------------------------------------------------------------------------------------sortVector v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_sort_values vec v vec r "sortVector"- return r--foreign import ccall unsafe "sort_values" c_sort_values :: TVV------------------------------------------------------------------------------------roundVector v = unsafePerformIO $ do- r <- createVector (dim v)- app2 c_round_vector vec v vec r "roundVector"- return r--foreign import ccall unsafe "round_vector" c_round_vector :: TVV-