diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,33 @@ +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 -------- diff --git a/THANKS.md b/THANKS.md --- a/THANKS.md +++ b/THANKS.md @@ -190,3 +190,17 @@ - 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 and improved urandom + +- "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. + diff --git a/hmatrix.cabal b/hmatrix.cabal --- a/hmatrix.cabal +++ b/hmatrix.cabal @@ -1,5 +1,5 @@ Name: hmatrix -Version: 0.16.1.5 +Version: 0.17.0.1 License: BSD3 License-file: LICENSE Author: Alberto Ruiz @@ -7,17 +7,11 @@ Stability: provisional Homepage: https://github.com/albertoruiz/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: @@ -30,16 +24,16 @@ 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 + manual: True library - Build-Depends: base >= 4 && < 5, + Build-Depends: base >= 4.8 && < 5, binary, array, deepseq, @@ -51,47 +45,38 @@ 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.Foreign + 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, @@ -100,18 +85,24 @@ ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans + -fprof-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 - if flag(openblas) - extra-lib-dirs: /usr/lib/openblas/lib - extra-libraries: openblas - else - extra-libraries: blas lapack + cpp-options: -DBINARY if os(OSX) + if flag(openblas) + extra-lib-dirs: /opt/local/lib/openblas/lib + extra-libraries: openblas + else + extra-libraries: blas lapack + extra-lib-dirs: /opt/local/lib/ include-dirs: /opt/local/include/ extra-lib-dirs: /usr/local/lib/ @@ -121,14 +112,29 @@ frameworks: Accelerate if os(freebsd) + if flag(openblas) + extra-lib-dirs: /usr/local/lib/openblas/lib + extra-libraries: openblas + else + extra-libraries: blas lapack + extra-lib-dirs: /usr/local/lib include-dirs: /usr/local/include - extra-libraries: blas lapack gfortran + extra-libraries: gfortran if os(windows) - extra-libraries: blas lapack + if flag(openblas) + extra-libraries: libopenblas + else + extra-libraries: blas lapack if os(linux) + if flag(openblas) + extra-lib-dirs: /usr/lib/openblas/lib + extra-libraries: openblas + else + extra-libraries: blas lapack + if arch(x86_64) cc-options: -fPIC diff --git a/src/C/lapack-aux.c b/src/C/lapack-aux.c deleted file mode 100644 --- a/src/C/lapack-aux.c +++ /dev/null @@ -1,1489 +0,0 @@ -#include -#include -#include -#include -#include -#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=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; k0) { - 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; k0) { - 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; k0) { - 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; k0) { - 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=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=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;k0) { - 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=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; k0; - } - OK -} - -int stepD(DVEC(x),DVEC(y)) { - DEBUGMSG("stepD") - int k; - for(k=0;k0; - } - 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;kyp[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;kyp[k]?gtp[k]:eqp[k]); - } - OK -} - diff --git a/src/C/lapack-aux.h b/src/C/lapack-aux.h deleted file mode 100644 --- a/src/C/lapack-aux.h +++ /dev/null @@ -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 - diff --git a/src/C/vector-aux.c b/src/C/vector-aux.c deleted file mode 100644 --- a/src/C/vector-aux.c +++ /dev/null @@ -1,883 +0,0 @@ -#include - -typedef double complex TCD; -typedef float complex TCF; - -#undef complex - -#include "lapack-aux.h" - -#define V(x) x##n,x##p - -#include -#include -#include -#include -#include - -#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; kr) { - r = xp[k]; - } - } - return r; -} - -double vector_min(KDVEC(x)) { - double r = xp[0]; - int k; - for (k = 1; kxp[r]) { - r = k; - } - } - return r; -} - -double vector_min_index(KDVEC(x)) { - int k, r = 0; - for (k = 1; kr) { - r = xp[k]; - } - } - return r; -} - -float vector_min_f(KFVEC(x)) { - float r = xp[0]; - int k; - for (k = 1; kxp[r]) { - r = k; - } - } - return r; -} - -float vector_min_index_f(KFVEC(x)) { - int k, r = 0; - for (k = 1; k0) { - 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= 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)) { - int phase = 0; - double V1,V2,S; - - srandom(seed); - - int k; - switch (code) { - case 0: { // uniform - for (k=0; k= 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 *(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 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) - diff --git a/src/Data/Packed/IO.hs b/src/Data/Packed/IO.hs deleted file mode 100644 --- a/src/Data/Packed/IO.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Packed/Internal.hs b/src/Data/Packed/Internal.hs deleted file mode 100644 --- a/src/Data/Packed/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Data/Packed/Internal/Common.hs b/src/Data/Packed/Internal/Common.hs deleted file mode 100644 --- a/src/Data/Packed/Internal/Common.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Packed/Internal/Matrix.hs b/src/Data/Packed/Internal/Matrix.hs deleted file mode 100644 --- a/src/Data/Packed/Internal/Matrix.hs +++ /dev/null @@ -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 - diff --git a/src/Data/Packed/Internal/Numeric.hs b/src/Data/Packed/Internal/Numeric.hs deleted file mode 100644 --- a/src/Data/Packed/Internal/Numeric.hs +++ /dev/null @@ -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 (Fractional a, Element a, 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 - --------------------------------------------------------------------------------- - diff --git a/src/Data/Packed/Internal/Signatures.hs b/src/Data/Packed/Internal/Signatures.hs deleted file mode 100644 --- a/src/Data/Packed/Internal/Signatures.hs +++ /dev/null @@ -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 -- - diff --git a/src/Data/Packed/Internal/Vector.hs b/src/Data/Packed/Internal/Vector.hs deleted file mode 100644 --- a/src/Data/Packed/Internal/Vector.hs +++ /dev/null @@ -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 #-} - - diff --git a/src/Data/Packed/Matrix.hs b/src/Data/Packed/Matrix.hs deleted file mode 100644 --- a/src/Data/Packed/Matrix.hs +++ /dev/null @@ -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>' $ 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> [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) diff --git a/src/Data/Packed/Numeric.hs b/src/Data/Packed/Numeric.hs deleted file mode 100644 --- a/src/Data/Packed/Numeric.hs +++ /dev/null @@ -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) - - diff --git a/src/Data/Packed/ST.hs b/src/Data/Packed/ST.hs deleted file mode 100644 --- a/src/Data/Packed/ST.hs +++ /dev/null @@ -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) - diff --git a/src/Data/Packed/Vector.hs b/src/Data/Packed/Vector.hs deleted file mode 100644 --- a/src/Data/Packed/Vector.hs +++ /dev/null @@ -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 - diff --git a/src/Internal/Algorithms.hs b/src/Internal/Algorithms.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Algorithms.hs @@ -0,0 +1,1030 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +{- | +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 where + +import Internal.Vector +import Internal.Matrix +import Internal.Element +import Internal.Conversion +import Internal.LAPACK as LAPACK +import Internal.Numeric +import Data.List(foldl1') +import qualified Data.Array as A +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 + 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)) + 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 + 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 + 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 + 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 +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" #-} 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 +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" #-} 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 +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) + + +-------------------------------------------------------------- + +-- | 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' + +-- | 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' + +-- | 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 => 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. +qr :: Field t => Matrix t -> (Matrix t, Matrix t) +qr = {-# SCC "qr" #-} unpackQR . 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. +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 \<> 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 + +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 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>=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) + diff --git a/src/Internal/C/lapack-aux.c b/src/Internal/C/lapack-aux.c new file mode 100644 --- /dev/null +++ b/src/Internal/C/lapack-aux.c @@ -0,0 +1,1544 @@ +#include +#include +#include +#include +#include +#include +#include + +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=1 && ar==ac && ar==br,BAD_SIZE); + DEBUGMSG("linearSolveR_l"); + integer * ipiv = (integer*)malloc(n*sizeof(integer)); + integer res; + dgesv_ (&n,&nhrs, + ap, &n, + ipiv, + bp, &n, + &res); + if(res>0) { + return SINGULAR; + } + CHECK(res,res); + free(ipiv); + OK +} + +//////////////////// 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 n = ar; + integer nhrs = bc; + REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); + DEBUGMSG("linearSolveC_l"); + integer * ipiv = (integer*)malloc(n*sizeof(integer)); + integer res; + zgesv_ (&n,&nhrs, + ap, &n, + ipiv, + bp, &n, + &res); + if(res>0) { + return SINGULAR; + } + CHECK(res,res); + free(ipiv); + OK +} + +//////// 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 +} + +//////////////////// 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 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); + lwork = ceil(ans); + double * work = (double*)malloc(lwork*sizeof(double)); + dgels_ ("N",&m,&n,&nrhs, + ap,&m, + bp,&ldb, + work,&lwork, + &res); + if(res>0) { + return SINGULAR; + } + CHECK(res,res); + free(work); + OK +} + +//////////////////// 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 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); + lwork = ceil(ans.r); + doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); + zgels_ ("N",&m,&n,&nrhs, + ap,&m, + bp,&ldb, + work,&lwork, + &res); + if(res>0) { + return SINGULAR; + } + CHECK(res,res); + free(work); + OK +} + +//////////////////// 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 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)); + integer res; + integer lwork = -1; + integer rank; + double ans; + dgelss_ (&m,&n,&nrhs, + ap,&m, + bp,&ldb, + S, + &rcond,&rank, + &ans,&lwork, + &res); + lwork = ceil(ans); + double * work = (double*)malloc(lwork*sizeof(double)); + dgelss_ (&m,&n,&nrhs, + ap,&m, + bp,&ldb, + S, + &rcond,&rank, + work,&lwork, + &res); + if(res>0) { + return NOCONVER; + } + CHECK(res,res); + free(work); + free(S); + OK +} + +//////////////////// 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 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)); + double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double)); + integer res; + integer lwork = -1; + integer rank; + doublecomplex ans; + zgelss_ (&m,&n,&nrhs, + ap,&m, + bp,&ldb, + S, + &rcond,&rank, + &ans,&lwork, + RWORK, + &res); + lwork = ceil(ans.r); + doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); + zgelss_ (&m,&n,&nrhs, + ap,&m, + bp,&ldb, + S, + &rcond,&rank, + work,&lwork, + RWORK, + &res); + if(res>0) { + return NOCONVER; + } + CHECK(res,res); + free(work); + free(RWORK); + free(S); + OK +} + +//////////////////// 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=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=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); + CHECK(res,res); + free(WORK); + OK +} + +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 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); + CHECK(res,res); + free(WORK); + OK +} + +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 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); + CHECK(res,res); + free(WORK); + OK +} + +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 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); + CHECK(res,res); + free(WORK); + OK +} + + +//////////////////// 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 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); + CHECK(res,res); + free(WORK); + OK +} + + +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 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); + CHECK(res,res); + free(WORK); + OK +} + +//////////////////// 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 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)); + 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); + if(res>0) { + return NOCONVER; + } + CHECK(res,res); + free(WR); + free(WI); + free(BWORK); + free(WORK); + OK +} + + +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 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)); + 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 ///////////////////////// + +int dgetrf_(integer *m, integer *n, doublereal *a, integer * + lda, integer *ipiv, integer *info); + +int lu_l_R(DVEC(ipiv), ODMAT(r)) { + 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)); + integer res; + dgetrf_ (&m,&n,rp,&m,auxipiv,&res); + if(res>0) { + res = 0; // FIXME + } + CHECK(res,res); + int k; + for (k=0; k=1 && n >=1 && ipivn == mn, BAD_SIZE); + DEBUGMSG("lu_l_C"); + integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); + integer res; + zgetrf_ (&m,&n,rp,&m,auxipiv,&res); + if(res>0) { + res = 0; // FIXME + } + CHECK(res,res); + int k; + for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); + DEBUGMSG("ldl_R"); + integer* auxipiv = (integer*)malloc(n*sizeof(integer)); + 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)); + dsytrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); + CHECK(res,res); + int k; + for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); + DEBUGMSG("ldl_R"); + integer* auxipiv = (integer*)malloc(n*sizeof(integer)); + 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)); + zhetrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); + CHECK(res,res); + int k; + for (k=0; k=0 && x=0 && y0) { + 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; + } +} diff --git a/src/Internal/C/vector-aux.c b/src/Internal/C/vector-aux.c new file mode 100644 --- /dev/null +++ b/src/Internal/C/vector-aux.c @@ -0,0 +1,1486 @@ +#include +#include + +typedef double complex TCD; +typedef float complex TCF; + +#undef complex + +#include "lapack-aux.h" + +#define V(x) x##n,x##p + +#include +#include +#include +#include +#include + +#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; kr) { + r = xp[k]; + } + } + return r; +} + +double vector_min(KDVEC(x)) { + double r = xp[0]; + int k; + for (k = 1; kxp[r]) { + r = k; + } + } + return r; +} + +int vector_min_index(KDVEC(x)) { + int k, r = 0; + for (k = 1; kr) { + r = xp[k]; + } + } + return r; +} + +float vector_min_f(KFVEC(x)) { + float r = xp[0]; + int k; + for (k = 1; kxp[r]) { + r = k; + } + } + return r; +} + +int vector_min_index_f(KFVEC(x)) { + int k, r = 0; + for (k = 1; kr) { + r = xp[k]; + } + } + return r; +} + +int vector_min_i(KIVEC(x)) { + int r = xp[0]; + int k; + for (k = 1; kxp[r]) { + r = k; + } + } + return r; +} + +int vector_min_index_i(KIVEC(x)) { + int k, r = 0; + for (k = 1; kr) { + r = xp[k]; + } + } + return r; +} + +int64_t vector_min_l(KLVEC(x)) { + int64_t r = xp[0]; + int k; + for (k = 1; kxp[r]) { + r = k; + } + } + return r; +} + +int vector_min_index_l(KLVEC(x)) { + int k, r = 0; + for (k = 1; k0) { + 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= 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)) { + int phase = 0; + double V1,V2,S; + + srandom(seed); + + int k; + switch (code) { + case 0: { // uniform + for (k=0; k= 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 *(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;kval > ((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; k0; \ + } \ + 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;kyp[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;k0?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 +} + diff --git a/src/Internal/CG.hs b/src/Internal/CG.hs new file mode 100644 --- /dev/null +++ b/src/Internal/CG.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +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 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 + diff --git a/src/Internal/Chain.hs b/src/Internal/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Chain.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Internal.Chain +-- Copyright : (c) Vivian McPhail 2010 +-- License : BSD3 +-- +-- Maintainer : Vivian McPhail 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..] + +-} + diff --git a/src/Internal/Container.hs b/src/Internal/Container.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Container.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +----------------------------------------------------------------------------- +-- | +-- 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) + +------------------------------------------------------------------ + +{- | 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 :: (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 +fromList [140.0,320.0] + +-} +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 +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 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) + +-------------------------------------------------------------------------------- + +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] + + diff --git a/src/Internal/Conversion.hs b/src/Internal/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Conversion.hs @@ -0,0 +1,94 @@ +{-# 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 +-- +----------------------------------------------------------------------------- + + +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' + diff --git a/src/Internal/Convolution.hs b/src/Internal/Convolution.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Convolution.hs @@ -0,0 +1,155 @@ +{-# 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 + + +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' = 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 + diff --git a/src/Internal/Devel.hs b/src/Internal/Devel.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Devel.hs @@ -0,0 +1,95 @@ +{-# 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 as E ( SomeException, catch ) +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 #| +(#|) = flip check + +-- | 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 + +-------------------------------------------------------------------------------- + +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 :: (Trans c b) -> c -> b + applyRaw :: (TransRaw c b) -> c -> b + 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 #-} + diff --git a/src/Internal/Element.hs b/src/Internal/Element.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Element.hs @@ -0,0 +1,604 @@ +{-# 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. + +----------------------------------------------------------------------------- + +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) + +------------------------------------------------------------------- + +#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>' $ dims + + +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 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 = toScalarI Min +maxEl = toScalarI Max +cmodi = vectorMapValI ModVS + +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>= 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 = (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 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' = 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> [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 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 [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 :: (Element a, Element b) => (a -> b) -> Matrix a -> Matrix b +mapMatrix f = liftMatrix (mapVector f) + diff --git a/src/Internal/Foreign.hs b/src/Internal/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Foreign.hs @@ -0,0 +1,102 @@ +{-# 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) +-- @ +-- + +module Internal.Foreign + ( app + , appVector, appVectorLen + , appMatrix, appMatrixLen, appMatrixRaw, appMatrixRawLen + , unsafeMatrixToVector, unsafeMatrixToForeignPtr + ) where + +import Foreign.C.Types(CInt) +import Internal.Vector +import Internal.Matrix +import qualified Data.Vector.Storable as S +import Foreign (Ptr, ForeignPtr, Storable) +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) + diff --git a/src/Internal/IO.hs b/src/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/src/Internal/IO.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- | +-- 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) +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 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 + +-------------------------------------------------------------------- + +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) + diff --git a/src/Internal/LAPACK.hs b/src/Internal/LAPACK.hs new file mode 100644 --- /dev/null +++ b/src/Internal/LAPACK.hs @@ -0,0 +1,640 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.LAPACK +-- Copyright : (c) Alberto Ruiz 2006-14 +-- License : BSD3 +-- Maintainer : Alberto Ruiz +-- Stability : provisional +-- +-- Functional interface to selected LAPACK functions (). +-- +----------------------------------------------------------------------------- + + +module Internal.LAPACK where + +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) + +----------------------------------------------------------------------------------- + +infixl 1 # +a # b = apply a b +{-# 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) + f (isT a) (isT b) # (tt a) # (tt b) # 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 + +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) + c_multiplyI m # a # b # s #|"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) + c_multiplyL m # a # b # s #|"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 + f # a # u # s # v #| 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 + f # a # u # s # v #| 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 + g # a # s #| 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 + g # a # s # v #| 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 + g # a # u # s #| 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_C" zgeev :: 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 + g # a # l # v #| 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 + g # a # l #| 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 + g # a # l # v #| "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" + + +-- | 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" + + +----------------------------------------------------------------------------- + +eigSHAux f st m = unsafePerformIO $ do + l <- createVector r + v <- copy ColumnMajor m + f # l # 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' 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 + f # a' # s #| 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 + f # a # s #| 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 "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 + f # a' # r #| 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 + f # r #| 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 + f # tau # r #| 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) + f # (subVector 0 n tau') # res #| 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) + f # tau # r #| 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 + f # u # s #| 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) + f # piv # lu #| 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 + f # a # piv' # x #| 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) + f # piv # ldl #| 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 + diff --git a/src/Internal/Matrix.hs b/src/Internal/Matrix.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Matrix.hs @@ -0,0 +1,598 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + + + +-- | +-- 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 m = (irows m, icols m) +{-# INLINE size #-} + +rowOrder m = xCol m == 1 || cols m == 1 +{-# INLINE rowOrder #-} + +colOrder m = xRow m == 1 || rows m == 1 +{-# INLINE colOrder #-} + +is1d (size->(r,c)) = r==1 || c==1 +{-# INLINE is1d #-} + +-- data is not contiguous +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 => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b +amatr f x = inlinePerformIO (unsafeWith (xdat x) (return . f r c)) + where + r = fi (rows x) + c = fi (cols x) + +{-# INLINE amat #-} +amat :: Storable a => (CInt -> CInt -> CInt -> CInt -> Ptr a -> b) -> Matrix a -> b +amat f x = inlinePerformIO (unsafeWith (xdat x) (return . f 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 #-} + +infixl 1 # +a # b = apply a b +{-# INLINE (#) #-} + +-------------------------------------------------------------------------------- + +copy ord m = extractR ord m 0 (idxs[0,rows m-1]) 0 (idxs[0,cols m-1]) + +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) +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 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' m i j = xdat m `at'` (i * (xRow m) + j * (xCol m)) +{-# INLINE atM' #-} + +------------------------------------------------------------------ + +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 () + + +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 + +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 + +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 + +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 + +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 + +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 + +------------------------------------------------------------------- + +-- | 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 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 " ++ shDim (r,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)) + +shSize = shDim . size + +shDim (r,c) = "(" ++ show r ++"x"++ show c ++")" + +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 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 + f moder modec # vr # vc # m # r #|"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 f i j m r = f (fi i) (fi j) # m # r #|"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 f v = unsafePerformIO $ do + r <- createVector (dim v) + f # v # r #|"sortG" + return r + +sortIdxD = sortG c_sort_indexD +sortIdxF = sortG c_sort_indexF +sortIdxI = sortG c_sort_indexI +sortIdxL = sortG c_sort_indexL + +sortValD = sortG c_sort_valD +sortValF = sortG c_sort_valF +sortValI = sortG c_sort_valI +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 f u v = unsafePerformIO $ do + r <- createVector (dim v) + f # u # v # r #|"compareG" + return r + +compareD = compareG c_compareD +compareF = compareG c_compareF +compareI = compareG c_compareI +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 f c u v w = unsafePerformIO $ do + r <- createVector (dim v) + f # c # u # v # w # r #|"selectG" + return r + +selectD = selectG c_selectD +selectF = selectG c_selectF +selectI = selectG c_selectI +selectL = selectG c_selectL +selectC = selectG c_selectC +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 f i j m = unsafePerformIO $ do + r <- createMatrix RowMajor (rows i) (cols i) + f # i # j # m # r #|"remapG" + return r + +remapD = remapG c_remapD +remapF = remapG c_remapF +remapI = remapG c_remapI +remapL = remapG c_remapL +remapC = remapG c_remapC +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 f c x i1 i2 j1 j2 m = do + px <- newArray [x] + f (fi c) px (fi i1) (fi i2) (fi j1) (fi j2) # m #|"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 f v m1 m2 m3 = f # v # m1 # m2 # m3 #|"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 + +-------------------------------------------------------------------------------- + +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 + c_saveMatrix cname cformat # m #|"saveMatrix" + free cname + free cformat + return () + +-------------------------------------------------------------------------------- + diff --git a/src/Internal/Modular.hs b/src/Internal/Modular.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Modular.hs @@ -0,0 +1,469 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{- | +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) +import GHC.TypeLits +import Data.Proxy(Proxy) +import Foreign.ForeignPtr(castForeignPtr) +import Foreign.Storable +import Data.Ratio +import Data.Complex +import Control.DeepSeq ( NFData(..) ) + + + +-- | 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 (Real t, KnownNat m, Integral (Mod m t)) => Real (Mod m t) + where + toRational x = toInteger x % 1 + +instance (Integral t, KnownNat m, Num (Mod m t)) => 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 (Show (Mod m t), Num (Mod m 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 forall n t . (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) + +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) + + +instance forall m . KnownNat m => CTrans (Mod m I) +instance forall m . KnownNat m => CTrans (Mod m Z) + + +instance forall m . 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 forall m . 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 forall m . 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 forall m . 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 + ] + + diff --git a/src/Internal/Numeric.hs b/src/Internal/Numeric.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Numeric.hs @@ -0,0 +1,949 @@ +{-# 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 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) + +-------------------------------------------------------------------------------- + +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 u v = dim u == dim v && maxElement' (vectorMapI Abs (sub u v)) == 0 + scalar' x = fromList [x] + 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 u v = dim u == dim v && maxElement' (vectorMapL Abs (sub u v)) == 0 + scalar' x = fromList [x] + 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 u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0 + scalar' x = fromList [x] + 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 u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0 + scalar' x = fromList [x] + 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 u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 + scalar' x = fromList [x] + 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 u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 + scalar' x = fromList [x] + 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 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)] + +-------------------------------------------------------- + +-- | 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 + +-------------------------------------------------------------------------------- + diff --git a/src/Internal/Random.hs b/src/Internal/Random.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Random.hs @@ -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 + -> 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 + diff --git a/src/Internal/ST.hs b/src/Internal/ST.hs new file mode 100644 --- /dev/null +++ b/src/Internal/ST.hs @@ -0,0 +1,249 @@ +{-# 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 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 m = copy (orderOf m) m + +{-# 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 + +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 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 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 (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 (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) + diff --git a/src/Internal/Sparse.hs b/src/Internal/Sparse.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Sparse.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Internal.Sparse( + GMatrix(..), CSR(..), mkCSR, fromCSR, + mkSparse, mkDiagR, mkDense, + AssocMatrix, + toDense, + gmXv, (!#>) +)where + +import Internal.Vector +import Internal.Matrix +import Internal.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 Internal.Devel +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 + c_smXv # csrVals # csrCols # csrRows # v # 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 + c_smTXv # cscVals # cscRows # cscCols # v # 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 + 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 + diff --git a/src/Internal/Static.hs b/src/Internal/Static.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Static.hs @@ -0,0 +1,527 @@ +#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 : 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 Data.Proxy(Proxy) +import Foreign.Storable(Storable) +import Text.Printf + +-------------------------------------------------------------------------------- + +type ℝ = Double +type ℂ = Complex Double + +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) + 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 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), 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 (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), Fractional 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), Fractional 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 + diff --git a/src/Internal/Util.hs b/src/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Util.hs @@ -0,0 +1,896 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ViewPatterns #-} + + +----------------------------------------------------------------------------- +{- | +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, + unitary, + 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 + +type ℝ = Double +type ℕ = Int +type ℤ = Int +type ℂ = Complex Double + +-- | imaginary unit +iC :: C +iC = 0:+1 + +{- | Create a real vector. + +>>> vector [1..5] +fromList [1.0,2.0,3.0,4.0,5.0] + +-} +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 + +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 + + +norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> R +norm_Frob = norm_2 . flatten + +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 +unitary :: Vector Double -> Vector Double +unitary v = v / scalar (norm 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 +fromList [6.0,7.0,8.0,9.0,10.0] + +>>> 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 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 (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 n xs + | n == -1 = [] + | otherwise = y : pivotUp (n-1) ys + where + y:ys = redu' (n,xs) + + 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] + ] + diff --git a/src/Internal/Vector.hs b/src/Internal/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Vector.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} + + +-- | +-- 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) + +#ifdef BINARY +import Data.Binary +import Control.Monad(replicateM) +import qualified Data.ByteString.Internal as BS +import Data.Vector.Storable.Internal(updPtr) +#endif + +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 + + +-- C-Haskell vector adapter +{-# INLINE avec #-} +avec :: Storable a => (CInt -> Ptr a -> b) -> Vector a -> b +avec f v = inlinePerformIO (unsafeWith v (return . f (fromIntegral (Vector.length v)))) +infixl 1 `avec` + +-- 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 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..] +fromList [1.0,2.0,3.0,4.0,5.0] + +-} +(|>) :: (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]) +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 @> +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] +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 + +-------------------------------------------------------------------------------- + + +-- | 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 (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 #-} + +-------------------------------------------------------------------------------- + + +#ifdef BINARY + +-- 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 -> 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 + +#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 + +------------------------------------------------------------------- + diff --git a/src/Internal/Vectorized.hs b/src/Internal/Vectorized.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Vectorized.hs @@ -0,0 +1,518 @@ +{-# 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) + +infixl 1 # +a # b = applyRaw a b +{-# INLINE (#) #-} + +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 m = sumg (c_sumI m) + +sumL m = sumg (c_sumL m) + +sumg f x = unsafePerformIO $ do + r <- createVector 1 + f # x # r #| "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 f x = unsafePerformIO $ do + r <- createVector 1 + f # x # r #| "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 fun code v = unsafePerformIO $ do + r <- createVector 1 + fun (fromei code) # v # r #|"toScalarAux" + return (r @> 0) + +vectorMapAux fun code v = unsafePerformIO $ do + r <- createVector (dim v) + fun (fromei code) # v # r #|"vectorMapAux" + return r + +vectorMapValAux fun code val v = unsafePerformIO $ do + r <- createVector (dim v) + pval <- newArray [val] + fun (fromei code) pval # v # r #|"vectorMapValAux" + free pval + return r + +vectorZipAux fun code u v = unsafePerformIO $ do + r <- createVector (dim u) + fun (fromei code) # u # v # 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 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 + c_random_vector (fi seed) ((fi.fromEnum) dist) # r #|"randomVector" + return r + +foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> Double :> Ok + +-------------------------------------------------------------------------------- + +roundVector v = unsafePerformIO $ do + r <- createVector (dim v) + c_round_vector # v # r #|"roundVector" + return r + +foreign import ccall unsafe "round_vector" c_round_vector :: TVV Double + +-------------------------------------------------------------------------------- + +-- | +-- >>> range 5 +-- fromList [0,1,2,3,4] +-- +range :: Int -> Vector I +range n = unsafePerformIO $ do + r <- createVector n + c_range_vector # r #|"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 f v = unsafePerformIO $ do + r <- createVector (dim v) + f # v # r #|"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 f v = unsafePerformIO $ do + r <- createVector (dim v) + f # v # r #|"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 fun x = unsafePerformIO $ do + v <- createVector (dim x) + fun # x # v #|"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 + f # v # r #|"cloneVector" + return r + +-------------------------------------------------------------------------------- + +constantAux fun x n = unsafePerformIO $ do + v <- createVector n + px <- newArray [x] + fun px # v #|"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 + +---------------------------------------------------------------------- + diff --git a/src/Numeric/Chain.hs b/src/Numeric/Chain.hs deleted file mode 100644 --- a/src/Numeric/Chain.hs +++ /dev/null @@ -1,146 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Numeric.Chain --- Copyright : (c) Vivian McPhail 2010 --- License : BSD3 --- --- Maintainer : Vivian McPhail gmail.com> --- Stability : provisional --- Portability : portable --- --- optimisation of association order for chains of matrix multiplication --- ------------------------------------------------------------------------------ - -{-# LANGUAGE FlexibleContexts #-} - -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..] - --} - diff --git a/src/Numeric/Container.hs b/src/Numeric/Container.hs deleted file mode 100644 --- a/src/Numeric/Container.hs +++ /dev/null @@ -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 - diff --git a/src/Numeric/Conversion.hs b/src/Numeric/Conversion.hs deleted file mode 100644 --- a/src/Numeric/Conversion.hs +++ /dev/null @@ -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' - diff --git a/src/Numeric/LinearAlgebra.hs b/src/Numeric/LinearAlgebra.hs --- a/src/Numeric/LinearAlgebra.hs +++ b/src/Numeric/LinearAlgebra.hs @@ -1,22 +1,255 @@ --------------------------------------------------------------------------------- +{-# LANGUAGE FlexibleContexts #-} + +----------------------------------------------------------------------------- {- | 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: + -- + -- >>> 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 ] + + -- * 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, + -- ** 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, + singularValues, + leftSV, rightSV, + + -- * Eigendecomposition + eig, eigSH, + eigenvalues, eigenvaluesSH, + geigSH, + + -- * QR + qr, rq, 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, unitary, 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 + +{- | 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) diff --git a/src/Numeric/LinearAlgebra/Algorithms.hs b/src/Numeric/LinearAlgebra/Algorithms.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Algorithms.hs +++ /dev/null @@ -1,968 +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 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 - -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>=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 - diff --git a/src/Numeric/LinearAlgebra/Data.hs b/src/Numeric/LinearAlgebra/Data.hs --- a/src/Numeric/LinearAlgebra/Data.hs +++ b/src/Numeric/LinearAlgebra/Data.hs @@ -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, -- * 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 diff --git a/src/Numeric/LinearAlgebra/Devel.hs b/src/Numeric/LinearAlgebra/Devel.hs --- a/src/Numeric/LinearAlgebra/Devel.hs +++ b/src/Numeric/LinearAlgebra/Devel.hs @@ -17,16 +17,23 @@ -- -- @ glUniformMatrix4fv 0 1 (fromIntegral gl_TRUE) \`appMatrix\` perspective 0.01 100 (pi\/2) (4\/3) -- @ - module Data.Packed.Foreign, + module Internal.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, @@ -34,6 +41,7 @@ -- ** 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, @@ -54,13 +62,15 @@ GMatrix(..), -- * Misc - toByteString, fromByteString + toByteString, fromByteString, showInternal ) where -import Data.Packed.Foreign -import Data.Packed.Development -import Data.Packed.ST -import Data.Packed -import Numeric.Sparse +import Internal.Foreign +import Internal.Devel +import Internal.ST +import Internal.Vector +import Internal.Matrix +import Internal.Element +import Internal.Sparse diff --git a/src/Numeric/LinearAlgebra/HMatrix.hs b/src/Numeric/LinearAlgebra/HMatrix.hs --- a/src/Numeric/LinearAlgebra/HMatrix.hs +++ b/src/Numeric/LinearAlgebra/HMatrix.hs @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------ +-------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.HMatrix Copyright : (c) Alberto Ruiz 2006-14 @@ -6,230 +6,25 @@ 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 - - Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample, - - -- * Misc - meanCov, rowOuters, 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(..) -) 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 ] - ->>> a <> b -(3><2) - [ 56.0, 50.0 - , 121.0, 135.0 - , 186.0, 220.0 ] +compatibility with previous version, to be removed -} -(<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t -(<>) = mXm -infixr 8 <> - --- | 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 +module Numeric.LinearAlgebra.HMatrix ( + module Numeric.LinearAlgebra, + (¦),(——),ℝ,ℂ,(<·>),app,mul, cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH' +) where ->>> a <> x -(2><3) - [ 6.0, 1.0, 10.0 - , 15.0, 3.0, 26.0 ] +import Numeric.LinearAlgebra +import Internal.Util +import Internal.Algorithms(cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH') --} -linearSolve m b = A.mbLinearSolve m b +infixr 8 <·> +(<·>) :: Numeric t => Vector t -> Vector t -> t +(<·>) = dot --- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'. -nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m) +app m v = m #> v --- | 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 diff --git a/src/Numeric/LinearAlgebra/LAPACK.hs b/src/Numeric/LinearAlgebra/LAPACK.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/LAPACK.hs +++ /dev/null @@ -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 (). --- ------------------------------------------------------------------------------ -{-# 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 - diff --git a/src/Numeric/LinearAlgebra/Random.hs b/src/Numeric/LinearAlgebra/Random.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Random.hs +++ /dev/null @@ -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 - diff --git a/src/Numeric/LinearAlgebra/Static.hs b/src/Numeric/LinearAlgebra/Static.hs --- a/src/Numeric/LinearAlgebra/Static.hs +++ b/src/Numeric/LinearAlgebra/Static.hs @@ -1,5 +1,3 @@ -#if __GLASGOW_HASKELL__ >= 708 - {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -13,7 +11,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -25,19 +22,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, @@ -47,7 +44,7 @@ -- * Complex C, M, Her, her, 𝑖, -- * Products - (<>),(#>),(<·>), + (<>),(#>),(<.>), -- * Linear Systems linSolve, (<\>), -- * Factorizations @@ -58,26 +55,22 @@ Disp(..), Domain(..), withVector, withMatrix, toRows, toColumns, - Sized(..), Diag(..), Sym, sym, mTm, unSym + 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,chol) -import qualified Numeric.LinearAlgebra.HMatrix as LA + (<\>),fromList,takeDiag,svd,eig,eigSH, + eigenvalues,eigenvaluesSH,build, + qr,size,dot,chol,range,R,C,sym,mTm,unSym) +import qualified Numeric.LinearAlgebra as LA import Data.Proxy(Proxy) -import Numeric.LinearAlgebra.Static.Internal +import Internal.Static import Control.Arrow((***)) - - - - ud1 :: R n -> Vector ℝ ud1 (R (Dim v)) = v @@ -171,22 +164,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 = forall n m. (KnownNat n, KnownNat m) => L m n -type GSq = forall n. 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)) @@ -213,6 +207,10 @@ (<·>) :: R n -> R n -> ℝ (<·>) = dotR +infixr 8 <.> +(<.>) :: R n -> R n -> ℝ +(<.>) = dotR + -------------------------------------------------------------------------------- class Diag m d | m -> d @@ -294,10 +292,10 @@ 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 @@ -307,7 +305,7 @@ (l,v) = LA.eig m chol :: KnownNat n => Sym n -> Sq n -chol (extract . unSym -> m) = mkL $ LA.cholSH m +chol (extract . unSym -> m) = mkL $ LA.chol $ LA.trustSym m -------------------------------------------------------------------------------- @@ -502,7 +500,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 + | otherwise = u LA.<.> v crossC :: C 3 -> C 3 -> C 3 @@ -590,12 +588,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 @@ -617,24 +615,4 @@ instance (KnownNat n', KnownNat m') => Testable (L n' m') where checkT _ = test - -#else - -{- | -Module : Numeric.LinearAlgebra.Static -Copyright : (c) Alberto Ruiz 2014 -License : BSD3 -Stability : experimental - -Experimental interface with statically checked dimensions. - -This module requires GHC >= 7.8 - --} - -module Numeric.LinearAlgebra.Static -{-# WARNING "This module requires GHC >= 7.8" #-} -where - -#endif diff --git a/src/Numeric/LinearAlgebra/Static/Internal.hs b/src/Numeric/LinearAlgebra/Static/Internal.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Static/Internal.hs +++ /dev/null @@ -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 - diff --git a/src/Numeric/LinearAlgebra/Util.hs b/src/Numeric/LinearAlgebra/Util.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Util.hs +++ /dev/null @@ -1,505 +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 - ->>> 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]] - --- | a synonym for ('|||') (unicode 0x00a6, broken bar) -infixl 3 ¦ -(¦) :: Matrix Double -> Matrix Double -> Matrix Double -(¦) = (|||) - - --- | vertical concatenation of real matrices --- -(===) :: Matrix Double -> Matrix Double -> Matrix Double -infixl 2 === -a === b = fromBlocks [[a],[b]] - --- | a synonym for ('===') (unicode 0x2014, em dash) -(——) :: Matrix Double -> Matrix Double -> Matrix Double -infixl 2 —— -(——) = (===) - - -(#) :: 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 - ->>> 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 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") - diff --git a/src/Numeric/LinearAlgebra/Util/CG.hs b/src/Numeric/LinearAlgebra/Util/CG.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Util/CG.hs +++ /dev/null @@ -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 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 - diff --git a/src/Numeric/LinearAlgebra/Util/Convolution.hs b/src/Numeric/LinearAlgebra/Util/Convolution.hs deleted file mode 100644 --- a/src/Numeric/LinearAlgebra/Util/Convolution.hs +++ /dev/null @@ -1,150 +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 qualified Data.Vector.Storable as SV -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' = 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 - diff --git a/src/Numeric/Matrix.hs b/src/Numeric/Matrix.hs --- a/src/Numeric/Matrix.hs +++ b/src/Numeric/Matrix.hs @@ -26,18 +26,20 @@ ------------------------------------------------------------------- -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 Internal.Chain ------------------------------------------------------------------- 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 +50,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 (/) diff --git a/src/Numeric/Sparse.hs b/src/Numeric/Sparse.hs deleted file mode 100644 --- a/src/Numeric/Sparse.hs +++ /dev/null @@ -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 - - diff --git a/src/Numeric/Vector.hs b/src/Numeric/Vector.hs --- a/src/Numeric/Vector.hs +++ b/src/Numeric/Vector.hs @@ -19,9 +19,10 @@ 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 ------------------------------------------------------------------- @@ -32,6 +33,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 +83,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 diff --git a/src/Numeric/Vectorized.hs b/src/Numeric/Vectorized.hs deleted file mode 100644 --- a/src/Numeric/Vectorized.hs +++ /dev/null @@ -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 -