diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,30 @@ +Copyright (c) Patrick Perry 2010 +Copyright (c) Carter Schonwald 2012 +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,100 @@ +Changes in 0.8.0.1 + +Changes in 0.8: + +* Use GADTs to and remove the element type from the typeclasses. This + makes the function signatures a lot nicer to read and write. + +* Put structural operations ( swap, copy, vconj ) in Elem. This removes the + BLAS1 constraint from the structural functions like getRow. + +* Allowing reading from immutable types in arbitrary monads. + +* Add binding to "ger". + +* Add functional dependency m -> a in Write{Vector,Matrix,Banded} a m + +* Add test coverage for all code paths in matrix multiplication and solve + routines. Fix bugs in bindings to gemv and hemm. + +* Specialize multiplication and solve routines for Doubles so that they + ignore complex conjugacy information. + +Changes in 0.7.6: + +* Fix a memory-trashing segfault. + +Changes in 0.7.5: + +* Export all unsafe functions in Unsafe.BLAS. + +* Use enumerations instead of Bools in data types. + +Changes in 0.7: + +* Get rid of most functional dependencies in favor of type families. + There is one remaining functional dependency that cannot be gotten + rid of until GHC implements equality constraints in superclass + contexts. + +* Put the right superclass constraints in ReadMatrix/ReadBanded. + +* Fix freeze/thaw functions. + +* Fix a bug in getting a row view of a banded matrix. + +* Make sure no NaNs/Infinities/Denormals are used when testing. + +* Documentation. + +* Export functions for writing QuickCheck tests. + +* Remove Perm and Diag. These will be in the LAPACK bindings. + +* Get rid of "UnsafeIOToM" type class. + +* Lots of INLINE everywhere. This should improve performance. + +* Switch to autoconf for build system. + +* Massive code cleanup. + + +Changes in 0.6: + +* Massive overhaul of the types. It is now possible to do mutable operations + in the ST monad. Access control is done via type classes now instead of + phantom types. + +* No more orphan instances. + +* Change some function names. You should never have to "import qualified" + anything now. + +* Put row/col operations in the Matrix type classes. Generic matrix types + now provide access to rows and columns. + + +Changes in 0.5: + +* Add Banded matrix data type, as well as Tri Banded and Herm Banded. + +* Add support for trapezoidal dense matrices (Tri Matrix (m,n) e, where + m is not the same as n). Note that trapezoidal banded matrices are + *NOT* supported. + +* Add Diag matrix data type for diagonal matrices. + +* Add Perm matrix data type, for permutation matrices. + +* Enhance the RMatrix and RSolve type classes with an API that allows + specifying where to store the result of a computation. + +* Enhance the IMatrix, RMatrix, ISolve, and RSolve type classes to add + "scale and multiply" operations. + +* Remove the scale parameter for Tri and Herm matrix data types. + +* Flatten the data types for DVector and DMatrix. + +* Some inlining and unpacking performance improvements. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,17 @@ + +To build the package, there is no need to run the configure script. Just +use the standard cabal commands: + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +The package uses a script to find what BLAS and LAPACK libraries to link with. +To link with a custom BLAS or LAPACK, add the "--with-blas=" +or "--with-lapack=" argument to --configure-option. For example, + + runhaskell Setup.lhs configure --configure-option="--with-blas=" + +To build this package from the git repository, first run + aclocal -I m4 + autoreconf diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,14 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> import Distribution.Simple.LocalBuildInfo +> import Distribution.PackageDescription +> import System.Cmd +> import System.FilePath +> +> main = defaultMainWithHooks autoconfUserHooks { runTests = runTests' } +> +> runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +> runTests' _ _ _ lbi = system testprog >> return () +> where testprog = (buildDir lbi) +> "test-hs-linear-algebra" +> "test-hs-linear-algebra" diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,67 @@ + +One great way to help is just to use the library, and give me feedback from +your experience. What do you like? What don't you like? What is fast? +What is slow? This stuff is really important for me to know. + +If you are interested in hacking on the library, there is tons of work to do. +Here is a partial list. Let me know what you would like to work on, and I can +give you some guidance on the best way to approach the task. + +Small projects +-------------- + +* Write tests. Look at the HPC output (from `make hpc` in the `tests` + directory), to find what functions are not being tested. + +* Write benchmarks, especially ones that allow comparisons with C or Fortran. + The LU decomposition in the examples directory is a good starting point. + +* Write a tutorial or blog post about the library. + +* The tests for solving triangular systems fail when an ill-conditioned + matrix gets generated. I have investigated some of the failing cases + in R, and have determined this isn't a bug. Ideally, we should only + test with well-conditioned systems. + +* Add conversions from Herm Matrix to Matrix. + +* Add conversions from Tri Matrix to Matrix. + +* investigate test failure + weightedMeanVector (equal weights): [OK, passed 100 tests] +VectorList 1 [fromList [0.0] :: Data.Vector.Storable.Vector] +fromList [0.0] :: Data.Vector.Storable.Vector +UnbiasedCov + covMatrix: [Failed] + +* Check arguments in shiftDiagWithScale (Matrix) + +* Don't use conjugateTo with same argument in conjTransTo + +* Optimize unsafeGetRow (use BLAS1) + +Medium projects +--------------- + +* I haven't really tested it, but probably the library doesn't build on + Windows. See if it is possible to build the library on windows. If + not, figure out how to do so. This may involve using something other + than autoconf on windows. + +* Write tests for STBanded. The easiest way to do this is to mimic what is + done in the STMatrix tests. + + +Big Projects +------------ + +* Support for packed storage of symmetric and triangular matrices. + Add a Data.Matrix.Packed class with a heirarchy similar to + Data.Matrix.Banded. Provide MMatrix/IMatrix instances for + Tri Packed and Herm Packed. + +* Switch over from error calls to extensible exceptions from base-4.0; + Throw "dimension mismatch" exceptions rather than just calling + error. This allows for better reporting. In particular, the covariance + match computations should catch any dimension mismatch exceptions and then + provide a more user-friendly message. diff --git a/aclocal.m4 b/aclocal.m4 new file mode 100644 --- /dev/null +++ b/aclocal.m4 @@ -0,0 +1,16 @@ +# generated automatically by aclocal 1.13.1 -*- Autoconf -*- + +# Copyright (C) 1996-2012 Free Software Foundation, Inc. + +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY, to the extent permitted by law; without +# even the implied warranty of MERCHANTABILITY or FITNESS FOR A +# PARTICULAR PURPOSE. + +m4_ifndef([AC_CONFIG_MACRO_DIRS], [m4_defun([_AM_CONFIG_MACRO_DIRS], [])m4_defun([AC_CONFIG_MACRO_DIRS], [_AM_CONFIG_MACRO_DIRS($@)])]) +m4_include([m4/ax_check_blas.m4]) +m4_include([m4/ax_check_lapack.m4]) diff --git a/cbits/config.h.in b/cbits/config.h.in new file mode 100644 --- /dev/null +++ b/cbits/config.h.in @@ -0,0 +1,31 @@ +/* cbits/config.h.in. Generated from configure.ac by autoheader. */ + +/* Define to a macro mangling the given Fortan function name */ +#undef F77_FUNC + +/* Define if you have a BLAS library. */ +#undef HAVE_BLAS + +/* Define if you have LAPACK library. */ +#undef HAVE_LAPACK + +/* Define to 1 if you have the `m' library (-lm). */ +#undef HAVE_LIBM + +/* Define to the address where bug reports for this package should be sent. */ +#undef PACKAGE_BUGREPORT + +/* Define to the full name of this package. */ +#undef PACKAGE_NAME + +/* Define to the full name and version of this package. */ +#undef PACKAGE_STRING + +/* Define to the one symbol short name of this package. */ +#undef PACKAGE_TARNAME + +/* Define to the home page for this package. */ +#undef PACKAGE_URL + +/* Define to the version of this package. */ +#undef PACKAGE_VERSION diff --git a/cbits/vmath-double.c b/cbits/vmath-double.c new file mode 100644 --- /dev/null +++ b/cbits/vmath-double.c @@ -0,0 +1,342 @@ + +#include "config.h" +#include +#include +#include "vmath.h" + +#define la_int int + +extern void +F77_FUNC(daxpy) (const la_int *n, const double *da, const double *dx, + const la_int *incx, double *dy, const la_int *incy); + + + +static void +vdClear (int n, double *z) +{ + memset(z, 0, n * sizeof(double)); +} + +static void +vdCopy (int n, const double *x, double *z) +{ + if (x != z) { + memcpy(z, x, n * sizeof(double)); + } +} + +void +vdScale (int n, double alpha, const double *x, double *z) +{ + if (alpha == 1) { + vdCopy(n, x, z); + } else if (alpha == 0) { + vdClear(n, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha * x[i]; + } + } + + /* Note: Using dscal sometimes gives differences in the least + * significant bit of the answer */ +} + +void +vdShift (int n, double alpha, const double *x, double *z) +{ + if (alpha == 0) { + vdCopy(n, x, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha + x[i]; + } + } +} + +void +vdNeg (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = -x[i]; + } +} + +void +vdAbs (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = fabs(x[i]); + } +} + +static double +dsgn (double x) +{ + if (x == 0 || isnan(x)) { + return x; + } else { + return copysign(1, x); + } +} + +void +vdSgn (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = dsgn(x[i]); + } +} + +void +vdInv (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = 1.0 / x[i]; + } +} + +static void +vdAxpy (int n, double alpha, const double *x, const double *y, double *z) +{ + la_int one = 1; + double done = 1.0; + + if (alpha == 0) { + vdCopy(n, y, z); + } else if (y == z) { + F77_FUNC(daxpy) (&n, &alpha, x, &one, z, &one); + } else if (alpha == 1 && x == z) { + F77_FUNC(daxpy) (&n, &done, y, &one, z, &one); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha * x[i] + y[i]; + } + } +} + +void +vdAxpby (int n, double alpha, const double *x, double beta, const double *y, double *z) +{ + if (alpha == 0) { + vdScale(n, beta, y, z); + } else if (alpha == 1) { + vdAxpy(n, beta, y, x, z); + } else if (beta == 0) { + vdScale(n, alpha, x, z); + } else if (beta == 1) { + vdAxpy(n, alpha, x, y, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha * x[i] + beta * y[i]; + } + } +} + +void +vdAdd (int n, const double *x, const double *y, double *z) +{ + vdAxpy(n, 1, x, y, z); +} + +void vdSub (int n, const double *x, const double *y, double *z) +{ + vdAxpy(n, -1, y, x, z); +} + +void +vdMul (int n, const double *x, const double *y, double *z) +{ + /* Note: using dtbmv sometimes gives different answers in the lower + * bits of precision */ + + /*if (y == z) { + blas_dtbmv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, x, 1, + z, 1); + } else if (x == z) { + blas_dtbmv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, y, 1, + z, 1); + } else { */ + + int i; + for (i = 0; i < n; i++) { + z[i] = x[i] * y[i]; + } +} + +void +vdDiv (int n, const double *x, const double *y, double *z) +{ + /* Note: using dtbsv gives slightly different answers + */ + /*if (y == z) { + blas_dtbsv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, x, 1, + z, 1); + } else */ + + if (x == z) { + int i; + for (i = 0; i < n; i++) { + z[i] = z[i] / y[i]; + } + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = x[i] / y[i]; + } + } +} + +void +vdExp (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = exp(x[i]); + } +} + +void +vdSqrt (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = sqrt(x[i]); + } +} + +void +vdLog (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = log(x[i]); + } +} + +void +vdPow (int n, const double *x, const double *y, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = pow(x[i], y[i]); + } +} + +void +vdSin (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = sin(x[i]); + } +} + +void +vdCos (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cos(x[i]); + } +} + +void +vdTan (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = tan(x[i]); + } +} + +void +vdASin (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = asin(x[i]); + } +} + +void +vdACos (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = acos(x[i]); + } +} + +void +vdATan (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = atan(x[i]); + } +} + +void +vdSinh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = sinh(x[i]); + } +} + +void +vdCosh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cosh(x[i]); + } +} + +void +vdTanh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = tanh(x[i]); + } +} + +void +vdASinh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = asinh(x[i]); + } +} + +void +vdACosh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = acosh(x[i]); + } +} + +void +vdATanh (int n, const double *x, double *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = atanh(x[i]); + } +} + diff --git a/cbits/vmath-zomplex.c b/cbits/vmath-zomplex.c new file mode 100644 --- /dev/null +++ b/cbits/vmath-zomplex.c @@ -0,0 +1,369 @@ + +#include "config.h" +#include +#include +#include "vmath.h" + +#define la_int int + +extern void +F77_FUNC(zaxpy) (const la_int *n, const void *za, const void *zx, + const la_int *incx, void *zy, const la_int *incy); + + +static double complex +complex_mul (double complex x, double complex y) +{ + double xr = creal(x), xi = cimag(x); + double yr = creal(y), yi = cimag(y); + double zr = xr * yr - xi * yi; + double zi = xr * yi + xi * yr; + double complex z = zr + I * zi; + return z; +} + + +static void +vzClear (int n, double complex *z) +{ + memset(z, 0, n * 2 * sizeof(double)); +} + +static void +vzCopy (int n, const double complex *x, double complex *z) +{ + if (x != z) { + memcpy(z, x, n * 2 * sizeof(double)); + } +} + +void +vzConj (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = conj(x[i]); + } +} + +void +vzScale (int n, const double complex *palpha, const double complex *x, double complex *z) +{ + double complex alpha = *palpha; + + if (alpha == 1) { + vzCopy(n, x, z); + } else if (alpha == 0) { + vzClear(n, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = complex_mul(alpha, x[i]); + } + } + + /* Note: Using zscal sometimes gives differences in the least + * significant bit of the answer */ +} + +void +vzShift (int n, const double complex *palpha, const double complex *x, double complex *z) +{ + double complex alpha = *palpha; + + if (alpha == 0) { + vzCopy(n, x, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha + x[i]; + } + } +} + +void +vzNeg (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = -x[i]; + } +} + +void +vzAbs (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cabs(x[i]) + 0*I; + } +} + +static void +zsgn (const double complex x, double complex *z) +{ + if (x == 0) { + *z = x; + } else { + double r = cabs(x); + *z = creal(x)/r + cimag(x)/r*I; + } +} + +void +vzSgn (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + zsgn(x[i], &(z[i])); + } +} + +void +vzInv (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = 1.0 / x[i]; + } +} + +static void +vzAxpy (int n, const double complex *palpha, const double complex *x, const double complex *y, double complex *z) +{ + double complex alpha = *palpha; + la_int one = 1; + + if (alpha == 0) { + vzCopy(n, y, z); + } else if (y == z) { + F77_FUNC(zaxpy) (&n, palpha, x, &one, z, &one); + } else if (alpha == 1 && x == z) { + F77_FUNC(zaxpy) (&n, palpha, y, &one, z, &one); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha * x[i] + y[i]; + } + } +} + +void +vzAxpby (int n, const double complex *palpha, const double complex *x, const double complex *pbeta, const double complex *y, double complex *z) +{ + double complex alpha = *palpha; + double complex beta = *pbeta; + + if (alpha == 0) { + vzScale(n, pbeta, y, z); + } else if (alpha == 1) { + vzAxpy(n, pbeta, y, x, z); + } else if (beta == 0) { + vzScale(n, palpha, x, z); + } else if (beta == 1) { + vzAxpy(n, palpha, x, y, z); + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = alpha * x[i] + beta * y[i]; + } + } +} + +void +vzAdd (int n, const double complex *x, const double complex *y, double complex *z) +{ + vdAdd(2 * n, (const double *)x, (const double *)y, (double *)z); +} + +void vzSub (int n, const double complex *x, const double complex *y, double complex *z) +{ + vdSub(2 * n, (const double *)x, (const double *)y, (double *)z); +} + +void +vzMul (int n, const double complex *x, const double complex *y, double complex *z) +{ + /* Note: using ztbmv sometimes gives different answers in the lower + * bits of precision */ + /* + if (y == z) { + blas_ztbmv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, x, 1, + z, 1); + } else if (x == z) { + blas_ztbmv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, y, 1, + z, 1); + } */ + int i; + for (i = 0; i < n; i++) { + z[i] = complex_mul(x[i], y[i]); + } +} + +void +vzDiv (int n, const double complex *x, const double complex *y, double complex *z) +{ + /* Note: using dtbsv gives slightly different answers + */ + /* + if (y == z) { + blas_ztbsv(BlasUpper, BlasNoTrans, BlasNonUnit, n, 0, x, 1, + z, 1); + } else */ + if (x == z) { + int i; + for (i = 0; i < n; i++) { + z[i] = z[i] / y[i]; + } + } else { + int i; + for (i = 0; i < n; i++) { + z[i] = x[i] / y[i]; + } + } +} + +void +vzExp (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cexp(x[i]); + } +} + +void +vzSqrt (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = csqrt(x[i]); + } +} + +void +vzLog (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = clog(x[i]); + } +} + +void +vzPow (int n, const double complex *x, const double complex *y, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cpow(x[i], y[i]); + } +} + +void +vzSin (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = csin(x[i]); + } +} + +void +vzCos (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = ccos(x[i]); + } +} + +void +vzTan (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = ctan(x[i]); + } +} + +void +vzASin (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = casin(x[i]); + } +} + +void +vzACos (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cacos(x[i]); + } +} + +void +vzATan (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = catan(x[i]); + } +} + +void +vzSinh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = csinh(x[i]); + } +} + +void +vzCosh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = ccosh(x[i]); + } +} + +void +vzTanh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = ctanh(x[i]); + } +} + +void +vzASinh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = casinh(x[i]); + } +} + +void +vzACosh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = cacosh(x[i]); + } +} + +void +vzATanh (int n, const double complex *x, double complex *z) +{ + int i; + for (i = 0; i < n; i++) { + z[i] = catanh(x[i]); + } +} + diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,5684 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69 for Haskell Linear Algebra 0.8. +# +# Report bugs to . +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org and patperry@gmail.com +$0: about your system, including any error possibly output +$0: before this message. Then install a modern shell, or +$0: manually run the script under such a shell if you do +$0: have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME='Haskell Linear Algebra' +PACKAGE_TARNAME='haskell-linear-algebra' +PACKAGE_VERSION='0.8' +PACKAGE_STRING='Haskell Linear Algebra 0.8' +PACKAGE_BUGREPORT='patperry@gmail.com' +PACKAGE_URL='' + +ac_unique_file="linear-algebra.cabal" +ac_subst_vars='LTLIBOBJS +LIBOBJS +BUILD_PACKAGE_BOOL +LAPACK_LIBS +BLAS_LIBS +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +with_compiler +with_blas +with_lapack +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures Haskell Linear Algebra 0.8 to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root + [DATAROOTDIR/doc/haskell-linear-algebra] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + case $ac_init_help in + short | recursive ) echo "Configuration of Haskell Linear Algebra 0.8:";; + esac + cat <<\_ACEOF + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-compiler= use Haskell compiler + --with-blas= use BLAS library + --with-lapack= use LAPACK library + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + LIBS libraries to pass to the linker, e.g. -l + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if + you have headers in a nonstandard directory + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to . +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +Haskell Linear Algebra configure 0.8 +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link + +# ac_fn_c_check_func LINENO FUNC VAR +# ---------------------------------- +# Tests whether FUNC exists, setting the cache variable VAR accordingly +ac_fn_c_check_func () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +/* Define $2 to an innocuous variant, in case declares $2. + For example, HP-UX 11i declares gettimeofday. */ +#define $2 innocuous_$2 + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $2 (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $2 + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $2 (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined __stub_$2 || defined __stub___$2 +choke me +#endif + +int +main () +{ +return $2 (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_func +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by Haskell Linear Algebra $as_me 0.8, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + +# Check whether --with-compiler was given. +if test "${with_compiler+set}" = set; then : + withval=$with_compiler; +fi + + +# Checks for programs + +# Checks for libraries +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include +#include +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for cos in -lm" >&5 +$as_echo_n "checking for cos in -lm... " >&6; } +if ${ac_cv_lib_m_cos+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lm $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char cos (); +int +main () +{ +return cos (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_m_cos=yes +else + ac_cv_lib_m_cos=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_cos" >&5 +$as_echo "$ac_cv_lib_m_cos" >&6; } +if test "x$ac_cv_lib_m_cos" = xyes; then : + cat >>confdefs.h <<_ACEOF +#define HAVE_LIBM 1 +_ACEOF + + LIBS="-lm $LIBS" + +fi + + + +ax_blas_ok=no + + +# Check whether --with-blas was given. +if test "${with_blas+set}" = set; then : + withval=$with_blas; +fi + +case $with_blas in + yes | "") ;; + no) ax_blas_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) BLAS_LIBS="$with_blas" ;; + *) BLAS_LIBS="-l$with_blas" ;; +esac + + + + + + + +ax_blas_save_LIBS="$LIBS" +LIBS="$LIBS $FLIBS" + +# First, check BLAS_LIBS environment variable +if test x$ax_blas_ok = xno; then + if test x$BLAS_LIBS != x; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in $BLAS_LIBS" >&5 +$as_echo_n "checking for sgemm_ in $BLAS_LIBS... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ax_blas_ok=yes +else + BLAS_LIBS="" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ax_blas_ok" >&5 +$as_echo "$ax_blas_ok" >&6; } + LIBS="$save_LIBS" + fi +fi + +# BLAS linked to by default? (happens on some supercomputers) +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="$LIBS" + ac_fn_c_check_func "$LINENO" "sgemm_" "ac_cv_func_sgemm_" +if test "x$ac_cv_func_sgemm_" = xyes; then : + ax_blas_ok=yes +fi + + LIBS="$save_LIBS" +fi + +# BLAS in ATLAS library? (http://math-atlas.sourceforge.net/) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ATL_xerbla in -latlas" >&5 +$as_echo_n "checking for ATL_xerbla in -latlas... " >&6; } +if ${ac_cv_lib_atlas_ATL_xerbla+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char ATL_xerbla (); +int +main () +{ +return ATL_xerbla (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_atlas_ATL_xerbla=yes +else + ac_cv_lib_atlas_ATL_xerbla=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_atlas_ATL_xerbla" >&5 +$as_echo "$ac_cv_lib_atlas_ATL_xerbla" >&6; } +if test "x$ac_cv_lib_atlas_ATL_xerbla" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lf77blas" >&5 +$as_echo_n "checking for sgemm_ in -lf77blas... " >&6; } +if ${ac_cv_lib_f77blas_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lf77blas -latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_f77blas_sgemm_=yes +else + ac_cv_lib_f77blas_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_f77blas_sgemm_" >&5 +$as_echo "$ac_cv_lib_f77blas_sgemm_" >&6; } +if test "x$ac_cv_lib_f77blas_sgemm_" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cblas_dgemm in -lcblas" >&5 +$as_echo_n "checking for cblas_dgemm in -lcblas... " >&6; } +if ${ac_cv_lib_cblas_cblas_dgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcblas -lf77blas -latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char cblas_dgemm (); +int +main () +{ +return cblas_dgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_cblas_cblas_dgemm=yes +else + ac_cv_lib_cblas_cblas_dgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cblas_cblas_dgemm" >&5 +$as_echo "$ac_cv_lib_cblas_cblas_dgemm" >&6; } +if test "x$ac_cv_lib_cblas_cblas_dgemm" = xyes; then : + ax_blas_ok=yes + BLAS_LIBS="-lcblas -lf77blas -latlas" +fi + +fi + +fi + +fi + +# BLAS in Intel MKL library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lmkl" >&5 +$as_echo_n "checking for sgemm_ in -lmkl... " >&6; } +if ${ac_cv_lib_mkl_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmkl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_mkl_sgemm_=yes +else + ac_cv_lib_mkl_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mkl_sgemm_" >&5 +$as_echo "$ac_cv_lib_mkl_sgemm_" >&6; } +if test "x$ac_cv_lib_mkl_sgemm_" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lmkl" +fi + +fi + +# BLAS in Apple vecLib library? +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS" + unset ac_cv_func_sgemm_ + ac_fn_c_check_func "$LINENO" "sgemm_" "ac_cv_func_sgemm_" +if test "x$ac_cv_func_sgemm_" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lblas" +fi + + LIBS="$save_LIBS" +fi + +# BLAS in PhiPACK libraries? (requires generic BLAS lib, too) +if test $ax_blas_ok = no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lblas" >&5 +$as_echo_n "checking for sgemm_ in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm_=yes +else + ac_cv_lib_blas_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm_" >&5 +$as_echo "$ac_cv_lib_blas_sgemm_" >&6; } +if test "x$ac_cv_lib_blas_sgemm_" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dgemm_ in -ldgemm" >&5 +$as_echo_n "checking for dgemm_ in -ldgemm... " >&6; } +if ${ac_cv_lib_dgemm_dgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldgemm -lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dgemm_ (); +int +main () +{ +return dgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dgemm_dgemm_=yes +else + ac_cv_lib_dgemm_dgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dgemm_dgemm_" >&5 +$as_echo "$ac_cv_lib_dgemm_dgemm_" >&6; } +if test "x$ac_cv_lib_dgemm_dgemm_" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lsgemm" >&5 +$as_echo_n "checking for sgemm_ in -lsgemm... " >&6; } +if ${ac_cv_lib_sgemm_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsgemm -lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sgemm_sgemm_=yes +else + ac_cv_lib_sgemm_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sgemm_sgemm_" >&5 +$as_echo "$ac_cv_lib_sgemm_sgemm_" >&6; } +if test "x$ac_cv_lib_sgemm_sgemm_" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas" +fi + +fi + +fi + +fi + +# BLAS in Alpha CXML library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lcxml" >&5 +$as_echo_n "checking for sgemm_ in -lcxml... " >&6; } +if ${ac_cv_lib_cxml_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcxml $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_cxml_sgemm_=yes +else + ac_cv_lib_cxml_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cxml_sgemm_" >&5 +$as_echo "$ac_cv_lib_cxml_sgemm_" >&6; } +if test "x$ac_cv_lib_cxml_sgemm_" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lcxml" +fi + +fi + +# BLAS in Alpha DXML library? (now called CXML, see above) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -ldxml" >&5 +$as_echo_n "checking for sgemm_ in -ldxml... " >&6; } +if ${ac_cv_lib_dxml_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldxml $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dxml_sgemm_=yes +else + ac_cv_lib_dxml_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dxml_sgemm_" >&5 +$as_echo "$ac_cv_lib_dxml_sgemm_" >&6; } +if test "x$ac_cv_lib_dxml_sgemm_" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-ldxml" +fi + +fi + +# BLAS in Sun Performance library? +if test x$ax_blas_ok = xno; then + if test "x$GCC" != xyes; then # only works with Sun CC + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for acosp in -lsunmath" >&5 +$as_echo_n "checking for acosp in -lsunmath... " >&6; } +if ${ac_cv_lib_sunmath_acosp+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsunmath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char acosp (); +int +main () +{ +return acosp (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sunmath_acosp=yes +else + ac_cv_lib_sunmath_acosp=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunmath_acosp" >&5 +$as_echo "$ac_cv_lib_sunmath_acosp" >&6; } +if test "x$ac_cv_lib_sunmath_acosp" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lsunperf" >&5 +$as_echo_n "checking for sgemm_ in -lsunperf... " >&6; } +if ${ac_cv_lib_sunperf_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsunperf -lsunmath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sunperf_sgemm_=yes +else + ac_cv_lib_sunperf_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunperf_sgemm_" >&5 +$as_echo "$ac_cv_lib_sunperf_sgemm_" >&6; } +if test "x$ac_cv_lib_sunperf_sgemm_" = xyes; then : + BLAS_LIBS="-xlic_lib=sunperf -lsunmath" + ax_blas_ok=yes +fi + +fi + + fi +fi + +# BLAS in SCSL library? (SGI/Cray Scientific Library) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lscs" >&5 +$as_echo_n "checking for sgemm_ in -lscs... " >&6; } +if ${ac_cv_lib_scs_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lscs $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_scs_sgemm_=yes +else + ac_cv_lib_scs_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_scs_sgemm_" >&5 +$as_echo "$ac_cv_lib_scs_sgemm_" >&6; } +if test "x$ac_cv_lib_scs_sgemm_" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lscs" +fi + +fi + +# BLAS in SGIMATH library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lcomplib.sgimath" >&5 +$as_echo_n "checking for sgemm_ in -lcomplib.sgimath... " >&6; } +if ${ac_cv_lib_complib_sgimath_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcomplib.sgimath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_complib_sgimath_sgemm_=yes +else + ac_cv_lib_complib_sgimath_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_complib_sgimath_sgemm_" >&5 +$as_echo "$ac_cv_lib_complib_sgimath_sgemm_" >&6; } +if test "x$ac_cv_lib_complib_sgimath_sgemm_" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath" +fi + +fi + +# BLAS in IBM ESSL library? (requires generic BLAS lib, too) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lblas" >&5 +$as_echo_n "checking for sgemm_ in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm_=yes +else + ac_cv_lib_blas_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm_" >&5 +$as_echo "$ac_cv_lib_blas_sgemm_" >&6; } +if test "x$ac_cv_lib_blas_sgemm_" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lessl" >&5 +$as_echo_n "checking for sgemm_ in -lessl... " >&6; } +if ${ac_cv_lib_essl_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lessl -lblas $FLIBS $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_essl_sgemm_=yes +else + ac_cv_lib_essl_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_essl_sgemm_" >&5 +$as_echo "$ac_cv_lib_essl_sgemm_" >&6; } +if test "x$ac_cv_lib_essl_sgemm_" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lessl -lblas" +fi + +fi + +fi + +# Generic BLAS library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm_ in -lblas" >&5 +$as_echo_n "checking for sgemm_ in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm_+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm_ (); +int +main () +{ +return sgemm_ (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm_=yes +else + ac_cv_lib_blas_sgemm_=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm_" >&5 +$as_echo "$ac_cv_lib_blas_sgemm_" >&6; } +if test "x$ac_cv_lib_blas_sgemm_" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lblas" +fi + +fi + +LIBS="$ax_blas_save_LIBS" + + + + + +if test x$ax_blas_ok = xyes; then + ax_blas_underscore=yes +else + + + + + + +ax_blas_save_LIBS="$LIBS" +LIBS="$LIBS $FLIBS" + +# First, check BLAS_LIBS environment variable +if test x$ax_blas_ok = xno; then + if test x$BLAS_LIBS != x; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in $BLAS_LIBS" >&5 +$as_echo_n "checking for sgemm in $BLAS_LIBS... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ax_blas_ok=yes +else + BLAS_LIBS="" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ax_blas_ok" >&5 +$as_echo "$ax_blas_ok" >&6; } + LIBS="$save_LIBS" + fi +fi + +# BLAS linked to by default? (happens on some supercomputers) +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="$LIBS" + ac_fn_c_check_func "$LINENO" "sgemm" "ac_cv_func_sgemm" +if test "x$ac_cv_func_sgemm" = xyes; then : + ax_blas_ok=yes +fi + + LIBS="$save_LIBS" +fi + +# BLAS in ATLAS library? (http://math-atlas.sourceforge.net/) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ATL_xerbla in -latlas" >&5 +$as_echo_n "checking for ATL_xerbla in -latlas... " >&6; } +if ${ac_cv_lib_atlas_ATL_xerbla+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char ATL_xerbla (); +int +main () +{ +return ATL_xerbla (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_atlas_ATL_xerbla=yes +else + ac_cv_lib_atlas_ATL_xerbla=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_atlas_ATL_xerbla" >&5 +$as_echo "$ac_cv_lib_atlas_ATL_xerbla" >&6; } +if test "x$ac_cv_lib_atlas_ATL_xerbla" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lf77blas" >&5 +$as_echo_n "checking for sgemm in -lf77blas... " >&6; } +if ${ac_cv_lib_f77blas_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lf77blas -latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_f77blas_sgemm=yes +else + ac_cv_lib_f77blas_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_f77blas_sgemm" >&5 +$as_echo "$ac_cv_lib_f77blas_sgemm" >&6; } +if test "x$ac_cv_lib_f77blas_sgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cblas_dgemm in -lcblas" >&5 +$as_echo_n "checking for cblas_dgemm in -lcblas... " >&6; } +if ${ac_cv_lib_cblas_cblas_dgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcblas -lf77blas -latlas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char cblas_dgemm (); +int +main () +{ +return cblas_dgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_cblas_cblas_dgemm=yes +else + ac_cv_lib_cblas_cblas_dgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cblas_cblas_dgemm" >&5 +$as_echo "$ac_cv_lib_cblas_cblas_dgemm" >&6; } +if test "x$ac_cv_lib_cblas_cblas_dgemm" = xyes; then : + ax_blas_ok=yes + BLAS_LIBS="-lcblas -lf77blas -latlas" +fi + +fi + +fi + +fi + +# BLAS in Intel MKL library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lmkl" >&5 +$as_echo_n "checking for sgemm in -lmkl... " >&6; } +if ${ac_cv_lib_mkl_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lmkl $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_mkl_sgemm=yes +else + ac_cv_lib_mkl_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mkl_sgemm" >&5 +$as_echo "$ac_cv_lib_mkl_sgemm" >&6; } +if test "x$ac_cv_lib_mkl_sgemm" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lmkl" +fi + +fi + +# BLAS in Apple vecLib library? +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS" + unset ac_cv_func_sgemm + ac_fn_c_check_func "$LINENO" "sgemm" "ac_cv_func_sgemm" +if test "x$ac_cv_func_sgemm" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lblas" +fi + + LIBS="$save_LIBS" +fi + +# BLAS in PhiPACK libraries? (requires generic BLAS lib, too) +if test $ax_blas_ok = no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 +$as_echo_n "checking for sgemm in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm=yes +else + ac_cv_lib_blas_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 +$as_echo "$ac_cv_lib_blas_sgemm" >&6; } +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dgemm in -ldgemm" >&5 +$as_echo_n "checking for dgemm in -ldgemm... " >&6; } +if ${ac_cv_lib_dgemm_dgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldgemm -lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char dgemm (); +int +main () +{ +return dgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dgemm_dgemm=yes +else + ac_cv_lib_dgemm_dgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dgemm_dgemm" >&5 +$as_echo "$ac_cv_lib_dgemm_dgemm" >&6; } +if test "x$ac_cv_lib_dgemm_dgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lsgemm" >&5 +$as_echo_n "checking for sgemm in -lsgemm... " >&6; } +if ${ac_cv_lib_sgemm_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsgemm -lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sgemm_sgemm=yes +else + ac_cv_lib_sgemm_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sgemm_sgemm" >&5 +$as_echo "$ac_cv_lib_sgemm_sgemm" >&6; } +if test "x$ac_cv_lib_sgemm_sgemm" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas" +fi + +fi + +fi + +fi + +# BLAS in Alpha CXML library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lcxml" >&5 +$as_echo_n "checking for sgemm in -lcxml... " >&6; } +if ${ac_cv_lib_cxml_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcxml $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_cxml_sgemm=yes +else + ac_cv_lib_cxml_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_cxml_sgemm" >&5 +$as_echo "$ac_cv_lib_cxml_sgemm" >&6; } +if test "x$ac_cv_lib_cxml_sgemm" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-lcxml" +fi + +fi + +# BLAS in Alpha DXML library? (now called CXML, see above) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -ldxml" >&5 +$as_echo_n "checking for sgemm in -ldxml... " >&6; } +if ${ac_cv_lib_dxml_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-ldxml $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_dxml_sgemm=yes +else + ac_cv_lib_dxml_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dxml_sgemm" >&5 +$as_echo "$ac_cv_lib_dxml_sgemm" >&6; } +if test "x$ac_cv_lib_dxml_sgemm" = xyes; then : + ax_blas_ok=yes;BLAS_LIBS="-ldxml" +fi + +fi + +# BLAS in Sun Performance library? +if test x$ax_blas_ok = xno; then + if test "x$GCC" != xyes; then # only works with Sun CC + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for acosp in -lsunmath" >&5 +$as_echo_n "checking for acosp in -lsunmath... " >&6; } +if ${ac_cv_lib_sunmath_acosp+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsunmath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char acosp (); +int +main () +{ +return acosp (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sunmath_acosp=yes +else + ac_cv_lib_sunmath_acosp=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunmath_acosp" >&5 +$as_echo "$ac_cv_lib_sunmath_acosp" >&6; } +if test "x$ac_cv_lib_sunmath_acosp" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lsunperf" >&5 +$as_echo_n "checking for sgemm in -lsunperf... " >&6; } +if ${ac_cv_lib_sunperf_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lsunperf -lsunmath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_sunperf_sgemm=yes +else + ac_cv_lib_sunperf_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_sunperf_sgemm" >&5 +$as_echo "$ac_cv_lib_sunperf_sgemm" >&6; } +if test "x$ac_cv_lib_sunperf_sgemm" = xyes; then : + BLAS_LIBS="-xlic_lib=sunperf -lsunmath" + ax_blas_ok=yes +fi + +fi + + fi +fi + +# BLAS in SCSL library? (SGI/Cray Scientific Library) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lscs" >&5 +$as_echo_n "checking for sgemm in -lscs... " >&6; } +if ${ac_cv_lib_scs_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lscs $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_scs_sgemm=yes +else + ac_cv_lib_scs_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_scs_sgemm" >&5 +$as_echo "$ac_cv_lib_scs_sgemm" >&6; } +if test "x$ac_cv_lib_scs_sgemm" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lscs" +fi + +fi + +# BLAS in SGIMATH library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lcomplib.sgimath" >&5 +$as_echo_n "checking for sgemm in -lcomplib.sgimath... " >&6; } +if ${ac_cv_lib_complib_sgimath_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lcomplib.sgimath $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_complib_sgimath_sgemm=yes +else + ac_cv_lib_complib_sgimath_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_complib_sgimath_sgemm" >&5 +$as_echo "$ac_cv_lib_complib_sgimath_sgemm" >&6; } +if test "x$ac_cv_lib_complib_sgimath_sgemm" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath" +fi + +fi + +# BLAS in IBM ESSL library? (requires generic BLAS lib, too) +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 +$as_echo_n "checking for sgemm in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm=yes +else + ac_cv_lib_blas_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 +$as_echo "$ac_cv_lib_blas_sgemm" >&6; } +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lessl" >&5 +$as_echo_n "checking for sgemm in -lessl... " >&6; } +if ${ac_cv_lib_essl_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lessl -lblas $FLIBS $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_essl_sgemm=yes +else + ac_cv_lib_essl_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_essl_sgemm" >&5 +$as_echo "$ac_cv_lib_essl_sgemm" >&6; } +if test "x$ac_cv_lib_essl_sgemm" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lessl -lblas" +fi + +fi + +fi + +# Generic BLAS library? +if test x$ax_blas_ok = xno; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for sgemm in -lblas" >&5 +$as_echo_n "checking for sgemm in -lblas... " >&6; } +if ${ac_cv_lib_blas_sgemm+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-lblas $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char sgemm (); +int +main () +{ +return sgemm (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_lib_blas_sgemm=yes +else + ac_cv_lib_blas_sgemm=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_blas_sgemm" >&5 +$as_echo "$ac_cv_lib_blas_sgemm" >&6; } +if test "x$ac_cv_lib_blas_sgemm" = xyes; then : + ax_blas_ok=yes; BLAS_LIBS="-lblas" +fi + +fi + +LIBS="$ax_blas_save_LIBS" + + + + + + if test x$ax_blas_ok = xyes; then + ax_blas_undersore=no + fi +fi + + +if test x$ax_blas_ok = xyes; then + + +$as_echo "#define HAVE_BLAS 1" >>confdefs.h + + + if test x$ax_blas_underscore = xyes; then + $as_echo "#define F77_FUNC(name) name ## _" >>confdefs.h + + else + $as_echo "#define F77_FUNC(name) name" >>confdefs.h + + fi + : +else + ax_blas_ok=no + +fi + + + + +ax_lapack_ok=no + + +# Check whether --with-lapack was given. +if test "${with_lapack+set}" = set; then : + withval=$with_lapack; +fi + +case $with_lapack in + yes | "") ;; + no) ax_lapack_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) LAPACK_LIBS="$with_lapack" ;; + *) LAPACK_LIBS="-l$with_lapack" ;; +esac + +# Get fortran linker name of LAPACK function to check for. +if test x"$ax_blas_underscore" = xyes; then + cheev=cheev_ +else + cheev=cheev +fi + +# We cannot use LAPACK if BLAS is not found +if test "x$ax_blas_ok" != xyes; then + ax_lapack_ok=noblas + LAPACK_LIBS="" +fi + +# First, check LAPACK_LIBS environment variable +if test "x$LAPACK_LIBS" != x; then + save_LIBS="$LIBS"; LIBS="$LAPACK_LIBS $BLAS_LIBS $LIBS" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $cheev in $LAPACK_LIBS" >&5 +$as_echo_n "checking for $cheev in $LAPACK_LIBS... " >&6; } + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $cheev (); +int +main () +{ +return $cheev (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ax_lapack_ok=yes +else + LAPACK_LIBS="" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ax_lapack_ok" >&5 +$as_echo "$ax_lapack_ok" >&6; } + LIBS="$save_LIBS" + if test $ax_lapack_ok = no; then + LAPACK_LIBS="" + fi +fi + +# LAPACK linked to by default? (is sometimes included in BLAS lib) +if test $ax_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$LIBS $BLAS_LIBS" + as_ac_var=`$as_echo "ac_cv_func_$cheev" | $as_tr_sh` +ac_fn_c_check_func "$LINENO" "$cheev" "$as_ac_var" +if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + ax_lapack_ok=yes +fi + + LIBS="$save_LIBS" +fi + +# Generic LAPACK library? +for lapack in lapack lapack_rs6k; do + if test $ax_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + as_ac_Lib=`$as_echo "ac_cv_lib_$lapack''_$cheev" | $as_tr_sh` +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $cheev in -l$lapack" >&5 +$as_echo_n "checking for $cheev in -l$lapack... " >&6; } +if eval \${$as_ac_Lib+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_check_lib_save_LIBS=$LIBS +LIBS="-l$lapack $LIBS" +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +/* Override any GCC internal prototype to avoid an error. + Use char because int might match the return type of a GCC + builtin and then its argument prototype would still apply. */ +#ifdef __cplusplus +extern "C" +#endif +char $cheev (); +int +main () +{ +return $cheev (); + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + eval "$as_ac_Lib=yes" +else + eval "$as_ac_Lib=no" +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +LIBS=$ac_check_lib_save_LIBS +fi +eval ac_res=\$$as_ac_Lib + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } +if eval test \"x\$"$as_ac_Lib"\" = x"yes"; then : + ax_lapack_ok=yes; LAPACK_LIBS="-l$lapack" +fi + + LIBS="$save_LIBS" + fi +done + + + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x"$ax_lapack_ok" = xyes; then + +$as_echo "#define HAVE_LAPACK 1" >>confdefs.h + + : +else + ax_lapack_ok=no + +fi + + +if test "$ax_lapack_ok" = yes; then + BUILD_PACKAGE_BOOL=True +else + BUILD_PACKAGE_BOOL=False +fi + + +ac_config_headers="$ac_config_headers cbits/config.h" + +ac_config_files="$ac_config_files linear-algebra.buildinfo" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by Haskell Linear Algebra $as_me 0.8, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + +case $ac_config_headers in *" +"*) set x $ac_config_headers; shift; ac_config_headers=$*;; +esac + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" +config_headers="$ac_config_headers" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to ." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +Haskell Linear Algebra config.status 0.8 +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + as_fn_append CONFIG_HEADERS " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "cbits/config.h") CONFIG_HEADERS="$CONFIG_HEADERS cbits/config.h" ;; + "linear-algebra.buildinfo") CONFIG_FILES="$CONFIG_FILES linear-algebra.buildinfo" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + +# Set up the scripts for CONFIG_HEADERS section. +# No need to generate them if there are no CONFIG_HEADERS. +# This happens for instance with `./config.status Makefile'. +if test -n "$CONFIG_HEADERS"; then +cat >"$ac_tmp/defines.awk" <<\_ACAWK || +BEGIN { +_ACEOF + +# Transform confdefs.h into an awk script `defines.awk', embedded as +# here-document in config.status, that substitutes the proper values into +# config.h.in to produce config.h. + +# Create a delimiter string that does not exist in confdefs.h, to ease +# handling of long lines. +ac_delim='%!_!# ' +for ac_last_try in false false :; do + ac_tt=`sed -n "/$ac_delim/p" confdefs.h` + if test -z "$ac_tt"; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done + +# For the awk script, D is an array of macro values keyed by name, +# likewise P contains macro parameters if any. Preserve backslash +# newline sequences. + +ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* +sed -n ' +s/.\{148\}/&'"$ac_delim"'/g +t rset +:rset +s/^[ ]*#[ ]*define[ ][ ]*/ / +t def +d +:def +s/\\$// +t bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3"/p +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p +d +:bsnl +s/["\\]/\\&/g +s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ +D["\1"]=" \3\\\\\\n"\\/p +t cont +s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p +t cont +d +:cont +n +s/.\{148\}/&'"$ac_delim"'/g +t clear +:clear +s/\\$// +t bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/"/p +d +:bsnlc +s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p +b cont +' >$CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + for (key in D) D_is_set[key] = 1 + FS = "" +} +/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { + line = \$ 0 + split(line, arg, " ") + if (arg[1] == "#") { + defundef = arg[2] + mac1 = arg[3] + } else { + defundef = substr(arg[1], 2) + mac1 = arg[2] + } + split(mac1, mac2, "(") #) + macro = mac2[1] + prefix = substr(line, 1, index(line, defundef) - 1) + if (D_is_set[macro]) { + # Preserve the white space surrounding the "#". + print prefix "define", macro P[macro] D[macro] + next + } else { + # Replace #undef with comments. This is necessary, for example, + # in the case of _POSIX_SOURCE, which is predefined and required + # on some systems where configure will not decide to define it. + if (defundef == "undef") { + print "/*", prefix defundef, macro, "*/" + next + } + } +} +{ print } +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 +fi # test -n "$CONFIG_HEADERS" + + +eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # + # CONFIG_HEADER + # + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" + } >"$ac_tmp/config.h" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 +$as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" + mv "$ac_tmp/config.h" "$ac_file" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ + && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ + || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + diff --git a/configure.ac b/configure.ac new file mode 100644 --- /dev/null +++ b/configure.ac @@ -0,0 +1,25 @@ +AC_PREREQ([2.61]) +AC_INIT([Haskell Linear Algebra], [0.8], [patperry@gmail.com]) + +AC_CONFIG_SRCDIR([linear-algebra.cabal]) +AC_CONFIG_MACRO_DIR([m4]) + +AC_ARG_WITH(compiler, + [AC_HELP_STRING([--with-compiler=], [use Haskell compiler ])]) + +# Checks for programs + +# Checks for libraries +AC_CHECK_LIB([m],[cos]) +AX_CHECK_LAPACK + +if test "$ax_lapack_ok" = yes; then + BUILD_PACKAGE_BOOL=True +else + BUILD_PACKAGE_BOOL=False +fi +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_CONFIG_HEADERS([cbits/config.h]) +AC_CONFIG_FILES([linear-algebra.buildinfo]) +AC_OUTPUT diff --git a/examples/LU.hs b/examples/LU.hs new file mode 100644 --- /dev/null +++ b/examples/LU.hs @@ -0,0 +1,64 @@ +module LU ( luFactor, luFactorM ) where + +import Control.Monad( zipWithM_ ) +import Control.Monad.ST( ST, runST ) + +import Numeric.LinearAlgebra +import qualified Numeric.LinearAlgebra.Matrix as M +import qualified Numeric.LinearAlgebra.Vector as V + + +luFactor :: (BLAS3 e) => Matrix e -> Either Int (Matrix e, [Int]) +luFactor a = runST $ do + ma <- M.newCopy a + luFactorM ma >>= + either (return . Left) (\pivots -> do + a' <- M.unsafeFreeze ma + return $ Right (a',pivots) + ) + +{- + - Recursive LU factorization with row pivoting. Takes a matrix + - A and factors it as P A = L U, where P is a permutation matrix, + - L is a lower triangular matrix with ones along the diagonal, and + - U is an upper triangular matrix. On successful return, the values of + - L and U are stored in A, and a list of the row swaps are returned. + - On failure, the index of the failing column is returned. + -} +luFactorM :: (BLAS3 e) => STMatrix s e -> ST s (Either Int [Int]) +luFactorM a = do + (m,n) <- M.getDim a + let mn = min m n + nleft = mn `div` 2 + + case undefined of + _ | mn > 1 -> + M.withSplitColsAtM nleft a $ \a_1 a_2 -> + M.withSplitRowsAtM nleft a_1 $ \a11 a21 -> + M.withSplitRowsAtM nleft a_2 $ \a12 a22 -> + luFactorM a_1 >>= + either (return . Left) (\pivots -> do + zipWithM_ (M.swapRows a_2) [ 0.. ] pivots + M.triSolvMatrixM_ LeftSide NoTrans (Tri Lower Unit a11) a12 + M.addMulMatrixWithScalesM_ (-1) NoTrans a21 NoTrans a12 1 a22 + luFactorM a22 >>= + either (return . Left . (nleft+)) (\pivots' -> do + zipWithM_ (M.swapRows a21) [ 0.. ] pivots' + return $ Right (pivots ++ map (nleft+) pivots') + ) + ) + + _ | mn == 1 -> + M.withColM a 0 $ \x -> + V.getWhichMaxAbs x >>= \(i,e) -> + if (e /= 0) + then do + V.scaleM_ (1/e) x + V.read x 0 >>= V.write x i + V.write x 0 e + return $ Right [i] + else + return $ Left 0 + + _ | otherwise -> + return $ Right [] diff --git a/lib/Foreign/BLAS.hs b/lib/Foreign/BLAS.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- BLAS operations. +-- + +module Foreign.BLAS ( + -- * BLAS typeclasses + module Foreign.BLAS.Level1, + module Foreign.BLAS.Level2, + module Foreign.BLAS.Level3, + -- * Enums + module Foreign.BLAS.Types, + ) where + +import Foreign.BLAS.Types +import Foreign.BLAS.Level1 +import Foreign.BLAS.Level2 +import Foreign.BLAS.Level3 diff --git a/lib/Foreign/BLAS/Double.hsc b/lib/Foreign/BLAS/Double.hsc new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Double.hsc @@ -0,0 +1,135 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Double +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.BLAS.Double + where + +import Foreign +import Foreign.C.Types +import Foreign.BLAS.Types + +#include "config.h" +#include "f77_func-hsc.h" + + +---------------------------- Level 1 Routines ------------------------------- + +foreign import ccall unsafe #f77_func ddot + ddot :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO Double + +foreign import ccall unsafe #f77_func dnrm2 + dnrm2 :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO Double + +foreign import ccall unsafe #f77_func dasum + dasum :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO Double + +foreign import ccall unsafe #f77_func idamax + idamax_hidden :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO CInt +-- for some reason ffi stuff wasn't working with return type IO LAInt +idamax :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO LAInt +idamax a b c = do res <- idamax_hidden a b c + return $! LAInt res + + +foreign import ccall unsafe #f77_func dscal + dscal :: Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dswap + dswap :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dcopy + dcopy :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func daxpy + daxpy :: Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func drotg + drotg :: Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe #f77_func drot + drot :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe #f77_func drotmg + drotmg :: Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe #f77_func drotm + drotm :: Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> IO () + + +---------------------------- Level 2 Routines ------------------------------- + +foreign import ccall unsafe #f77_func dgemv + dgemv :: BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dgbmv + dgbmv :: BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtrmv + dtrmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtpmv + dtpmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtpsv + dtpsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtbmv + dtbmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtrsv + dtrsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtbsv + dtbsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsymv + dsymv :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsbmv + dsbmv :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dger + dger :: Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsyr + dsyr :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsyr2 + dsyr2 :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dspmv + dspmv :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dspr + dspr :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> IO () + +foreign import ccall unsafe #f77_func dspr2 + dspr2 :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> IO () + + +---------------------------- Level 3 Routines ------------------------------- + +foreign import ccall unsafe #f77_func dgemm + dgemm :: BLASTrans -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsymm + dsymm :: BLASSide -> BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtrmm + dtrmm :: BLASSide -> BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dtrsm + dtrsm :: BLASSide -> BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsyrk + dsyrk :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsyr2k + dsyr2k :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> IO () diff --git a/lib/Foreign/BLAS/Level1.hs b/lib/Foreign/BLAS/Level1.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Level1.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Level1 +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Vector operations. +-- + +module Foreign.BLAS.Level1 ( + BLAS1(..), + ) where + +import Foreign( Storable, Ptr, peek, with ) +import Foreign.Storable.Complex() +import Data.Complex( Complex(..) ) + +import Foreign.VMath.VFractional( VFractional ) +import Foreign.BLAS.Double +import Foreign.BLAS.Zomplex + +-- | Types with vector-vector operations. +class (Storable a, VFractional a) => BLAS1 a where + copy :: Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + swap :: Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + dotc :: Int -> Ptr a -> Int -> Ptr a -> Int -> IO a + dotu :: Int -> Ptr a -> Int -> Ptr a -> Int -> IO a + nrm2 :: Int -> Ptr a -> Int -> IO Double + asum :: Int -> Ptr a -> Int -> IO Double + iamax :: Int -> Ptr a -> Int -> IO Int + + scal :: Int -> a -> Ptr a -> Int -> IO () + + axpy :: Int -> a -> Ptr a -> Int -> Ptr a -> Int -> IO () + + rotg :: Ptr a -> Ptr a -> Ptr a -> Ptr a -> IO () + rot :: Int -> Ptr a -> Int -> Ptr a -> Int -> Double -> Double -> IO () + + +withEnum :: (Enum a, Storable a) => Int -> (Ptr a -> IO b) -> IO b +withEnum = with . toEnum +{-# INLINE withEnum #-} + +instance BLAS1 Double where + copy n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + dcopy pn px pincx py pincy + {-# INLINE copy #-} + + swap n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + dswap pn px pincx py pincy + {-# INLINE swap #-} + + dotc n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + ddot pn px pincx py pincy + {-# INLINE dotc #-} + + dotu = dotc + {-# INLINE dotu #-} + + nrm2 n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + dnrm2 pn px pincx + {-# INLINE nrm2 #-} + + asum n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + dasum pn px pincx + {-# INLINE asum #-} + + iamax n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> do + i <- idamax pn px pincx + return $! fromEnum (i - 1) + {-# INLINE iamax #-} + + axpy n alpha px incx py incy = + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + daxpy pn palpha px pincx py pincy + {-# INLINE axpy #-} + + scal n alpha px incx = + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + dscal pn palpha px pincx + {-# INLINE scal #-} + + rotg = drotg + {-# INLINE rotg #-} + + rot n px incx py incy c s = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + with c $ \pc -> + with s $ \ps -> + drot pn px pincx py pincy pc ps + {-# INLINE rot #-} + + +instance BLAS1 (Complex Double) where + copy n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + zcopy pn px pincx py pincy + {-# INLINE copy #-} + + swap n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + zswap pn px pincx py pincy + {-# INLINE swap #-} + + dotc n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + with 0 $ \pdotc -> do + zdotc pdotc pn px pincx py pincy + peek pdotc + {-# INLINE dotc #-} + + dotu n px incx py incy = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + with 0 $ \pdotu -> do + zdotu pdotu pn px pincx py pincy + peek pdotu + {-# INLINE dotu #-} + + nrm2 n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + znrm2 pn px pincx + {-# INLINE nrm2 #-} + + asum n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + zasum pn px pincx + {-# INLINE asum #-} + + iamax n px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> do + i <- izamax pn px pincx + return $! fromEnum (i - 1) + {-# INLINE iamax #-} + + axpy n alpha px incx py incy = + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + zaxpy pn palpha px pincx py pincy + {-# INLINE axpy #-} + + scal n alpha px incx = + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + zscal pn palpha px pincx + {-# INLINE scal #-} + + rotg = zrotg + {-# INLINE rotg #-} + + rot n px incx py incy c s = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + with c $ \pc -> + with s $ \ps -> + zdrot pn px pincx py pincy pc ps + {-# INLINE rot #-} diff --git a/lib/Foreign/BLAS/Level2.hs b/lib/Foreign/BLAS/Level2.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Level2.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Level2 +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Matrix-Vector operations. +-- + +module Foreign.BLAS.Level2 ( + BLAS2(..), + ) where + +import Data.Complex +import Foreign( Ptr, Storable, with ) + +import Foreign.BLAS.Types +import Foreign.BLAS.Level1 +import Foreign.BLAS.Double +import Foreign.BLAS.Zomplex + +-- | Types with matrix-vector operations. +class (BLAS1 a) => BLAS2 a where + gbmv :: Trans -> Int -> Int -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + gemv :: Trans -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + gerc :: Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + geru :: Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + + hbmv :: Uplo -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + hemv :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + her :: Uplo -> Int -> Double -> Ptr a -> Int -> Ptr a -> Int -> IO () + her2 :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + hpmv :: Uplo -> Int -> a -> Ptr a -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + hpr :: Uplo -> Int -> Double -> Ptr a -> Int -> Ptr a -> IO () + hpr2 :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> IO () + + tbmv :: Uplo -> Trans -> Diag -> Int -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + tbsv :: Uplo -> Trans -> Diag -> Int -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + tpmv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Ptr a -> Int -> IO () + tpsv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Ptr a -> Int -> IO () + trmv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + trsv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () + + +withEnum :: (Enum a, Storable a) => Int -> (Ptr a -> IO b) -> IO b +withEnum = with . toEnum +{-# INLINE withEnum #-} + +instance BLAS2 Double where + gemv transa m n alpha pa lda px incx beta py incy = + withTrans transa $ \ptransa -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + dgemv ptransa pm pn palpha pa plda px pincx pbeta py pincy + {-# INLINE gemv #-} + + gbmv transa m n kl ku alpha pa lda px incx beta py incy = + withTrans transa $ \ptransa -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum kl $ \pkl -> + withEnum ku $ \pku -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + dgbmv ptransa pm pn pkl pku palpha pa plda px pincx pbeta py pincy + {-# INLINE gbmv #-} + + trmv uplo trans diag n pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + dtrmv puplo ptrans pdiag pn pa plda px pincx + {-# INLINE trmv #-} + + tpmv uplo trans diag n pap px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum incx $ \pincx -> + dtpmv puplo ptrans pdiag pn pap px pincx + {-# INLINE tpmv #-} + + tpsv uplo trans diag n pap px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum incx $ \pincx -> + dtpsv puplo ptrans pdiag pn pap px pincx + {-# INLINE tpsv #-} + + tbmv uplo trans diag n k pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + dtbmv puplo ptrans pdiag pn pk pa plda px pincx + {-# INLINE tbmv #-} + + trsv uplo trans diag n pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + dtrsv puplo ptrans pdiag pn pa plda px pincx + {-# INLINE trsv #-} + + tbsv uplo trans diag n k pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + dtbsv puplo ptrans pdiag pn pk pa plda px pincx + {-# INLINE tbsv #-} + + hemv uplo n alpha pa lda px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + dsymv puplo pn palpha pa plda px pincx pbeta py pincy + {-# INLINE hemv #-} + + hbmv uplo n k alpha pa lda px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + dsbmv puplo pn pk palpha pa plda px pincx pbeta py pincy + {-# INLINE hbmv #-} + + gerc m n alpha px incx py incy pa lda = + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + withEnum lda $ \plda -> + dger pm pn palpha px pincx py pincy pa plda + {-# INLINE gerc #-} + + geru = gerc + {-# INLINE geru #-} + + her uplo n alpha px incx pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum lda $ \plda -> + dsyr puplo pn palpha px pincx pa plda + {-# INLINE her #-} + + her2 uplo n alpha px incx py incy pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + withEnum lda $ \plda -> + dsyr2 puplo pn palpha px pincx py pincy pa plda + {-# INLINE her2 #-} + + hpmv uplo n alpha pap px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + dspmv puplo pn palpha pap px pincx pbeta py pincy + {-# INLINE hpmv #-} + + hpr uplo n alpha px incx pap = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + dspr puplo pn palpha px pincx pap + {-# INLINE hpr #-} + + hpr2 uplo n alpha px incx py incy pap = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + dspr2 puplo pn palpha px pincx py pincy pap + {-# INLINE hpr2 #-} + + +instance BLAS2 (Complex Double) where + gemv transa m n alpha pa lda px incx beta py incy = + withTrans transa $ \ptransa -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + zgemv ptransa pm pn palpha pa plda px pincx pbeta py pincy + {-# INLINE gemv #-} + + gbmv transa m n kl ku alpha pa lda px incx beta py incy = + withTrans transa $ \ptransa -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum kl $ \pkl -> + withEnum ku $ \pku -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + zgbmv ptransa pm pn pkl pku palpha pa plda px pincx pbeta py pincy + {-# INLINE gbmv #-} + + trmv uplo trans diag n pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + ztrmv puplo ptrans pdiag pn pa plda px pincx + {-# INLINE trmv #-} + + tpmv uplo trans diag n pap px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum incx $ \pincx -> + ztpmv puplo ptrans pdiag pn pap px pincx + {-# INLINE tpmv #-} + + tpsv uplo trans diag n pap px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum incx $ \pincx -> + ztpsv puplo ptrans pdiag pn pap px pincx + {-# INLINE tpsv #-} + + tbmv uplo trans diag n k pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + ztbmv puplo ptrans pdiag pn pk pa plda px pincx + {-# INLINE tbmv #-} + + trsv uplo trans diag n pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + ztrsv puplo ptrans pdiag pn pa plda px pincx + {-# INLINE trsv #-} + + tbsv uplo trans diag n k pa lda px incx = + withUplo uplo $ \puplo -> + withTrans trans $ \ptrans -> + withDiag diag $ \pdiag -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + ztbsv puplo ptrans pdiag pn pk pa plda px pincx + {-# INLINE tbsv #-} + + hemv uplo n alpha pa lda px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + zhemv puplo pn palpha pa plda px pincx pbeta py pincy + {-# INLINE hemv #-} + + hbmv uplo n k alpha pa lda px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + zhbmv puplo pn pk palpha pa plda px pincx pbeta py pincy + {-# INLINE hbmv #-} + + gerc m n alpha px incx py incy pa lda = + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + withEnum lda $ \plda -> + zgerc pm pn palpha px pincx py pincy pa plda + {-# INLINE gerc #-} + + geru m n alpha px incx py incy pa lda = + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + withEnum lda $ \plda -> + zgeru pm pn palpha px pincx py pincy pa plda + {-# INLINE geru #-} + + her uplo n alpha px incx pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum lda $ \plda -> + zher puplo pn palpha px pincx pa plda + {-# INLINE her #-} + + her2 uplo n alpha px incx py incy pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + withEnum lda $ \plda -> + zher2 puplo pn palpha px pincx py pincy pa plda + {-# INLINE her2 #-} + + hpmv uplo n alpha pap px incx beta py incy = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + with beta $ \pbeta -> + withEnum incy $ \pincy -> + zhpmv puplo pn palpha pap px pincx pbeta py pincy + {-# INLINE hpmv #-} + + hpr uplo n alpha px incx pap = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + zhpr puplo pn palpha px pincx pap + {-# INLINE hpr #-} + + hpr2 uplo n alpha px incx py incy pap = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum incx $ \pincx -> + withEnum incy $ \pincy -> + zhpr2 puplo pn palpha px pincx py pincy pap + {-# INLINE hpr2 #-} diff --git a/lib/Foreign/BLAS/Level3.hs b/lib/Foreign/BLAS/Level3.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Level3.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Level3 +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Matrix-Matrix operations. +-- + +module Foreign.BLAS.Level3 ( + BLAS3(..), + ) where + +import Data.Complex +import Foreign( Ptr, Storable, with ) + +import Foreign.BLAS.Types +import Foreign.BLAS.Level2 +import Foreign.BLAS.Double +import Foreign.BLAS.Zomplex + +-- | Types with matrix-matrix operations. +class (BLAS2 a) => BLAS3 a where + gemm :: Trans -> Trans -> Int -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + symm :: Side -> Uplo -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + hemm :: Side -> Uplo -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + trmm :: Side -> Uplo -> Trans -> Diag -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> IO () + trsm :: Side -> Uplo -> Trans -> Diag -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> IO () + syrk :: Uplo -> Trans -> Int -> Int -> a -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + syr2k :: Uplo -> Trans -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + herk :: Uplo -> Trans -> Int -> Int -> a -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + her2k :: Uplo -> Trans -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO () + + +withEnum :: (Enum a, Storable a) => Int -> (Ptr a -> IO b) -> IO b +withEnum = with . toEnum +{-# INLINE withEnum #-} + + +instance BLAS3 Double where + gemm transa transb m n k alpha pa lda pb ldb beta pc ldc = + withTrans transa $ \ptransa -> + withTrans transb $ \ptransb -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + dgemm ptransa ptransb pm pn pk palpha pa plda pb pldb pbeta pc pldc + {-# INLINE gemm #-} + + symm side uplo m n alpha pa lda pb ldb beta pc ldc = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + dsymm pside puplo pm pn palpha pa plda pb pldb pbeta pc pldc + {-# INLINE symm #-} + + hemm = symm + {-# INLINE hemm #-} + + trmm side uplo transa diag m n alpha pa lda pb ldb = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withDiag diag $ \pdiag -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + dtrmm pside puplo ptransa pdiag pm pn palpha pa plda pb pldb + {-# INLINE trmm #-} + + trsm side uplo transa diag m n alpha pa lda pb ldb = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withDiag diag $ \pdiag -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + dtrsm pside puplo ptransa pdiag pm pn palpha pa plda pb pldb + {-# INLINE trsm #-} + + syrk uplo transa n k alpha pa lda beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + dsyrk puplo ptransa pn pk palpha pa plda pbeta pc pldc + {-# INLINE syrk #-} + + syr2k uplo transa n k alpha pa lda pb ldb beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + dsyr2k puplo ptransa pn pk palpha pa plda pb pldb pbeta pc pldc + {-# INLINE syr2k #-} + + herk = syrk + {-# INLINE herk #-} + + her2k = syr2k + {-# INLINE her2k #-} + + +instance BLAS3 (Complex Double) where + gemm transa transb m n k alpha pa lda pb ldb beta pc ldc = + withTrans transa $ \ptransa -> + withTrans transb $ \ptransb -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zgemm ptransa ptransb pm pn pk palpha pa plda pb pldb pbeta pc pldc + {-# INLINE gemm #-} + + symm side uplo m n alpha pa lda pb ldb beta pc ldc = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zsymm pside puplo pm pn palpha pa plda pb pldb pbeta pc pldc + {-# INLINE symm #-} + + hemm side uplo m n alpha pa lda pb ldb beta pc ldc = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zhemm pside puplo pm pn palpha pa plda pb pldb pbeta pc pldc + {-# INLINE hemm #-} + + trmm side uplo transa diag m n alpha pa lda pb ldb = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withDiag diag $ \pdiag -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + ztrmm pside puplo ptransa pdiag pm pn palpha pa plda pb pldb + {-# INLINE trmm #-} + + trsm side uplo transa diag m n alpha pa lda pb ldb = + withSide side $ \pside -> + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withDiag diag $ \pdiag -> + withEnum m $ \pm -> + withEnum n $ \pn -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + ztrsm pside puplo ptransa pdiag pm pn palpha pa plda pb pldb + {-# INLINE trsm #-} + + syrk uplo transa n k alpha pa lda beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zsyrk puplo ptransa pn pk palpha pa plda pbeta pc pldc + {-# INLINE syrk #-} + + syr2k uplo transa n k alpha pa lda pb ldb beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zsyr2k puplo ptransa pn pk palpha pa plda pb pldb pbeta pc pldc + {-# INLINE syr2k #-} + + herk uplo transa n k alpha pa lda beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zherk puplo ptransa pn pk palpha pa plda pbeta pc pldc + {-# INLINE herk #-} + + her2k uplo transa n k alpha pa lda pb ldb beta pc ldc = + withUplo uplo $ \puplo -> + withTrans transa $ \ptransa -> + withEnum n $ \pn -> + withEnum k $ \pk -> + with alpha $ \palpha -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + with beta $ \pbeta -> + withEnum ldc $ \pldc -> + zher2k puplo ptransa pn pk palpha pa plda pb pldb pbeta pc pldc + {-# INLINE her2k #-} diff --git a/lib/Foreign/BLAS/Types.hs b/lib/Foreign/BLAS/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Types.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Types +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.BLAS.Types ( + BLASTrans(..), + Trans(..), + withTrans, + + BLASUplo(..), + Uplo(..), + withUplo, + + BLASDiag(..), + Diag(..), + withDiag, + + BLASSide(..), + Side(..), + withSide, + + LAInt(..), + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +newtype BLASTrans = BLASTrans CString +data Trans = NoTrans | Trans | ConjTrans deriving (Eq, Show) + +withTrans :: Trans -> (BLASTrans -> IO a) -> IO a +withTrans trans f = flip withCString (f . BLASTrans) $ case trans of + NoTrans -> "N" + Trans -> "T" + ConjTrans -> "C" + +newtype BLASUplo = BLASUplo CString +data Uplo = Upper | Lower deriving (Eq, Show) + +withUplo :: Uplo -> (BLASUplo -> IO a) -> IO a +withUplo uplo f = flip withCString (f . BLASUplo) $ case uplo of + Upper -> "U" + Lower -> "L" + +newtype BLASSide = BLASSide CString +data Side = LeftSide | RightSide deriving (Eq, Show) + +withSide :: Side -> (BLASSide -> IO a) -> IO a +withSide side f = flip withCString (f . BLASSide) $ case side of + LeftSide -> "L" + RightSide -> "R" + +newtype BLASDiag = BLASDiag CString +data Diag = NonUnit | Unit deriving (Eq, Show) + +withDiag :: Diag -> (BLASDiag -> IO a) -> IO a +withDiag diag f = flip withCString (f . BLASDiag) $ case diag of + NonUnit -> "N" + Unit -> "U" + +newtype LAInt = LAInt CInt deriving (Eq, Show, Enum, Num, Ord, Storable) diff --git a/lib/Foreign/BLAS/Zomplex.hsc b/lib/Foreign/BLAS/Zomplex.hsc new file mode 100644 --- /dev/null +++ b/lib/Foreign/BLAS/Zomplex.hsc @@ -0,0 +1,146 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.BLAS.Zomplex +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.BLAS.Zomplex + where + +import Data.Complex( Complex ) +import Foreign +import Foreign.BLAS.Types +import Foreign.C.Types + +#include "config.h" +#include "f77_func-hsc.h" +#define la_int int + +---------------------------- Level 1 Routines ------------------------------- + +foreign import ccall unsafe #f77_func zdotu + zdotu :: Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zdotc + zdotc :: Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + + +foreign import ccall unsafe #f77_func dznrm2 + znrm2 :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO Double + +foreign import ccall unsafe #f77_func dzasum + zasum :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO Double + +foreign import ccall unsafe #f77_func izamax + izamax_hidden :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO CInt +izamax :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO LAInt +izamax a b c = do + res <- izamax_hidden a b c + return $! LAInt res + + +foreign import ccall unsafe #f77_func zscal + zscal :: Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zswap + zswap :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zcopy + zcopy :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zaxpy + zaxpy :: Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zrotg + zrotg :: Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe #f77_func zdrot + zdrot :: Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr Double -> Ptr Double -> IO () + + +---------------------------- Level 2 Routines ------------------------------- + +foreign import ccall unsafe #f77_func zgemv + zgemv :: BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zgbmv + zgbmv :: BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztrmv + ztrmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztpmv + ztpmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztpsv + ztpsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztbmv + ztbmv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztrsv + ztrsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztbsv + ztbsv :: BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zhemv + zhemv :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zhbmv + zhbmv :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zgeru + zgeru :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zgerc + zgerc :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zher + zher :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zher2 + zher2 :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zhpmv + zhpmv :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zhpr + zhpr :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe #f77_func zhpr2 + zhpr2 :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> IO () + + +---------------------------- Level 3 Routines ------------------------------- + +foreign import ccall unsafe #f77_func zgemm + zgemm :: BLASTrans -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zsymm + zsymm :: BLASSide -> BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zhemm + zhemm :: BLASSide -> BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztrmm + ztrmm :: BLASSide -> BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func ztrsm + ztrsm :: BLASSide -> BLASUplo -> BLASTrans -> BLASDiag -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zsyrk + zsyrk :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zsyr2k + zsyr2k :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zherk + zherk :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zher2k + zher2k :: BLASUplo -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt -> IO () diff --git a/lib/Foreign/LAPACK.hs b/lib/Foreign/LAPACK.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/LAPACK.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.LAPACK +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Types with a Linear Algebra PACKage. +-- +module Foreign.LAPACK ( + -- * LAPACK typeclass + LAPACK(..), + -- * Enums + module Foreign.LAPACK.Types, + ) where + +import Control.Monad( forM_, when ) +import Control.Exception( assert ) +import Data.Complex( Complex ) +import Foreign +import Foreign.BLAS +import Foreign.LAPACK.Types +import Foreign.LAPACK.Double +import Foreign.LAPACK.Zomplex + + +-- | Types with LAPACK operations. +class (BLAS3 e) => LAPACK e where + geqrf :: Int -> Int -> Ptr e -> Int -> Ptr e -> IO () + gelqf :: Int -> Int -> Ptr e -> Int -> Ptr e -> IO () + + heevr :: EigJob -> EigRange -> Uplo -> Int -> Ptr e -> Int -> Double + -> Ptr Double -> Ptr e -> Int -> Ptr Int -> IO Int + + larfg :: Int -> Ptr e -> Ptr e -> Int -> IO e + potrf :: Uplo -> Int -> Ptr e -> Int -> IO Int + potrs :: Uplo -> Int -> Int -> Ptr e -> Int -> Ptr e -> Int -> IO () + pptrf :: Uplo -> Int -> Ptr e -> IO Int + pptrs :: Uplo -> Int -> Int -> Ptr e -> Ptr e -> Int -> IO () + + unmqr :: Side -> Trans -> Int -> Int -> Int -> Ptr e -> Int -> Ptr e -> Ptr e -> Int -> IO () + unmlq :: Side -> Trans -> Int -> Int -> Int -> Ptr e -> Int -> Ptr e -> Ptr e -> Int -> IO () + + +callWithWork :: (Storable e) => (Ptr e -> Ptr LAInt -> Ptr LAInt -> IO ()) -> IO LAInt +callWithWork call = + alloca $ \pquery -> + with (-1) $ \pnone -> + alloca $ \pinfo -> do + call pquery pnone pinfo + lwork <- (ceiling . max 1) `fmap` (peek (castPtr pquery) :: IO Double) + allocaArray lwork $ \pwork -> + withEnum lwork $ \plwork -> do + call pwork plwork pinfo + peek pinfo + +callWithWorkIWork :: (Storable e) + => (Ptr e -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> IO ()) + -> IO LAInt +callWithWorkIWork call = + alloca $ \pquery -> + alloca $ \piquery -> + with (-1) $ \pnone -> + alloca $ \pinfo -> do + call pquery pnone piquery pnone pinfo + lwork <- (ceiling . max 1) `fmap` (peek (castPtr pquery) :: IO Double) + liwork <- max 1 `fmap` peek piquery + allocaArray lwork $ \pwork -> + withEnum lwork $ \plwork -> + allocaArray (fromEnum liwork) $ \piwork -> + with liwork $ \pliwork -> do + call pwork plwork piwork pliwork pinfo + peek pinfo + +callWithWorkRWorkIWork :: (Storable e) + => (Ptr e -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> IO ()) + -> IO LAInt +callWithWorkRWorkIWork call = + alloca $ \pquery -> + alloca $ \prquery -> + alloca $ \piquery -> + with (-1) $ \pnone -> + alloca $ \pinfo -> do + call pquery pnone prquery pnone piquery pnone pinfo + lwork <- (ceiling . max 1) `fmap` (peek (castPtr pquery) :: IO Double) + lrwork <- (ceiling . max 1) `fmap` peek prquery + liwork <- max 1 `fmap` peek piquery + allocaArray lwork $ \pwork -> + withEnum lwork $ \plwork -> + allocaArray lrwork $ \prwork -> + withEnum lrwork $ \plrwork -> + allocaArray (fromEnum liwork) $ \piwork -> + with liwork $ \pliwork -> do + call pwork plwork prwork plrwork piwork pliwork pinfo + peek pinfo + + +checkInfo :: (Num info,Eq info ) => info -> IO () +checkInfo info = assert (info == 0) $ return () + +withEnum :: (Enum a, Storable a) => Int -> (Ptr a -> IO b) -> IO b +withEnum = with . toEnum +{-# INLINE withEnum #-} + + +instance LAPACK Double where + geqrf m n pa lda ptau = + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + checkInfo =<< callWithWork (dgeqrf pm pn pa plda ptau) + + gelqf m n pa lda ptau = + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + checkInfo =<< callWithWork (dgelqf pm pn pa plda ptau) + + heevr jobz range uplo n pa lda abstol pw pz ldz psuppz = + withEigJob jobz $ \pjobz -> + withEigRange range $ \prange pvl pvu pil piu -> + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + with abstol $ \pabstol -> + alloca $ \pm -> + withEnum ldz $ \pldz -> + allocaArray nsuppz $ \psuppz' -> do + checkInfo =<< + (callWithWorkIWork $ + dsyevr pjobz prange puplo pn pa plda pvl pvu pil piu + pabstol pm pw pz pldz psuppz') + m <- fromEnum `fmap` peek pm + when (psuppz /= nullPtr) $ + forM_ [ 0..2*m - 1 ] $ \i -> do + s <- peekElemOff psuppz' i + pokeElemOff psuppz i (fromEnum s) + return m + where + nsuppz = if psuppz == nullPtr then 0 else 2 * max 1 n + + unmqr side trans m n k pa lda ptau pc ldc = + withSide side $ \pside -> + withTrans trans $ \ptrans -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum ldc $ \pldc -> + checkInfo =<< callWithWork (dormqr pside ptrans pm pn pk pa plda ptau pc pldc) + + unmlq side trans m n k pa lda ptau pc ldc = + withSide side $ \pside -> + withTrans trans $ \ptrans -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum ldc $ \pldc -> + checkInfo =<< callWithWork (dormlq pside ptrans pm pn pk pa plda ptau pc pldc) + + larfg n palpha px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + alloca $ \ptau -> do + dlarfg pn palpha px pincx ptau + peek ptau + + potrf uplo n pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + alloca $ \pinfo -> do + dpotrf puplo pn pa plda pinfo + info <- fromEnum `fmap` peek pinfo + assert (info >= 0) $ return info + + potrs uplo n nrhs pa lda pb ldb = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum nrhs $ \pnrhs -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + alloca $ \pinfo -> do + dpotrs puplo pn pnrhs pa plda pb pldb pinfo + checkInfo =<< peek pinfo + + pptrf uplo n pa = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + alloca $ \pinfo -> do + dpptrf puplo pn pa pinfo + info <- fromEnum `fmap` peek pinfo + assert (info >= 0) $ return info + + pptrs uplo n nrhs pa pb ldb = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum nrhs $ \pnrhs -> + withEnum ldb $ \pldb -> + alloca $ \pinfo -> do + dpptrs puplo pn pnrhs pa pb pldb pinfo + checkInfo =<< peek pinfo + + +instance LAPACK (Complex Double) where + geqrf m n pa lda ptau = + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + checkInfo =<< callWithWork (zgeqrf pm pn pa plda ptau) + + gelqf m n pa lda ptau = + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + checkInfo =<< callWithWork (zgelqf pm pn pa plda ptau) + + heevr jobz range uplo n pa lda abstol pw pz ldz psuppz = + withEigJob jobz $ \pjobz -> + withEigRange range $ \prange pvl pvu pil piu -> + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + with abstol $ \pabstol -> + alloca $ \pm -> + withEnum ldz $ \pldz -> + allocaArray nsuppz $ \psuppz' -> do + checkInfo =<< + (callWithWorkRWorkIWork $ + zheevr pjobz prange puplo pn pa plda pvl pvu pil piu + pabstol pm pw pz pldz psuppz') + m <- fromEnum `fmap` peek pm + when (psuppz /= nullPtr) $ + forM_ [ 0..2*m - 1 ] $ \i -> do + s <- peekElemOff psuppz' i + pokeElemOff psuppz i (fromEnum s) + return m + where + nsuppz = if psuppz == nullPtr then 0 else 2 * max 1 n + + unmqr side trans m n k pa lda ptau pc ldc = + withSide side $ \pside -> + withTrans trans $ \ptrans -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum ldc $ \pldc -> + checkInfo =<< callWithWork (zunmqr pside ptrans pm pn pk pa plda ptau pc pldc) + + unmlq side trans m n k pa lda ptau pc ldc = + withSide side $ \pside -> + withTrans trans $ \ptrans -> + withEnum m $ \pm -> + withEnum n $ \pn -> + withEnum k $ \pk -> + withEnum lda $ \plda -> + withEnum ldc $ \pldc -> + checkInfo =<< callWithWork (zunmlq pside ptrans pm pn pk pa plda ptau pc pldc) + + larfg n palpha px incx = + withEnum n $ \pn -> + withEnum incx $ \pincx -> + alloca $ \ptau -> do + zlarfg pn palpha px pincx ptau + peek ptau + + potrf uplo n pa lda = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum lda $ \plda -> + alloca $ \pinfo -> do + zpotrf puplo pn pa plda pinfo + info <- fromEnum `fmap` peek pinfo + assert (info >= 0) $ return info + + potrs uplo n nrhs pa lda pb ldb = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum nrhs $ \pnrhs -> + withEnum lda $ \plda -> + withEnum ldb $ \pldb -> + alloca $ \pinfo -> do + zpotrs puplo pn pnrhs pa plda pb pldb pinfo + checkInfo =<< peek pinfo + + pptrf uplo n pa = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + alloca $ \pinfo -> do + zpptrf puplo pn pa pinfo + info <- fromEnum `fmap` peek pinfo + assert (info >= 0) $ return info + + pptrs uplo n nrhs pa pb ldb = + withUplo uplo $ \puplo -> + withEnum n $ \pn -> + withEnum nrhs $ \pnrhs -> + withEnum ldb $ \pldb -> + alloca $ \pinfo -> do + zpptrs puplo pn pnrhs pa pb pldb pinfo + checkInfo =<< peek pinfo diff --git a/lib/Foreign/LAPACK/Double.hsc b/lib/Foreign/LAPACK/Double.hsc new file mode 100644 --- /dev/null +++ b/lib/Foreign/LAPACK/Double.hsc @@ -0,0 +1,64 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.LAPACK.Double +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.LAPACK.Double + where + +import Foreign( Ptr ) +import Foreign.BLAS.Types +import Foreign.LAPACK.Types + +#include "f77_func-hsc.h" + + +foreign import ccall unsafe #f77_func dgeqrf + dgeqrf :: Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dgelqf + dgelqf :: Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dlarfg + dlarfg :: Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr Double + -> IO () + +foreign import ccall unsafe #f77_func dormqr + dormqr :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dormlq + dormlq :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dpotrf + dpotrf :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr LAInt + -> IO () + +foreign import ccall unsafe #f77_func dpotrs + dpotrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dpptrf + dpptrf :: BLASUplo -> Ptr LAInt -> Ptr Double -> Ptr LAInt + -> IO () + +foreign import ccall unsafe #f77_func dpptrs + dpptrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr Double + -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func dsyevr + dsyevr :: LAEigJob -> LAEigRange -> BLASUplo -> Ptr LAInt -> Ptr Double + -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr LAInt + -> Ptr Double -> Ptr LAInt -> Ptr Double -> Ptr Double -> Ptr LAInt + -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt + -> Ptr LAInt -> IO () diff --git a/lib/Foreign/LAPACK/Types.hs b/lib/Foreign/LAPACK/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/LAPACK/Types.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.LAPACK.Types +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.LAPACK.Types ( + LAEigJob(..), + EigJob(..), + withEigJob, + + LAEigRange(..), + EigRange(..), + withEigRange, + + ) where + +import Foreign +import Foreign.C.String + +import Foreign.BLAS.Types( LAInt ) + +newtype LAEigJob = LAEigJob CString + +-- | A type of eigenvalue computation. +data EigJob = NoEigVectors -- ^ no eigenvectors (eigenvalues only) + | EigVectors -- ^ eigenvalues and eigenvectors + deriving (Eq, Show) + +withEigJob :: EigJob -> (LAEigJob -> IO a) -> IO a +withEigJob evjob f = flip withCString (f . LAEigJob) $ case evjob of + NoEigVectors -> "N" + EigVectors -> "V" + +newtype LAEigRange = LAEigRange CString + +-- | A range of eigenvalues to compute. +data EigRange = AllEigs -- ^ All eigenvalues are computed + | EigValueRange !Double !Double -- ^ Eigenvalues in the half-open + -- interval @(vl,vu]@ are + -- computed + | EigIndexRange !Int !Int -- ^ Eigenvalues with indices in + -- the closed interval + -- @[il,iu]@ are computed. + -- Index @0@ corresponds to + -- the smallest eigenvalue. + deriving (Eq, Show) + +withEigRange :: EigRange + -> (LAEigRange -> Ptr Double -> Ptr Double -> Ptr LAInt -> Ptr LAInt -> IO a) + -> IO a +withEigRange eigrange f = case eigrange of + AllEigs -> + withCString "A" $ \pA -> + alloca $ \pvl -> + alloca $ \pvu -> + alloca $ \pil -> + alloca $ \piu -> + f (LAEigRange pA) pvl pvu pil piu + EigValueRange vl vu -> + withCString "V" $ \pV -> + with vl $ \pvl -> + with vu $ \pvu -> + alloca $ \pil -> + alloca $ \piu -> + f (LAEigRange pV) pvl pvu pil piu + EigIndexRange il iu -> + withCString "I" $ \pI -> + alloca $ \pvl -> + alloca $ \pvu -> + with (toEnum $ il + 1) $ \pil -> + with (toEnum $ iu + 1) $ \piu -> + f (LAEigRange pI) pvl pvu pil piu diff --git a/lib/Foreign/LAPACK/Zomplex.hsc b/lib/Foreign/LAPACK/Zomplex.hsc new file mode 100644 --- /dev/null +++ b/lib/Foreign/LAPACK/Zomplex.hsc @@ -0,0 +1,74 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.LAPACK.Zomplex +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.LAPACK.Zomplex + where + +import Data.Complex( Complex ) +import Foreign( Ptr ) +import Foreign.BLAS.Types +import Foreign.LAPACK.Types + +#include "f77_func-hsc.h" + + +foreign import ccall unsafe #f77_func zgeqrf + zgeqrf :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zgelqf + zgelqf :: Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zheevr + zheevr :: LAEigJob -> LAEigRange -> BLASUplo -> Ptr LAInt + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr Double -> Ptr Double + -> Ptr LAInt -> Ptr LAInt -> Ptr Double -> Ptr LAInt -> Ptr Double + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr Double -> Ptr LAInt + -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zlarfg + zlarfg :: Ptr LAInt -> Ptr (Complex Double) -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe #f77_func zpotrf + zpotrf :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt + -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zpotrs + zpotrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt + -> IO () + +foreign import ccall unsafe #f77_func zpptrf + zpptrf :: BLASUplo -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr LAInt -> IO () + +foreign import ccall unsafe #f77_func zpptrs + zpptrs :: BLASUplo -> Ptr LAInt -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt + -> IO () + +foreign import ccall unsafe #f77_func zunmqr + zunmqr :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt + -> Ptr LAInt -> Ptr (Complex Double) -> Ptr LAInt + -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr LAInt + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr LAInt + -> IO () + +foreign import ccall unsafe #f77_func zunmlq + zunmlq :: BLASSide -> BLASTrans -> Ptr LAInt -> Ptr LAInt -> Ptr LAInt + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr (Complex Double) -> Ptr LAInt -> Ptr (Complex Double) + -> Ptr LAInt -> Ptr LAInt -> IO () + diff --git a/lib/Foreign/VMath.hs b/lib/Foreign/VMath.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Vector math operations. +-- + +module Foreign.VMath ( + -- * Vector Math typeclasses + module Foreign.VMath.VNum, + module Foreign.VMath.VFractional, + module Foreign.VMath.VFloating + ) where + +import Foreign.VMath.VNum +import Foreign.VMath.VFractional +import Foreign.VMath.VFloating diff --git a/lib/Foreign/VMath/Double.hs b/lib/Foreign/VMath/Double.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath/Double.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# CFILES cbits/vmath-double.c #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath.Double +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.VMath.Double + where + +import Foreign.Ptr( Ptr ) + +---------------------------- Vector Routines -------------------------------- + +foreign import ccall unsafe "vdShift" + vdShift :: Int -> Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdAdd" + vdAdd :: Int -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdSub" + vdSub :: Int -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdAxpby" + vdAxpby :: Int -> Double -> Ptr Double -> Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdScale" + vdScale :: Int -> Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdMul" + vdMul :: Int -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdNeg" + vdNeg :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdAbs" + vdAbs :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdSgn" + vdSgn :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdInv" + vdInv :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdDiv" + vdDiv :: Int -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdExp" + vdExp :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdSqrt" + vdSqrt :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdLog" + vdLog :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdPow" + vdPow :: Int -> Ptr Double -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdSin" + vdSin :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdCos" + vdCos :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdTan" + vdTan :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdASin" + vdASin :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdACos" + vdACos :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdATan" + vdATan :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdSinh" + vdSinh :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdCosh" + vdCosh :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdTanh" + vdTanh :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdASinh" + vdASinh :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdACosh" + vdACosh :: Int -> Ptr Double -> Ptr Double -> IO () + +foreign import ccall unsafe "vdATanh" + vdATanh :: Int -> Ptr Double -> Ptr Double -> IO () + + diff --git a/lib/Foreign/VMath/VFloating.hs b/lib/Foreign/VMath/VFloating.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath/VFloating.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath.VFloating +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Vector Floating operations. +-- + +module Foreign.VMath.VFloating ( + VFloating(..) + ) where + +import Foreign( Ptr, Storable, peek, poke, advancePtr ) +import Data.Complex( Complex(..) ) + +import Foreign.VMath.VFractional +import Foreign.VMath.Double +import Foreign.VMath.Zomplex + +-- | Types with vectorized 'Floating' operations. +class (VFractional a, Floating a) => VFloating a where + vExp :: Int -> Ptr a -> Ptr a -> IO () + vSqrt :: Int -> Ptr a -> Ptr a -> IO () + vLog :: Int -> Ptr a -> Ptr a -> IO () + vPow :: Int -> Ptr a -> Ptr a -> Ptr a -> IO () + vSin :: Int -> Ptr a -> Ptr a -> IO () + vCos :: Int -> Ptr a -> Ptr a -> IO () + vTan :: Int -> Ptr a -> Ptr a -> IO () + vASin :: Int -> Ptr a -> Ptr a -> IO () + vACos :: Int -> Ptr a -> Ptr a -> IO () + vATan :: Int -> Ptr a -> Ptr a -> IO () + vSinh :: Int -> Ptr a -> Ptr a -> IO () + vCosh :: Int -> Ptr a -> Ptr a -> IO () + vTanh :: Int -> Ptr a -> Ptr a -> IO () + vASinh :: Int -> Ptr a -> Ptr a -> IO () + vACosh :: Int -> Ptr a -> Ptr a -> IO () + vATanh :: Int -> Ptr a -> Ptr a -> IO () + + vExp = vop exp + vSqrt = vop sqrt + vLog = vop log + vPow = vop2 (**) + vSin = vop sin + vCos = vop cos + vTan = vop tan + vASin = vop asin + vACos = vop acos + vATan = vop atan + vSinh = vop sinh + vCosh = vop cosh + vTanh = vop tanh + vASinh = vop asinh + vACosh = vop acosh + vATanh = vop atanh + + +vop :: (Storable a, Storable b) + => (a -> b) -> Int -> Ptr a -> Ptr b -> IO () +vop f n src dst | n <= 0 = return () + | otherwise = do + a <- peek src + poke dst $ f a + vop f (n-1) (src `advancePtr` 1) (dst `advancePtr` 1) +{-# INLINE vop #-} + +vop2 :: (Storable a1, Storable a2, Storable b) + => (a1 -> a2 -> b) -> Int -> Ptr a1 -> Ptr a2 -> Ptr b -> IO () +vop2 f n src1 src2 dst | n <= 0 = return () + | otherwise = do + a1 <- peek src1 + a2 <- peek src2 + poke dst $ f a1 a2 + vop2 f (n-1) (src1 `advancePtr` 1) (src2 `advancePtr` 1) + (dst `advancePtr` 1) +{-# INLINE vop2 #-} + +instance VFloating Double where + vExp = vdExp + {-# INLINE vExp #-} + vSqrt = vdSqrt + {-# INLINE vSqrt #-} + vLog = vdLog + {-# INLINE vLog #-} + vPow = vdPow + {-# INLINE vPow #-} + vSin = vdSin + {-# INLINE vSin #-} + vCos = vdCos + {-# INLINE vCos #-} + vTan = vdTan + {-# INLINE vTan #-} + vASin = vdASin + {-# INLINE vASin #-} + vACos = vdACos + {-# INLINE vACos #-} + vATan = vdATan + {-# INLINE vATan #-} + vSinh = vdSinh + {-# INLINE vSinh #-} + vCosh = vdCosh + {-# INLINE vCosh #-} + vTanh = vdTanh + {-# INLINE vTanh #-} + vASinh = vdASinh + {-# INLINE vASinh #-} + vACosh = vdACosh + {-# INLINE vACosh #-} + vATanh = vdATanh + {-# INLINE vATanh #-} + + +instance VFloating (Complex Double) where + vSqrt = vzSqrt + {-# INLINE vSqrt #-} + vLog = vzLog + {-# INLINE vLog #-} + + {- These functions have branch cuts in the wrong places + vExp = vzExp + {-# INLINE vExp #-} + vPow = vzPow + {-# INLINE vPow #-} + vSin = vzSin + {-# INLINE vSin #-} + vCos = vzCos + {-# INLINE vCos #-} + vTan = vzTan + {-# INLINE vTan #-} + vASin = vzASin + {-# INLINE vASin #-} + vACos = vzACos + {-# INLINE vACos #-} + vATan = vzATan + {-# INLINE vATan #-} + vSinh = vzSinh + {-# INLINE vSinh #-} + vCosh = vzCosh + {-# INLINE vCosh #-} + vTanh = vzTanh + {-# INLINE vTanh #-} + vASinh = vzASinh + {-# INLINE vASinh #-} + vACosh = vzACosh + {-# INLINE vACosh #-} + vATanh = vzATanh + {-# INLINE vATanh #-} + -} diff --git a/lib/Foreign/VMath/VFractional.hs b/lib/Foreign/VMath/VFractional.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath/VFractional.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath.VFractional +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Vector Fractional operations. +-- + +module Foreign.VMath.VFractional + where + +import Foreign( Ptr ) +import Data.Complex( Complex(..) ) + +import Foreign.VMath.VNum +import Foreign.VMath.Double +import Foreign.VMath.Zomplex + +-- | Types with vectorized 'Fractional' operations. +class (VNum a, Fractional a) => VFractional a where + vInv :: Int -> Ptr a -> Ptr a -> IO () + vDiv :: Int -> Ptr a -> Ptr a -> Ptr a -> IO () + +instance VFractional Double where + vInv = vdInv + {-# INLINE vInv #-} + vDiv = vdDiv + {-# INLINE vDiv #-} + +instance VFractional (Complex Double) where + vInv = vzInv + {-# INLINE vInv #-} + vDiv = vzDiv + {-# INLINE vDiv #-} diff --git a/lib/Foreign/VMath/VNum.hs b/lib/Foreign/VMath/VNum.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath/VNum.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath.VNum +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Vector Num operations. +-- + +module Foreign.VMath.VNum + where + +import Foreign( Storable, Ptr, with, ) +import Foreign.Storable.Complex() +import Data.Complex( Complex(..) ) + +import Foreign.BLAS.Double( dcopy ) +import Foreign.VMath.Double +import Foreign.VMath.Zomplex + +-- | Types with vectorized 'Num' operations. +class (Storable a, Num a) => VNum a where + vShift :: Int -> a -> Ptr a -> Ptr a -> IO () + vAdd :: Int -> Ptr a -> Ptr a -> Ptr a -> IO () + vSub :: Int -> Ptr a -> Ptr a -> Ptr a -> IO () + vAxpby :: Int -> a -> Ptr a -> a -> Ptr a -> Ptr a -> IO () + + vScale :: Int -> a -> Ptr a -> Ptr a -> IO () + vMul :: Int -> Ptr a -> Ptr a -> Ptr a -> IO () + + vConj :: Int -> Ptr a -> Ptr a -> IO () + vNeg :: Int -> Ptr a -> Ptr a -> IO () + vAbs :: Int -> Ptr a -> Ptr a -> IO () + vSgn :: Int -> Ptr a -> Ptr a -> IO () + + +instance VNum Double where + vShift = vdShift + {-# INLINE vShift #-} + vAdd = vdAdd + {-# INLINE vAdd #-} + vSub = vdSub + {-# INLINE vSub #-} + vAxpby = vdAxpby + {-# INLINE vAxpby #-} + vScale = vdScale + {-# INLINE vScale #-} + vMul = vdMul + {-# INLINE vMul #-} + vConj n src dst = + with (toEnum n) $ \pn -> + with 1 $ \pone -> + dcopy pn src pone dst pone + {-# INLINE vConj #-} + vNeg = vdNeg + {-# INLINE vNeg #-} + vAbs = vdAbs + {-# INLINE vAbs #-} + vSgn = vdSgn + {-# INLINE vSgn #-} + +instance VNum (Complex Double) where + vShift n alpha pX pZ = with alpha $ \pAlpha -> + vzShift n pAlpha pX pZ + {-# INLINE vShift #-} + vAdd = vzAdd + {-# INLINE vAdd #-} + vSub = vzSub + {-# INLINE vSub #-} + vAxpby n alpha pX beta pY pZ = + with alpha $ \pAlpha -> + with beta $ \pBeta -> + vzAxpby n pAlpha pX pBeta pY pZ + {-# INLINE vAxpby #-} + vScale n alpha pX pZ = with alpha $ \pAlpha -> + vzScale n pAlpha pX pZ + {-# INLINE vScale #-} + vMul = vzMul + {-# INLINE vMul #-} + vConj = vzConj + {-# INLINE vConj #-} + vNeg = vzNeg + {-# INLINE vNeg #-} + vAbs = vzAbs + {-# INLINE vAbs #-} + vSgn = vzSgn + {-# INLINE vSgn #-} diff --git a/lib/Foreign/VMath/Zomplex.hs b/lib/Foreign/VMath/Zomplex.hs new file mode 100644 --- /dev/null +++ b/lib/Foreign/VMath/Zomplex.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# CFILES cbits/vmath-zomplex.c #-} +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.VMath.Zomplex +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Foreign.VMath.Zomplex + where + +import Data.Complex ( Complex ) +import Foreign.Ptr ( Ptr ) + +foreign import ccall unsafe "vzConj" + vzConj :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzShift" + vzShift :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzAdd" + vzAdd :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzSub" + vzSub :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzAxpby" + vzAxpby :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzScale" + vzScale :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzMul" + vzMul :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzNeg" + vzNeg :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzAbs" + vzAbs :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzSgn" + vzSgn :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzInv" + vzInv :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzDiv" + vzDiv :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzExp" + vzExp :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzSqrt" + vzSqrt :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzLog" + vzLog :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzPow" + vzPow :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzSin" + vzSin :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzCos" + vzCos :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzTan" + vzTan :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzASin" + vzASin :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzACos" + vzACos :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzATan" + vzATan :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzSinh" + vzSinh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzCosh" + vzCosh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzTanh" + vzTanh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzASinh" + vzASinh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzACosh" + vzACosh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + +foreign import ccall unsafe "vzATanh" + vzATanh :: Int -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO () + diff --git a/lib/Numeric/LinearAlgebra.hs b/lib/Numeric/LinearAlgebra.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Linear algebra types and operations +-- + +module Numeric.LinearAlgebra ( + -- * Vector types + Vector, + RVector, + STVector, + IOVector, + + -- * Matrix types + Matrix, + RMatrix, + STMatrix, + IOMatrix, + + -- * Packed matrix types + Packed, + RPacked, + STPacked, + IOPacked, + + module Numeric.LinearAlgebra.Types, + ) where + +import Numeric.LinearAlgebra.Types +import Numeric.LinearAlgebra.Vector( Vector, RVector, STVector, IOVector ) +import Numeric.LinearAlgebra.Matrix( Matrix, RMatrix, STMatrix, IOMatrix ) +import Numeric.LinearAlgebra.Packed( Packed, RPacked, STPacked, IOPacked ) diff --git a/lib/Numeric/LinearAlgebra/Internal.hs b/lib/Numeric/LinearAlgebra/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Internal.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface, MagicHash #-} + +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Internal +-- Copyright : Copyright (c) 2008, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + + +module Numeric.LinearAlgebra.Internal ( + clearArray, + bzero, + inlinePerformIO, + checkedRow, + checkedCol, + checkedDiag, + checkedSubmatrix, + checkMatMatOp, + checkMatVecMult, + checkMatMatMult, + checkMatVecMultAdd, + checkMatMatMultAdd, + checkMatVecSolv, + checkMatMatSolv, + checkMatVecSolvTo, + checkMatMatSolvTo, + checkSquare, + checkFat, + checkTall, + checkBinaryOp, + checkTernaryOp, + diagStart, + diagLen, + ) where + + +import Foreign ( Ptr, Storable(..), castPtr, sizeOf ) +import Foreign.C.Types ( CSize(..) ) +import Text.Printf ( printf ) + + +#if defined(__GLASGOW_HASKELL__) +import GHC.IO ( unsafeDupablePerformIO ) +#else +import System.IO.Unsafe ( unsafePerformIO ) +#endif + + +clearArray :: Storable e => Ptr e -> Int -> IO () +clearArray = clearArray' undefined + where + clearArray' :: Storable e => e -> Ptr e -> Int -> IO () + clearArray' e ptr n = + let nbytes = fromIntegral (n * sizeOf e) + in do + bzero ptr nbytes +{-# INLINE clearArray #-} + + +bzero :: Ptr a -> Int -> IO () +bzero ptr n = + let ptr' = castPtr ptr + n' = fromIntegral n + in bzero_ ptr' n' + +foreign import ccall "strings.h bzero" + bzero_ :: Ptr () -> CSize -> IO () + + +inlinePerformIO :: IO a -> a +#if defined(__GLASGOW_HASKELL__) +inlinePerformIO a = unsafeDupablePerformIO a +#else +inlinePerformIO = unsafePerformIO +#endif +{-# INLINE inlinePerformIO #-} + +checkedRow :: (Int,Int) -> (Int -> v) -> Int -> v +checkedRow (m,n) row i + | i < 0 || i >= m = + error $ printf + "Error in row index. Tried to get row `%d' in a matrix with shape `(%d,%d)'" i m n + | otherwise = + row i + +checkedCol :: (Int,Int) -> (Int -> v) -> Int -> v +checkedCol (m,n) col j + | j < 0 || j >= n = + error $ printf + "Error in column index. Tried to get column `%d' in a matrix with shape `(%d,%d)'" j m n + | otherwise = + col j + +checkedDiag :: (Int,Int) -> (Int -> v) -> Int -> v +checkedDiag (m,n) diag i + | i < 0 && negate i >= m = + error $ printf + "Tried to get sub-diagonal `%d' of a matrix with shape `(%d,%d)'" (negate i) m n + | i > 0 && i >= n = + error $ printf + "Tried to get super-diagonal `%d' of a matrix with shape `(%d,%d)'" i m n + | otherwise = + diag i + +diagStart :: Int -> (Int,Int) +diagStart i + | i <= 0 = + (negate i, 0) + | otherwise = + (0, i) + +diagLen :: (Int,Int) -> Int -> Int +diagLen (m,n) i + | m <= n = + if i <= 0 + then max (m + i) 0 + else min (n - i) m + | otherwise = + if i > 0 + then max (n - i) 0 + else min (m + i) n + +checkedSubmatrix :: (Int,Int) -> ((Int,Int) -> (Int,Int) -> a) -> (Int,Int) -> (Int,Int) -> a +checkedSubmatrix (m,n) sub (i,j) (m',n') + | or [ i < 0, m' < 0, i + m' > m, + j < 0, n' < 0, j + n' > n ] = + error $ printf ("tried to create submatrix of a `(%d,%d)' matrix " ++ + " using offset `(%d,%d)' and shape (%d,%d)") m n i j m' n' + | otherwise = + sub (i,j) (m',n') + + +checkMatMatOp :: String -> (Int,Int) -> (Int,Int) -> a -> a +checkMatMatOp name mn1 mn2 + | mn1 /= mn2 = + error $ printf + ("%s: x and y have different shapes. x has shape `%s'," + ++ " and y has shape `%s'") name (show mn1) (show mn2) + | otherwise = id + +checkMatVecMult :: (Int,Int) -> Int -> a -> a +checkMatVecMult mn n + | snd mn /= n = + error $ printf + ("Tried to multiply a matrix with shape `%s' by a vector of dimension `%d'") + (show mn) n + | otherwise = id + +checkMatMatMult :: (Int,Int) -> (Int,Int) -> a -> a +checkMatMatMult mk kn + | snd mk /= fst kn = + error $ printf + ("Tried to multiply a matrix with shape `%s' by a matrix with shape `%s'") + (show mk) (show kn) + | otherwise = id + +checkMatVecMultAdd :: (Int,Int) -> Int -> Int -> a -> a +checkMatVecMultAdd mn n m + | snd mn /= n = + error $ printf + ("Tried to multiply a matrix with shape `%s' by a vector of dimension `%d'") + (show mn) n + | fst mn /= m = + error $ printf + ("Tried to add a vector of dimension `%d' to a vector of dimension `%d'") + (fst mn) m + | otherwise = id + +checkMatMatMultAdd :: (Int,Int) -> (Int,Int) -> (Int,Int) -> a -> a +checkMatMatMultAdd mk kn mn + | snd mk /= fst kn = + error $ printf + ("Tried to multiply a matrix with shape `%s' by a matrix with shape `%s'") + (show mk) (show kn) + | (fst mk, snd kn) /= mn = + error $ printf + ("Tried to add a matrix with shape `%s' to a matrix with shape `%s'") + (show (fst mk, snd kn)) (show mn) + | otherwise = id + +checkMatVecSolv :: (Int,Int) -> Int -> a -> a +checkMatVecSolv mn m + | fst mn /= m = + error $ printf + ("Tried to solve a matrix with shape `%s' for a vector of dimension `%d'") + (show mn) m + | otherwise = id + +checkMatVecSolvTo :: (Int,Int) -> Int -> Int -> a -> a +checkMatVecSolvTo mn m n + | fst mn /= m = + error $ printf + ("Tried to solve a matrix with shape `%s' for a vector of dimension `%d'") + (show mn) m + | snd mn /= n = + error $ printf + ("Tried to store a vector of dimension `%s' in a vector of dimension `%d'") + (show $ snd mn) n + | otherwise = id + +checkMatMatSolv :: (Int,Int) -> (Int,Int) -> a -> a +checkMatMatSolv mn mk + | fst mn /= fst mk = + error $ printf + ("Tried to solve a matrix with shape `%s' for a matrix with shape `%s'") + (show mn) (show mk) + | otherwise = id + +checkMatMatSolvTo :: (Int,Int) -> (Int,Int) -> (Int,Int) -> a -> a +checkMatMatSolvTo mk mn kn + | fst mn /= fst mk = + error $ printf + ("Tried to solve a matrix with shape `%s' for a matrix with shape `%s'") + (show mk) (show mn) + | kn /= (snd mk, snd mn) = + error $ printf + ("Tried to store a matrix with shape `%s' in a matrix with shape `%s'") + (show (snd mk, snd mn)) (show kn) + | otherwise = id + +checkSquare :: String -> (Int,Int) -> a -> a +checkSquare str (m,n) + | m /= n = + error $ printf + "%s : matrix shape must be square." + str m n + | otherwise = id + +checkFat :: String -> (Int,Int) -> a -> a +checkFat str (m,n) + | m > n = + error $ printf + "%s : matrix must have at least as many columns as rows." + str m n + | otherwise = id + +checkTall :: String -> (Int,Int) -> a -> a +checkTall str (m,n) + | m < n = + error $ printf + "%s : matrix must have at least as many rows as columns." + str m n + | otherwise = id + +checkBinaryOp :: (Eq i, Show i) => i -> i -> a -> a +checkBinaryOp m n + | m /= n = + error $ printf + ("Shapes in binary operation do not match. " + ++ " First operand has shape `%s' and second has shapw `%s'.") + (show m) + (show n) + | otherwise = id +{-# INLINE checkBinaryOp #-} + +checkTernaryOp :: (Eq i, Show i) => i -> i -> i -> a -> a +checkTernaryOp l m n + | l == m && l == n = id + | otherwise = + error $ printf + ("Shapes in ternary operation do not match. " + ++ " First operand has shape `%s', second has shapw `%s'," + ++ " and third has shape `%s'.") + (show l) + (show m) + (show n) +{-# INLINE checkTernaryOp #-} diff --git a/lib/Numeric/LinearAlgebra/Matrix.hs b/lib/Numeric/LinearAlgebra/Matrix.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Immutable dense matrices. + +module Numeric.LinearAlgebra.Matrix ( + -- * Immutable matrices + Matrix, + dim, + + -- * Matrix construction + fromList, + fromCols, + fromRows, + constant, + zero, + + -- * Accessing matrices + at, + indices, + elems, + assocs, + + -- * Incremental matrix updates + update, + unsafeUpdate, + accum, + unsafeAccum, + + -- * Derived matrices + map, + zipWith, + + -- * Matrix views + slice, + takeRows, + dropRows, + splitRowsAt, + takeCols, + dropCols, + splitColsAt, + + -- * Matrix rows and columns + col, + cols, + row, + rows, + + -- * Matrix diagonals + diag, + + -- * Conversions to vectors + toVector, + + -- * Conversions from vectors + fromVector, + fromCol, + fromRow, + + -- * Matrix math operations + shiftDiag, + shiftDiagWithScale, + add, + addWithScale, + sub, + scale, + scaleRows, + scaleCols, + negate, + conjugate, + + -- * Linear algebra + trans, + conjTrans, + rank1Update, + + -- ** Matrix-Vector multiplication + mulVector, + mulVectorWithScale, + addMulVectorWithScales, + + -- ** Matrix-Matrix multiplication + mulMatrix, + mulMatrixWithScale, + addMulMatrixWithScales, + + -- * Conversions between foreign pointers + unsafeFromForeignPtr, + unsafeToForeignPtr, + + -- * Mutable interface + module Numeric.LinearAlgebra.Matrix.ST, + + -- * Hermitian views + module Numeric.LinearAlgebra.Matrix.Herm, + + -- * Triangular views + module Numeric.LinearAlgebra.Matrix.Tri, + + -- * Cholesky factorizations + module Numeric.LinearAlgebra.Matrix.Cholesky, + + -- * Eigenvalues and eigenvectors + module Numeric.LinearAlgebra.Matrix.Eigen, + + -- * Basic multivariate statistics + module Numeric.LinearAlgebra.Matrix.Statistics, + + ) where + +import Prelude hiding ( map, zipWith, negate, ) +import Control.Monad( zipWithM_ ) +import Control.Monad.ST( ST ) +import Foreign( Storable ) +import Text.Printf( printf ) + +import Foreign.BLAS( BLAS1, BLAS2, BLAS3, Trans(..) ) +import Foreign.VMath( VNum ) + + +import Numeric.LinearAlgebra.Matrix.Base +import Numeric.LinearAlgebra.Matrix.Herm +import Numeric.LinearAlgebra.Matrix.Tri +import Numeric.LinearAlgebra.Matrix.ST +import Numeric.LinearAlgebra.Matrix.Cholesky +import Numeric.LinearAlgebra.Matrix.Eigen +import Numeric.LinearAlgebra.Matrix.Statistics +import Numeric.LinearAlgebra.Vector( Vector ) +import qualified Numeric.LinearAlgebra.Vector as V + + +infixl 7 `scale`, `scaleRows`, `scaleCols` +infixl 6 `add`, `shiftDiag`, `sub` + + +-- | Create a matrix of the given dimension with the given vectors as +-- columns. +fromCols :: (Storable e) => (Int,Int) -> [Vector e] -> Matrix e +fromCols mn cs = create $ do + a <- new_ mn + withColsM a $ \cs' -> zipWithM_ V.copyTo cs' cs + return a + +-- | Create a matrix of the given dimension with the given vectors as +-- rows. +fromRows :: (Storable e) => (Int,Int) -> [Vector e] -> Matrix e +fromRows (m,n) rs = create $ do + a <- new_ (m,n) + sequence_ [ setRow a i r | (i,r) <- zip [ 0..m-1 ] rs ] + return a + +-- | Get the given row of the matrix. +row :: (BLAS1 e) => Matrix e -> Int -> Vector e +row a i + | i < 0 || i >= m = error $ + printf ("row %d:" + ++ " index out of range") m n i + | otherwise = + unsafeRow a i + where + (m,n) = dim a +{-# INLINE row #-} + +-- | Version of 'row' that doesn't range-check indices. +unsafeRow :: (BLAS1 e) => Matrix e -> Int -> Vector e +unsafeRow a@(Matrix v _ n lda) i + | lda == 1 = v + | otherwise = V.create $ do + r <- V.new_ n + unsafeRowTo r a i + return r + +-- | Get a list of the rows in a matrix +rows :: (BLAS1 e) => Matrix e -> [Vector e] +rows a = [ unsafeRow a i | i <- [ 0..m-1 ] ] + where + (m,_) = dim a + + +-- | Get the diagonal of the matrix. +diag :: (Storable e) => Matrix e -> Vector e +diag a = V.create $ do + x <- V.new_ mn + diagTo x a + return x + where + (m,n) = dim a + mn = min m n + +-- | @shiftDiag d a@ returns @diag(d) + a@. +shiftDiag :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e +shiftDiag s a = create $ do + a' <- newCopy a + shiftDiagM_ s a' + return a' + +-- | @shiftDiagWithScale alpha d a@ returns @alpha * diag(d) + a@. +shiftDiagWithScale :: (BLAS1 e) => e -> Vector e -> Matrix e -> Matrix e +shiftDiagWithScale e s a = create $ do + a' <- newCopy a + shiftDiagWithScaleM_ e s a' + return a' + +-- | @add a b@ returns @a + b@. +add :: (VNum e) => Matrix e -> Matrix e -> Matrix e +add = result2 addTo + +-- | @sub a b@ returns @a - b@. +sub :: (VNum e) => Matrix e -> Matrix e -> Matrix e +sub = result2 subTo + +-- | @scale k a@ returns @k * a@. +scale :: (BLAS1 e) => e -> Matrix e -> Matrix e +scale k a = create $ do + a' <- newCopy a + scaleM_ k a' + return a' + +-- | @addWithScale alpha x y@ returns @alpha * x + y@. +addWithScale :: (BLAS1 e) => e -> Matrix e -> Matrix e -> Matrix e +addWithScale alpha x y = create $ do + y' <- newCopy y + addWithScaleM_ alpha x y' + return y' + +-- | @scaleRows s a@ returns @diag(s) * a@. +scaleRows :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e +scaleRows s a = create $ do + a' <- newCopy a + scaleRowsM_ s a' + return a' + +-- | @scaleCols s a@ returns @a * diag(s)@. +scaleCols :: (BLAS1 e) => Vector e -> Matrix e -> Matrix e +scaleCols s a = create $ do + a' <- newCopy a + scaleColsM_ s a' + return a' + +-- | @negate a@ returns @-a@. +negate :: (VNum e) => Matrix e -> Matrix e +negate = result negateTo + +-- | @conjugate a@ returns @conjugate(a)@. +conjugate :: (VNum e) => Matrix e -> Matrix e +conjugate = result conjugateTo + +-- | @trans a@ retunrs @trans(a)@. +trans :: (BLAS1 e) + => Matrix e + -> Matrix e +trans a = let + (m,n) = dim a + in create $ do + a' <- new_ (n,m) + transTo a' a + return a' + +-- | @conjTrans a@ retunrs @conj(trans(a))@. +conjTrans :: (BLAS1 e) + => Matrix e + -> Matrix e +conjTrans a = let + (m,n) = dim a + in create $ do + a' <- new_ (n,m) + conjTransTo a' a + return a' + +-- | @rank1Update alpha x y a@ returns @alpha * x * y^H + a@. +rank1Update :: (BLAS2 e) + => e + -> Vector e + -> Vector e + -> Matrix e + -> Matrix e +rank1Update alpha x y a = + create $ do + a' <- newCopy a + rank1UpdateM_ alpha x y a' + return a' + +-- | @mulVector transa a x@ +-- returns @op(a) * x@, where @op(a)@ is determined by @transa@. +mulVector :: (BLAS2 e) + => Trans -> Matrix e + -> Vector e + -> Vector e +mulVector transa a x = let + m = case transa of NoTrans -> (fst . dim) a + _ -> (snd . dim) a + in V.create $ do + y <- V.new_ m + mulVectorTo y transa a x + return y + +-- | @mulVectorWithScale alpha transa a x@ +-- retunrs @alpha * op(a) * x@, where @op(a)@ is determined by @transa@. +mulVectorWithScale :: (BLAS2 e) + => e + -> Trans -> Matrix e + -> Vector e + -> Vector e +mulVectorWithScale alpha transa a x = let + m = case transa of NoTrans -> (fst . dim) a + _ -> (snd . dim) a + in V.create $ do + y <- V.new_ m + mulVectorWithScaleTo y alpha transa a x + return y + +-- | @addMulVectorWithScales alpha transa a x beta y@ +-- returns @alpha * op(a) * x + beta * y@, where @op(a)@ is +-- determined by @transa@. +addMulVectorWithScales :: (BLAS2 e) + => e + -> Trans -> Matrix e + -> Vector e + -> e + -> Vector e + -> Vector e +addMulVectorWithScales alpha transa a x beta y = + V.create $ do + y' <- V.newCopy y + addMulVectorWithScalesM_ alpha transa a x beta y' + return y' + +-- | @mulMatrix transa a transb b@ +-- returns @op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined +-- by @transa@ and @transb@. +mulMatrix :: (BLAS3 e) + => Trans -> Matrix e + -> Trans -> Matrix e + -> Matrix e +mulMatrix transa a transb b = let + m = case transa of NoTrans -> (fst . dim) a + _ -> (snd . dim) a + n = case transb of NoTrans -> (snd . dim) b + _ -> (fst . dim) b + in create $ do + c <- new_ (m,n) + mulMatrixTo c transa a transb b + return c + +-- | @mulMatrixWithScale alpha transa a transb b@ +-- returns @alpha * op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined +-- by @transa@ and @transb@. +mulMatrixWithScale :: (BLAS3 e) + => e + -> Trans -> Matrix e + -> Trans -> Matrix e + -> Matrix e +mulMatrixWithScale alpha transa a transb b = let + m = case transa of NoTrans -> (fst . dim) a + _ -> (snd . dim) a + n = case transb of NoTrans -> (snd . dim) b + _ -> (fst . dim) b + in create $ do + c <- new_ (m,n) + mulMatrixWithScaleTo c alpha transa a transb b + return c + +-- | @addMulMatrixWithScales alpha transa a transb b beta c@ +-- returns @alpha * op(a) * op(b) + beta * c@, where @op(a)@ and +-- @op(b)@ are determined by @transa@ and @transb@. +addMulMatrixWithScales :: (BLAS3 e) + => e + -> Trans -> Matrix e + -> Trans -> Matrix e + -> e + -> Matrix e + -> Matrix e +addMulMatrixWithScales alpha transa a transb b beta c = + create $ do + c' <- newCopy c + addMulMatrixWithScalesM_ alpha transa a transb b beta c' + return c' + +result :: (Storable e, Storable f) + => (forall s . STMatrix s f -> Matrix e -> ST s a) + -> Matrix e + -> Matrix f +result f a = create $ newResult f a +{-# INLINE result #-} + +result2 :: (Storable e, Storable f, Storable g) + => (forall s . STMatrix s g -> Matrix e -> Matrix f -> ST s a) + -> Matrix e + -> Matrix f + -> Matrix g +result2 f a1 a2 = create $ newResult2 f a1 a2 +{-# INLINE result2 #-} + +newResult :: (RMatrix m, Storable e, Storable f) + => (STMatrix s f -> m e -> ST s a) + -> m e + -> ST s (STMatrix s f) +newResult f a = do + mn <- getDim a + c <- new_ mn + _ <- f c a + return c +{-# INLINE newResult #-} + +newResult2 :: (RMatrix m1, RMatrix m2, Storable e, Storable f, Storable g) + => (STMatrix s g -> m1 e -> m2 f -> ST s a) + -> m1 e + -> m2 f + -> ST s (STMatrix s g) +newResult2 f a1 a2 = do + mn <- getDim a1 + c <- new_ mn + _ <- f c a1 a2 + return c +{-# INLINE newResult2 #-} diff --git a/lib/Numeric/LinearAlgebra/Matrix/Base.hs b/lib/Numeric/LinearAlgebra/Matrix/Base.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Base.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, Rank2Types #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Base +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Numeric.LinearAlgebra.Matrix.Base ( + Matrix(..), + dim, + + fromList, + fromRow, + fromCol, + zero, + constant, + + at, + unsafeAt, + + indices, + elems, + assocs, + + col, + unsafeCol, + cols, + + update, + unsafeUpdate, + accum, + unsafeAccum, + + map, + zipWith, + unsafeZipWith, + + + slice, + unsafeSlice, + + splitRowsAt, + dropRows, + takeRows, + + splitColsAt, + dropCols, + takeCols, + + fromVector, + toVector, + + isContig, + unsafeFromForeignPtr, + unsafeToForeignPtr, + unsafeWith, + + ) where + +import Prelude hiding ( read, map, zipWith ) +import qualified Prelude as P + +import Data.AEq( AEq(..) ) +import Data.Typeable( Typeable ) +import Foreign( ForeignPtr, Ptr, Storable ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Vector( Vector ) +import qualified Numeric.LinearAlgebra.Vector as V + +-- | Immutable dense matrices. +data Matrix e = + Matrix {-# UNPACK #-} !(Vector e) -- matrix data + {-# UNPACK #-} !Int -- row dimension + {-# UNPACK #-} !Int -- column dimension + {-# UNPACK #-} !Int -- leading dimension + deriving (Typeable) + +-- | Get the matrix dimensions (number of rows and number of columns). +dim :: (Storable e) => Matrix e -> (Int,Int) +dim (Matrix _ m n _) = (m,n) +{-# INLINE dim #-} + +-- | Indicates if the elements of the matrix are stored contigously +isContig :: (Storable e) => Matrix e -> Bool +isContig (Matrix _ m _ lda) = lda == m || m == 0 +{-# INLINE isContig #-} + +-- | Create a matrix of the given dimension with elements initialized +-- to the values from the list, in column major order. +fromList :: (Storable e) => (Int,Int) -> [e] -> Matrix e +fromList (m,n) es + | m < 0 || n < 0 = error $ + printf "fromList (%d,%d): negative dimension" m n + | otherwise = let + v = V.fromList (m*n) es + lda = max 1 m + in Matrix v m n lda +{-# INLINE fromList #-} + +-- | Create a matrix of the given dimension with all elements initialized +-- to the given value +constant :: (Storable e) => (Int,Int) -> e -> Matrix e +constant (m,n) e + | m < 0 || n < 0 = error $ + printf "constant (%d,%d): negative dimension" m n + | otherwise = let + v = V.constant (m*n) e + lda = max 1 m + in Matrix v m n lda +{-# INLINE constant #-} + +-- | Create a zero of the given dimension with all elements initialized +-- to zero. +zero :: (Storable e, Num e) => (Int,Int) -> Matrix e +zero (m,n) + | m < 0 || n < 0 = error $ + printf "zero (%d,%d): negative dimension" m n + | otherwise = let + v = V.zero (m*n) + lda = max 1 m + in Matrix v m n lda +{-# INLINE zero #-} + +-- | Returns the element of a matrix at the specified index. +at :: (Storable e) => Matrix e -> (Int,Int) -> e +at a ij@(i,j) + | i < 0 || i >= m || j < 0 || j >= n = error $ + printf ("at (%d,%d):" + ++ " invalid index") m n i j + | otherwise = + unsafeAt a ij + where + (m,n) = dim a +{-# INLINE at #-} + +unsafeAt :: (Storable e) => Matrix e -> (Int,Int) -> e +unsafeAt (Matrix v _ _ lda) (i,j) = + V.unsafeAt v (i + j * lda) +{-# INLINE unsafeAt #-} + +-- | Get the indices of the elements in the matrix, in column-major order. +indices :: (Storable e) => Matrix e -> [(Int,Int)] +indices a = [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ] + where (m,n) = dim a + +-- | Returns a list of the elements of a matrix, in the same order as their +-- indices. +elems :: (Storable e) => Matrix e -> [e] +elems (Matrix v m _ lda) + | lda == m = V.elems v + | otherwise = let + breakCols [] = [] + breakCols es = let (c,es') = splitAt lda es in c:(breakCols es') + + dropJunk c = take m c + + in concatMap dropJunk $ breakCols (V.elems v) +{-# INLINE elems #-} + +-- | Returns the contents of a matrix as a list of associations. +assocs :: (Storable e) => Matrix e -> [((Int,Int),e)] +assocs x = zip (indices x) (elems x) +{-# INLINE assocs #-} + +-- | Version of 'update' that doesn't range-check indices. +unsafeUpdate :: (Storable e) => Matrix e -> [((Int,Int),e)] -> Matrix e +unsafeUpdate (Matrix v m n lda) ijes = let + ies = [ (i + j * lda, e) | ((i,j),e) <- ijes ] + v' = V.unsafeUpdate v ies + in Matrix v' m n lda + +-- | Create a new matrix by replacing the values at the specified indices. +update :: (Storable e) => Matrix e -> [((Int,Int),e)] -> Matrix e +update (Matrix v m n lda) ijes = let + ies = [ if i < 0 || i >= m || j < 0 || j >= n + then error $ printf + ("update" + ++ " " + ++ " [ ..((%d,%d),_).. ]" + ++ ": invalid index") + m n i j + else (i + j * lda, e) + | ((i,j),e) <- ijes + ] + v' = V.unsafeUpdate v ies + in Matrix v' m n lda + +-- | Same as 'accum' but does not range-check indices. +unsafeAccum :: (Storable e) + => (e -> e' -> e) + -> Matrix e + -> [((Int,Int), e')] + -> Matrix e +unsafeAccum f (Matrix v m n lda) ijes = let + ies = [ (i + j * lda, e) | ((i,j),e) <- ijes ] + v' = V.unsafeAccum f v ies + in Matrix v' m n lda + +-- | @accum f@ takes a matrix and an association list and accumulates +-- pairs from the list into the matrix with the accumulating function @f@. +accum :: (Storable e) + => (e -> e' -> e) + -> Matrix e + -> [((Int,Int), e')] + -> Matrix e +accum f (Matrix v m n lda) ijes = let + ies = [ if i < 0 || i >= m || j < 0 || j >= n + then error $ printf + ("accum" + ++ " " + ++ " [ ..((%d,%d),_).. ]" + ++ ": invalid index") + m n i j + else (i + j * lda, e) + | ((i,j),e) <- ijes + ] + v' = V.unsafeAccum f v ies + in Matrix v' m n lda + +-- | Construct a new matrix by applying a function to every element of +-- a matrix. +map :: (Storable e, Storable e') + => (e -> e') + -> Matrix e + -> Matrix e' +map f a = fromList (dim a) $ P.map f (elems a) +{-# INLINE map #-} + +-- | Construct a new matrix by applying a function to every pair of elements +-- of two matrices. The two matrices must have identical dimensions. +zipWith :: (Storable e, Storable e', Storable f) + => (e -> e' -> f) + -> Matrix e + -> Matrix e' + -> Matrix f +zipWith f a a' + | mn /= mn' = error $ + printf ("zipWith" + ++ " " + ++ " " + ++ ": dimension mismatch" + ) (show mn) (show mn') + | otherwise = + unsafeZipWith f a a' + where + mn = dim a + mn' = dim a' +{-# INLINE zipWith #-} + +-- | Version of 'zipWith' that does not check if the input matrices +-- have the same dimensions. +unsafeZipWith :: (Storable e, Storable e', Storable f) + => (e -> e' -> f) + -> Matrix e + -> Matrix e' + -> Matrix f +unsafeZipWith f a a' = + fromList (dim a') $ P.zipWith f (elems a) (elems a') +{-# INLINE unsafeZipWith #-} + +-- | Get the given column of the matrix. +col :: (Storable e) => Matrix e -> Int -> Vector e +col a j + | j < 0 || j >= n = error $ + printf ("col %d:" + ++ " index out of range") m n j + | otherwise = + unsafeCol a j + where + (m,n) = dim a +{-# INLINE col #-} + +-- | Version of 'col' that doesn't range-check indices. +unsafeCol :: (Storable e) => Matrix e -> Int -> Vector e +unsafeCol (Matrix v m _ lda) j = + V.unsafeSlice (j*lda) m v +{-# INLINE unsafeCol #-} + +-- | Get a list of the columns of the matrix. +cols :: (Storable e) => Matrix e -> [Vector e] +cols a = P.map (unsafeCol a) [ 0..n-1 ] + where + (_,n) = dim a +{-# INLINE cols #-} + +-- | @slice (i,j) (m,n) a@ creates a submatrix view of @a@ starting at +-- element @(i,j)@ and having dimensions @(m,n)@. +slice :: (Storable e) + => (Int,Int) + -> (Int,Int) + -> Matrix e + -> Matrix e +slice (i,j) (m',n') a + | (i < 0 || m' < 0 || i + m' > m + || j < 0 || n' < 0 || j + n' > n) = error $ + printf ( "slice" + ++ " (%d,%d)" + ++ " (%d,%d)" + ++ " " + ++ ": index out of range" + ) i j m' n' m n + | otherwise = + unsafeSlice (i,j) (m',n') a + where + (m,n) = dim a +{-# INLINE slice #-} + +-- | Version of 'slice' that doesn't range-check indices. +unsafeSlice :: (Storable e) + => (Int,Int) -> (Int,Int) -> Matrix e -> Matrix e +unsafeSlice (i,j) (m',n') (Matrix v _ _ lda) = let + o = i + j*lda + l = if m' == 0 + then 0 + else lda * n' + v' = V.unsafeSlice o l v + in Matrix v' m' n' lda +{-# INLINE unsafeSlice #-} + +-- | Create a view of a matrix by taking the initial rows. +takeRows :: (Storable e) => Int -> Matrix e -> Matrix e +takeRows i a = slice (0,0) (i,n) a + where + (_,n) = dim a + +-- | Create a view of a matrix by dropping the initial rows. +dropRows :: (Storable e) => Int -> Matrix e -> Matrix e +dropRows i a = slice (i,0) (m-i,n) a + where + (m,n) = dim a + +-- | Split a matrix into two blocks and returns views into the blocks. If +-- @(a1, a2) = splitRowsAt i a@, then +-- @a1 = slice (0,0) (i,n) a@ and +-- @a2 = slice (i,0) (m-i,n) a@, where @(m,n)@ is the dimension of @a@. +splitRowsAt :: (Storable e) => Int -> Matrix e -> (Matrix e, Matrix e) +splitRowsAt i a + | i < 0 || i > m = error $ + printf ("splitRowsAt %d :" + ++ " invalid index") i m n + | otherwise = let + a1 = unsafeSlice (0,0) (i,n) a + a2 = unsafeSlice (i,0) (m-i,n) a + in (a1,a2) + where + (m,n) = dim a +{-# INLINE splitRowsAt #-} + +-- | Create a view of a matrix by taking the initial columns. +takeCols :: (Storable e) => Int -> Matrix e -> Matrix e +takeCols j a = slice (0,0) (m,j) a + where + (m,_) = dim a + +-- | Create a view of a matrix by dropping the initial columns. +dropCols :: (Storable e) => Int -> Matrix e -> Matrix e +dropCols j a = slice (0,j) (m,n-j) a + where + (m,n) = dim a + +-- | Split a matrix into two blocks and returns views into the blocks. If +-- @(a1, a2) = splitColsAt j a@, then +-- @a1 = slice (0,0) (m,j) a@ and +-- @a2 = slice (0,j) (m,n-j) a@, where @(m,n)@ is the dimension of @a@. +splitColsAt :: (Storable e) => Int -> Matrix e -> (Matrix e, Matrix e) +splitColsAt j a + | j < 0 || j > n = error $ + printf ("splitColsAt %d :" + ++ " invalid index") j m n + | otherwise = let + a1 = unsafeSlice (0,0) (m,j) a + a2 = unsafeSlice (0,j) (m,n-j) a + in (a1,a2) + where + (m,n) = dim a +{-# INLINE splitColsAt #-} + + +-- | Convert a matrix to a vector by stacking its columns. +toVector :: (Storable e) + => Matrix e + -> Vector e +toVector a@(Matrix v m n _lda) + | isContig a = v + | otherwise = V.fromList (m*n) $ elems a + +-- | Cast a vector to a matrix of the given shape. +fromVector :: (Storable e) + => (Int,Int) + -> Vector e + -> Matrix e +fromVector (m,n) v + | nv /= m * n = error $ + printf ("fromVector" + ++ " (%d,%d)" + ++ " " + ++ ": dimension mismatch" + ) m n nv + | otherwise = + Matrix v m n (max 1 m) + where + nv = V.dim v +{-# INLINE fromVector #-} + +-- | Cast a vector to a matrix with one column. +fromCol :: (Storable e) + => Vector e + -> Matrix e +fromCol v = Matrix v m 1 (max 1 m) + where + m = V.dim v + +-- | Cast a vector to a matrix with one row. +fromRow :: (Storable e) + => Vector e + -> Matrix e +fromRow v = Matrix v 1 n 1 + where + n = V.dim v + +instance (Storable e, Show e) => Show (Matrix e) where + show x = "fromList " ++ show (dim x) ++ " " ++ show (elems x) + {-# INLINE show #-} + +instance (Storable e, Eq e) => Eq (Matrix e) where + (==) = compareWith (==) + {-# INLINE (==) #-} + +instance (Storable e, AEq e) => AEq (Matrix e) where + (===) = compareWith (===) + {-# INLINE (===) #-} + (~==) = compareWith (~==) + {-# INLINE (~==) #-} + +compareWith :: (Storable e, Storable e') + => (e -> e' -> Bool) + -> Matrix e + -> Matrix e' + -> Bool +compareWith cmp a a' = + dim a == dim a' + && and (P.zipWith cmp (elems a) (elems a')) +{-# INLINE compareWith #-} + +-- | Create a matrix from a 'ForeignPtr' with offset, dimensions, and lda. The +-- data may not be modified through the ForeignPtr afterwards. +unsafeFromForeignPtr :: (Storable e) + => ForeignPtr e -- ^ pointer + -> Int -- ^ offset + -> (Int,Int) -- ^ dimensions + -> Int -- ^ leading dimension (lda) + -> Matrix e +unsafeFromForeignPtr p o (m,n) lda = let + nv = if m == 0 then 0 else n * lda + v = V.unsafeFromForeignPtr p o nv + in Matrix v m n lda +{-# INLINE unsafeFromForeignPtr #-} + +-- | Yield the underlying 'ForeignPtr' together with the offset to the data +-- the matrix dimensions, and the lda. The data may not be modified through +-- the 'ForeignPtr'. +unsafeToForeignPtr :: (Storable e) + => Matrix e + -> (ForeignPtr e, Int, (Int,Int), Int) +unsafeToForeignPtr (Matrix v m n lda) = let + (f,o,_) = V.unsafeToForeignPtr v + in (f, o, (m,n), lda) +{-# INLINE unsafeToForeignPtr #-} + +-- | Execute an 'IO' action with a pointer to the first element in the +-- matrix and the leading dimension (lda). +unsafeWith :: (Storable e) => Matrix e -> (Ptr e -> Int -> IO a) -> IO a +unsafeWith (Matrix v _ _ lda) f = + V.unsafeWith v $ \p -> f p lda +{-# INLINE unsafeWith #-} diff --git a/lib/Numeric/LinearAlgebra/Matrix/Cholesky.hs b/lib/Numeric/LinearAlgebra/Matrix/Cholesky.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Cholesky.hs @@ -0,0 +1,133 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Cholesky +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Cholesky factorizations of symmetric (Hermitian) positive-definite +-- matrices. +-- + +module Numeric.LinearAlgebra.Matrix.Cholesky ( + -- * Immutable interface + cholFactor, + cholSolveVector, + cholSolveMatrix, + + -- * Mutable interface + cholFactorM, + cholSolveVectorM_, + cholSolveMatrixM_, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Text.Printf( printf ) + +import qualified Foreign.LAPACK as LAPACK + +import Numeric.LinearAlgebra.Types + +import Numeric.LinearAlgebra.Matrix.Base( Matrix ) +import Numeric.LinearAlgebra.Matrix.STBase( RMatrix, STMatrix ) +import qualified Numeric.LinearAlgebra.Matrix.STBase as M + +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V + + +-- | @cholFactor a@ tries to compute the Cholesky +-- factorization of @a@. If @a@ is positive-definite then the routine +-- returns @Right@ with the factorization. If the leading minor of order @i@ +-- is not positive-definite then the routine returns @Left i@. +cholFactor :: (LAPACK e) + => Herm Matrix e + -> Either Int (Chol Matrix e) +cholFactor (Herm uplo a) = runST $ do + ma <- M.newCopy a + cholFactorM (Herm uplo ma) + >>= either (return . Left) (\(Chol uplo' ma') -> do + a' <- M.unsafeFreeze ma' + return $ Right (Chol uplo' a') + ) + +-- | @cholSolveVector a x@ returns @a \\ x@. +cholSolveVector :: (LAPACK e) + => Chol Matrix e + -> Vector e + -> Vector e +cholSolveVector a x = V.create $ do + x' <- V.newCopy x + cholSolveVectorM_ a x' + return x' + +-- | @cholSolveMatrix a b@ returns @a \\ b@. +cholSolveMatrix :: (LAPACK e) + => Chol Matrix e + -> Matrix e + -> Matrix e +cholSolveMatrix a c = M.create $ do + c' <- M.newCopy c + cholSolveMatrixM_ a c' + return c' + +-- | @cholFactorM a@ tries to compute the Cholesky +-- factorization of @a@ in place. If @a@ is positive-definite then the +-- routine returns @Right@ with the factorization, stored in the same +-- memory as @a@. If the leading minor of order @i@ is not +-- positive-definite then the routine returns @Left i@. +-- In either case, the original storage of @a@ is destroyed. +cholFactorM :: (LAPACK e) + => Herm (STMatrix s) e + -> ST s (Either Int (Chol (STMatrix s) e)) +cholFactorM (Herm uplo a) = do + (ma,na) <- M.getDim a + let n = na + + when (not $ (ma,na) == (n,n)) $ error $ + printf ("cholFactorM" + ++ " (Herm _ ): nonsquare matrix" + ) ma na + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> do + info <- LAPACK.potrf uplo n pa lda + return $ if info > 0 then Left info + else Right (Chol uplo a) + + +-- | @cholSolveVectorM_ a x@ sets @x := a \\ x@. +cholSolveVectorM_ :: (LAPACK e, RMatrix m) + => Chol m e + -> STVector s e + -> ST s () +cholSolveVectorM_ a x = + M.withFromColM x $ \x' -> + cholSolveMatrixM_ a x' + +-- | @cholSolveMatrixM_ a b@ sets @b := a \\ b@. +cholSolveMatrixM_ :: (LAPACK e, RMatrix m) + => Chol m e + -> STMatrix s e + -> ST s () +cholSolveMatrixM_ (Chol uplo a) b = do + (ma,na) <- M.getDim a + (mb,nb) <- M.getDim b + let (n,nrhs) = (mb,nb) + + when ((not . and) [ (ma,na) == (n,n) + , (mb,nb) == (n,nrhs) + ]) $ error $ + printf ("cholSolveMatrixM_" + ++ " (Chol _ )" + ++ " " + ++ ": dimension mismatch") + ma na mb nb + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith b $ \pb ldb -> + LAPACK.potrs uplo n nrhs pa lda pb ldb diff --git a/lib/Numeric/LinearAlgebra/Matrix/Eigen.hs b/lib/Numeric/LinearAlgebra/Matrix/Eigen.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Eigen.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Eigen +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Eigenvalue decompositions. +-- +module Numeric.LinearAlgebra.Matrix.Eigen ( + hermEigen, + hermEigenvalues, + hermEigenM_, + hermEigenvaluesM_, + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Foreign( allocaArray, nullPtr ) +import Text.Printf( printf ) + +import Foreign.LAPACK( LAPACK, EigJob(..), EigRange(..) ) +import qualified Foreign.LAPACK as LAPACK + +import Numeric.LinearAlgebra.Types( Herm(..) ) +import Numeric.LinearAlgebra.Matrix.Base( Matrix ) +import Numeric.LinearAlgebra.Matrix.STBase( STMatrix ) +import qualified Numeric.LinearAlgebra.Matrix.STBase as M +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +-- | Compute the eigenvalues and eigenvectors of a Hermitian matrix. +-- Return the eigenvalues are in ascending order in the result vector; +-- store the corresponding eigenvectors are in the columns of the result +-- matrix. +hermEigen :: (LAPACK e) => Herm Matrix e -> (Vector Double, Matrix e) +hermEigen (Herm uplo a) = runST $ do + (_,n) <- M.getDim a + ma <- M.newCopy a + mw <- V.new_ n + mz <- M.new_ (n,n) + hermEigenM_ (Herm uplo ma) mw mz + w <- V.unsafeFreeze mw + z <- M.unsafeFreeze mz + return (w,z) + + +-- | Return the eigenvalues of a Hermitian matrix in ascending order. +hermEigenvalues :: (LAPACK e) => Herm Matrix e -> Vector Double +hermEigenvalues (Herm uplo a) = V.create $ do + (_,n) <- M.getDim a + ma <- M.newCopy a + w <- V.new_ n + hermEigenvaluesM_ (Herm uplo ma) w + return w + + +-- | Compute and copy the eigenvalues and eigenvectors of a mutable +-- Hermitian matrix. This destroys the original Hermitian matrix. +hermEigenM_ :: (LAPACK e) + => Herm (STMatrix s) e + -> STVector s Double + -> STMatrix s e + -> ST s () +hermEigenM_ (Herm uplo a) w z = do + (ma,na) <- M.getDim a + (mz,nz) <- M.getDim z + nw <- V.getDim w + let n = na + + when (ma /= na) $ error $ + printf ("hermEigenM_" + ++ " (Herm _ ): nonsquare matrix" + ) ma na + when ((not . and) [ (ma,na) == (n,n) + , nw == n + , (mz,nz) == (n,n) + ]) $ error $ + printf ("hermEigenM_" + ++ " (Herm _ )" + ++ " :" + ++ " " + ++ " dimension mismatch") + ma na nw mz nz + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + V.unsafeWith w $ \pw -> + M.unsafeWith z $ \pz ldz -> + allocaArray (2*n) $ \psuppz -> do + _m <- LAPACK.heevr jobz range uplo n pa lda abstol pw pz ldz + psuppz + return () + where + jobz = EigVectors + range = AllEigs + abstol = 0 + + +-- | Compute and copy the eigenvalues of a mutable Hermitian matrix. This +-- destroys the original Hermitian matrix. +hermEigenvaluesM_ :: (LAPACK e) + => Herm (STMatrix s) e + -> STVector s Double + -> ST s () +hermEigenvaluesM_ (Herm uplo a) w = do + (ma,na) <- M.getDim a + nw <- V.getDim w + let n = na + + when (ma /= na) $ error $ + printf ("hermEigenvaluesM_" + ++ " (Herm _ ): nonsquare matrix" + ) ma na + + when ((not . and) [ (ma,na) == (n,n) + , nw == n + ]) $ error $ + printf ("hermEigenvaluesM_" + ++ " (Herm _ )" + ++ " : dimension mismatch") + ma na nw + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + V.unsafeWith w $ \pw -> do + _m <- LAPACK.heevr jobz range uplo n pa lda abstol pw pz ldz + psuppz + return () + + where + jobz = NoEigVectors + range = AllEigs + abstol = 0 + pz = nullPtr + ldz = 1 + psuppz = nullPtr diff --git a/lib/Numeric/LinearAlgebra/Matrix/Herm.hs b/lib/Numeric/LinearAlgebra/Matrix/Herm.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Herm.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Herm +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Hermitian views of matrices. +-- + +module Numeric.LinearAlgebra.Matrix.Herm ( + -- * Immutable interface + + -- ** Vector multiplication + hermMulVector, + hermMulVectorWithScale, + addHermMulVectorWithScales, + + -- ** Matrix multiplication + hermMulMatrix, + hermMulMatrixWithScale, + addHermMulMatrixWithScales, + + -- ** Updates + hermRank1Update, + hermRank2Update, + hermRankKUpdate, + hermRank2KUpdate, + + + -- * Mutable interface + hermCreate, + + -- ** Vector multiplication + hermMulVectorTo, + hermMulVectorWithScaleTo, + addHermMulVectorWithScalesM_, + + -- ** Matrix multiplication + hermMulMatrixTo, + hermMulMatrixWithScaleTo, + addHermMulMatrixWithScalesM_, + + -- ** Updates + hermRank1UpdateM_, + hermRank2UpdateM_, + hermRankKUpdateM_, + hermRank2KUpdateM_, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Vector( Vector, RVector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V +import Numeric.LinearAlgebra.Matrix.Base( Matrix ) +import Numeric.LinearAlgebra.Matrix.STBase( STMatrix, RMatrix ) +import qualified Numeric.LinearAlgebra.Matrix.STBase as M +import Numeric.LinearAlgebra.Types +import qualified Foreign.BLAS as BLAS + + +-- | A safe way to create and work with a mutable Herm Matrix before returning +-- an immutable one for later perusal. +hermCreate :: (Storable e) + => (forall s. ST s (Herm (STMatrix s) e)) + -> Herm Matrix e +hermCreate mh = runST $ do + (Herm u ma) <- mh + a <- M.unsafeFreeze ma + return $ Herm u a + +-- | @hermRank1Update alpha x a@ returns +-- @alpha * x * x^H + a@. +hermRank1Update :: (BLAS2 e) + => Double -> Vector e -> Herm Matrix e -> Herm Matrix e +hermRank1Update alpha x (Herm uplo a) = runST $ do + ma' <- M.newCopy a + hermRank1UpdateM_ alpha x (Herm uplo ma') + a' <- M.unsafeFreeze ma' + return $ Herm uplo a' + +-- | @hermRank2Update alpha x y a@ returns +-- @alpha * x * y^H + conj(alpha) * y * x^H + a@. +hermRank2Update :: (BLAS2 e) + => e -> Vector e -> Vector e -> Herm Matrix e + -> Herm Matrix e +hermRank2Update alpha x y (Herm uplo a) = runST $ do + ma' <- M.newCopy a + hermRank2UpdateM_ alpha x y (Herm uplo ma') + a' <- M.unsafeFreeze ma' + return $ Herm uplo a' + +-- | @hermRankKUpdate alpha trans a beta c@ returns +-- @c := alpha * a * a^H + beta * c@ when @trans@ is @NoTrans@ and +-- @c := alpha * a^H * a + beta * c@ when @trans@ is @ConjTrans@. The +-- function signals an error when @trans@ is @Trans@. +hermRankKUpdate :: (BLAS3 e) + => e -> Trans -> Matrix e -> e -> Herm Matrix e + -> Herm Matrix e +hermRankKUpdate alpha trans a beta (Herm uplo c) = runST $ do + mc' <- M.newCopy c + hermRankKUpdateM_ alpha trans a beta (Herm uplo mc') + c' <- M.unsafeFreeze mc' + return $ Herm uplo c' + +-- | @hermRank2KUpdate alpha trans a b beta c@ returns +-- @c := alpha * a * b^H + conj(alpha) * b * a^H + beta * c@ when @trans@ is +-- @NoTrans@ and @c := alpha * b^H * a + conj(alpha) * a^H * b + beta * c@ +-- when @trans@ is @ConjTrans@. The function signals an error when @trans@ +-- is @Trans@. +hermRank2KUpdate :: (BLAS3 e) + => e -> Trans -> Matrix e -> Matrix e -> e -> Herm Matrix e + -> Herm Matrix e +hermRank2KUpdate alpha trans a b beta (Herm uplo c) = runST $ do + mc' <- M.newCopy c + hermRank2KUpdateM_ alpha trans a b beta (Herm uplo mc') + c' <- M.unsafeFreeze mc' + return $ Herm uplo c' + +-- | @hermRank1UpdateM_ alpha x a@ sets +-- @a := alpha * x * x^H + a@. +hermRank1UpdateM_ :: (RVector v, BLAS2 e) + => Double -> v e -> Herm (STMatrix s) e -> ST s () +hermRank1UpdateM_ alpha x (Herm uplo a) = do + nx <- V.getDim x + (ma,na) <- M.getDim a + let n = nx + + when ((not . and) [ nx == n, (ma,na) == (n,n) ]) $ error $ + printf ("hermRank1UpdateM_ _ " + ++ " (Herm _ ):" + ++ " invalid dimensions") nx ma na + + unsafeIOToST $ + V.unsafeWith x $ \px -> + M.unsafeWith a $ \pa lda -> + BLAS.her uplo n alpha px 1 pa lda + + +-- | @hermRank2UpdateM_ alpha x y a@ sets +-- @a := alpha * x * y^H + conj(alpha) * y * x^H + a@. +hermRank2UpdateM_ :: (RVector v1, RVector v2, BLAS2 e) + => e -> v1 e -> v2 e -> Herm (STMatrix s) e -> ST s () +hermRank2UpdateM_ alpha x y (Herm uplo a) = do + nx <- V.getDim x + ny <- V.getDim y + (ma,na) <- M.getDim a + let n = nx + + when ((not . and) [ nx == n, ny == n, (ma,na) == (n,n) ]) $ error $ + printf ("hermRank2UpdateM_ _ " + ++ " " + ++ " (Herm _ ):" + ++ " invalid dimensions") nx ny ma na + + unsafeIOToST $ + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + M.unsafeWith a $ \pa lda -> + BLAS.her2 uplo n alpha px 1 py 1 pa lda + + +-- | @hermRankKUpdateM_ alpha trans a beta c@ sets +-- @c := alpha * a * a^H + beta * c@ when @trans@ is @NoTrans@ and +-- @c := alpha * a^H * a + beta * c@ when @trans@ is @ConjTrans@. The +-- function signals an error when @trans@ is @Trans@. +hermRankKUpdateM_ :: (RMatrix m, BLAS3 e) + => e -> Trans -> m e -> e -> Herm (STMatrix s) e + -> ST s () +hermRankKUpdateM_ alpha trans a beta (Herm uplo c) = do + (ma,na) <- M.getDim a + (mc,nc) <- M.getDim c + let (n,k) = if trans == NoTrans then (ma,na) else (na,ma) + + when (trans == Trans) $ error $ + printf ("hermRankKUpdateM_ _ %s:" + ++ " trans argument must be NoTrans or ConjTrans") + (show trans) + + when ((not . and) [ (mc,nc) == (n,n) + , case trans of NoTrans -> (ma,na) == (n,k) + _ -> (ma,na) == (k,n) + ]) $ error $ + printf ("hermRankKUpdateM_ _ %s _" + ++ " (Herm _ ):" + ++ " invalid dimensions") (show trans) ma na mc nc + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith c $ \pc ldc -> + BLAS.herk uplo trans n k alpha pa lda beta pc ldc + + +-- | @hermRank2KUpdateM_ alpha trans a b beta c@ sets +-- @c := alpha * a * b^H + conj(alpha) * b * a^H + beta * c@ when @trans@ is +-- @NoTrans@ and @c := alpha * b^H * a + conj(alpha) * a^H * b + beta * c@ +-- when @trans@ is @ConjTrans@. The function signals an error when @trans@ +-- is @Trans@. +hermRank2KUpdateM_ :: (RMatrix m1, RMatrix m2, BLAS3 e) + => e -> Trans -> m1 e -> m2 e -> e -> Herm (STMatrix s) e + -> ST s () +hermRank2KUpdateM_ alpha trans a b beta (Herm uplo c) = do + (ma,na) <- M.getDim a + (mb,nb) <- M.getDim b + (mc,nc) <- M.getDim c + let (n,k) = if trans == NoTrans then (ma,na) else (na,ma) + + when (trans == Trans) $ error $ + printf ("hermRank2KUpdateM_ _ %s:" + ++ " trans argument must be NoTrans or ConjTrans") + (show trans) + + when ((not . and) [ (mc,nc) == (n,n) + , (mb,nb) == (ma,na) + , case trans of NoTrans -> (ma,na) == (n,k) + _ -> (ma,na) == (k,n) + ]) $ error $ + printf ("hermRank2KUpdateM_ _ %s " + ++ " _" + ++ " (Herm _ ):" + ++ " invalid dimensions") (show trans) ma na mb nb mc nc + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith b $ \pb ldb -> + M.unsafeWith c $ \pc ldc -> + BLAS.her2k uplo trans n k alpha pa lda pb ldb beta pc ldc + + +-- | @hermMulVector a x@ returns @a * x@. +hermMulVector :: (BLAS2 e) + => Herm Matrix e + -> Vector e + -> Vector e +hermMulVector a x = + V.create $ do + n <- V.getDim x + y <- V.new_ n + hermMulVectorTo y a x + return y + +-- | @hermMulVectorWithScale alpha a x@ retunrs @alpha * a * x@. +hermMulVectorWithScale :: (BLAS2 e) + => e + -> Herm Matrix e + -> Vector e + -> Vector e +hermMulVectorWithScale alpha a x = + V.create $ do + n <- V.getDim x + y <- V.new_ n + hermMulVectorWithScaleTo y alpha a x + return y + +-- | @addHermMulVectorWithScales alpha a x y@ +-- returns @alpha * a * x + beta * y@. +addHermMulVectorWithScales :: (BLAS2 e) + => e + -> Herm Matrix e + -> Vector e + -> e + -> Vector e + -> Vector e +addHermMulVectorWithScales alpha a x beta y = + V.create $ do + y' <- V.newCopy y + addHermMulVectorWithScalesM_ alpha a x beta y' + return y' + +-- | @hermMulMatrix side a b@ +-- returns @alpha * a * b@ when @side@ is @LeftSide@ and +-- @alpha * b * a@ when @side@ is @RightSide@. +hermMulMatrix :: (BLAS3 e) + => Side -> Herm Matrix e + -> Matrix e + -> Matrix e +hermMulMatrix side a b = + M.create $ do + mn <- M.getDim b + c <- M.new_ mn + hermMulMatrixTo c side a b + return c + +-- | @hermMulMatrixWithScale alpha side a b@ +-- returns @alpha * a * b@ when @side@ is @LeftSide@ and +-- @alpha * b * a@ when @side@ is @RightSide@. +hermMulMatrixWithScale :: (BLAS3 e) + => e + -> Side -> Herm Matrix e + -> Matrix e + -> Matrix e +hermMulMatrixWithScale alpha side a b = + M.create $ do + mn <- M.getDim b + c <- M.new_ mn + hermMulMatrixWithScaleTo c alpha side a b + return c + +-- | @addHermMulMatrixWithScales alpha side a b beta c@ +-- returns @alpha * a * b + beta * c@ when @side@ is @LeftSide@ and +-- @alpha * b * a + beta * c@ when @side@ is @RightSide@. +addHermMulMatrixWithScales :: (BLAS3 e) + => e + -> Side -> Herm Matrix e + -> Matrix e + -> e + -> Matrix e + -> Matrix e +addHermMulMatrixWithScales alpha side a b beta c = + M.create $ do + c' <- M.newCopy c + addHermMulMatrixWithScalesM_ alpha side a b beta c' + return c' + +-- | @hermMulVectorTo dst a x@ sets @dst := a * x@. +hermMulVectorTo :: (RMatrix m, RVector v, BLAS2 e) + => STVector s e + -> Herm m e + -> v e + -> ST s () +hermMulVectorTo dst = hermMulVectorWithScaleTo dst 1 + +-- | @hermMulVectorWithScaleTo dst alpha a x@ +-- sets @dst := alpha * a * x@. +hermMulVectorWithScaleTo :: (RMatrix m, RVector v, BLAS2 e) + => STVector s e + -> e + -> Herm m e + -> v e + -> ST s () +hermMulVectorWithScaleTo dst alpha a x = + addHermMulVectorWithScalesM_ alpha a x 0 dst + +-- | @addHermMulVectorWithScalesM_ alpha a x beta y@ +-- sets @y := alpha * a * x + beta * y@. +addHermMulVectorWithScalesM_ :: (RMatrix m, RVector v, BLAS2 e) + => e + -> Herm m e + -> v e + -> e + -> STVector s e + -> ST s () +addHermMulVectorWithScalesM_ alpha (Herm uplo a) x beta y = do + (ma,na) <- M.getDim a + nx <- V.getDim x + ny <- V.getDim y + let n = ny + + when (ma /= na) $ error $ + printf ("addHermMulVectorWithScalesM_ _" + ++ " (Herm %s )" + ++ " %s " + ++ " _" + ++ " : Herm matrix is not square") + (show uplo) ma na + nx ny + + when ((not . and) [ (ma,na) == (n,n) + , nx == n + , ny == n + ]) $ error $ + printf ("addHermMulVectorWithScalesM_ _" + ++ " (Herm %s )" + ++ " %s " + ++ " _" + ++ " : dimension mismatch") + (show uplo) ma na + nx ny + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + BLAS.hemv uplo n alpha pa lda px 1 beta py 1 + +-- | @hermMulMatrixTo dst side a b@ +-- sets @dst := a * b@ when @side@ is @LeftSide@ and +-- @dst := b * a@ when @side@ is @RightSide@. +hermMulMatrixTo :: (RMatrix m1, RMatrix m2, BLAS3 e) + => STMatrix s e + -> Side -> Herm m1 e + -> m2 e + -> ST s () +hermMulMatrixTo dst = hermMulMatrixWithScaleTo dst 1 + +-- | @hermMulMatrixWithScaleTo dst alpha side a b@ +-- sets @dst := alpha * a * b@ when @side@ is @LeftSide@ and +-- @dst := alpha * b * a@ when @side@ is @RightSide@. +hermMulMatrixWithScaleTo :: (RMatrix m1, RMatrix m2, BLAS3 e) + => STMatrix s e + -> e + -> Side -> Herm m1 e + -> m2 e + -> ST s () +hermMulMatrixWithScaleTo dst alpha side a b = + addHermMulMatrixWithScalesM_ alpha side a b 0 dst + +-- | @addHermMulMatrixWithScalesM_ alpha side a b beta c@ +-- sets @c := alpha * a * b + beta * c@ when @side@ is @LeftSide@ and +-- @c := alpha * b * a + beta * c@ when @side@ is @RightSide@. +addHermMulMatrixWithScalesM_ :: (RMatrix m1, RMatrix m2, BLAS3 e) + => e + -> Side -> Herm m1 e + -> m2 e + -> e + -> STMatrix s e + -> ST s () +addHermMulMatrixWithScalesM_ alpha side (Herm uplo a) b beta c = do + (ma,na) <- M.getDim a + (mb,nb) <- M.getDim b + (mc,nc) <- M.getDim c + let (m,n) = (mc,nc) + + when (ma /= na) $ error $ + printf ("addHermMulMatrixWithScalesM_ _" + ++ " %s (Herm %s )" + ++ " " + ++ " _" + ++ " : Herm matrix is not square") + (show side) (show uplo) ma na + mb nb + mc nc + when ((not . and) [ case side of LeftSide -> (ma,na) == (m,m) + RightSide -> (ma,na) == (n,n) + , (mb, nb ) == (m,n) + , (mc, nc ) == (m,n) + ]) $ error $ + printf ("addHermMulMatrixWithScalesM_ _" + ++ " %s (Herm %s )" + ++ " " + ++ " _" + ++ " : dimension mismatch") + (show side) (show uplo) ma na + mb nb + mc nc + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith b $ \pb ldb -> + M.unsafeWith c $ \pc ldc -> + BLAS.hemm side uplo m n alpha pa lda pb ldb beta pc ldc diff --git a/lib/Numeric/LinearAlgebra/Matrix/ST.hs b/lib/Numeric/LinearAlgebra/Matrix/ST.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/ST.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.ST +-- Copyright : Copyright (c) , Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Mutable matrices in the ST monad. + +module Numeric.LinearAlgebra.Matrix.ST ( + -- * Mutable matrices + STMatrix, + IOMatrix, + create, + + -- * Read-only matrices + RMatrix(..), + + -- * Creating new matrices + new_, + new, + + -- * Copying matrices + newCopy, + copyTo, + + -- * Matrix views + withSlice, + withTakeRows, + withDropRows, + withSplitRowsAt, + withTakeCols, + withDropCols, + withSplitColsAt, + withSliceM, + withTakeRowsM, + withDropRowsM, + withSplitRowsAtM, + withTakeColsM, + withDropColsM, + withSplitColsAtM, + + -- * Matrix rows and columns + rowTo, + unsafeRowTo, + setRow, + unsafeSetRow, + withCol, + + withColM, + withColsM, + + swapRows, + unsafeSwapRows, + swapCols, + unsafeSwapCols, + + -- * Matrix diagonals + diagTo, + setDiag, + + -- * Reading and writing matrix elements + read, + write, + modify, + getIndices, + getElems, + getElems', + getAssocs, + getAssocs', + setElems, + setAssocs, + + -- * List-like operations + mapTo, + zipWithTo, + + -- * Matrix math operations + shiftDiagM_, + shiftDiagWithScaleM_, + addTo, + subTo, + scaleM_, + addWithScaleM_, + scaleRowsM_, + scaleColsM_, + negateTo, + conjugateTo, + + -- * Linear algebra + transTo, + conjTransTo, + rank1UpdateM_, + + -- ** Matrix-Vector multiplication + mulVectorTo, + mulVectorWithScaleTo, + addMulVectorWithScalesM_, + + -- ** Matrix-Matrix multiplication + mulMatrixTo, + mulMatrixWithScaleTo, + addMulMatrixWithScalesM_, + + -- * Conversions between mutable and immutable matrices + freeze, + + -- * Vector views of matrices + maybeWithVectorM, + + -- * Matrix views of vectors + withFromVector, + withFromCol, + withFromRow, + + withFromVectorM, + withFromColM, + withFromRowM, + + -- * Unsafe operations + unsafeCopyTo, + unsafeAddWithScaleM_, + + ) where + +import Prelude() +import Numeric.LinearAlgebra.Matrix.STBase diff --git a/lib/Numeric/LinearAlgebra/Matrix/STBase.hs b/lib/Numeric/LinearAlgebra/Matrix/STBase.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/STBase.hs @@ -0,0 +1,1250 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, Rank2Types #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.STBase +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : asinerimental +-- + +module Numeric.LinearAlgebra.Matrix.STBase + where + +import Control.Monad( forM_, when ) +import Control.Monad.ST( ST, RealWorld, runST, unsafeInterleaveST, + unsafeIOToST ) +import Data.Maybe( fromMaybe ) +import Data.Typeable( Typeable ) +import Foreign( Ptr, advancePtr, peek, peekElemOff, pokeElemOff, + mallocForeignPtrArray ) +import Text.Printf( printf ) +import Unsafe.Coerce( unsafeCoerce ) + +import Numeric.LinearAlgebra.Types +import qualified Foreign.BLAS as BLAS +import Numeric.LinearAlgebra.Matrix.Base hiding ( unsafeWith, + unsafeToForeignPtr, unsafeFromForeignPtr, ) +import qualified Numeric.LinearAlgebra.Matrix.Base as M +import Numeric.LinearAlgebra.Vector( STVector, RVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +-- | Mutable dense matrices in the 'ST' monad. +newtype STMatrix s e = STMatrix { unSTMatrix :: Matrix e } + deriving (Typeable) + +-- | Mutable dense matrices in the 'IO' monad. +type IOMatrix = STMatrix RealWorld + +-- | A safe way to create and work with a mutable matrix before returning +-- an immutable matrix for later perusal. This function avoids copying +-- the matrix before returning it - it uses 'unsafeFreeze' internally, +-- but this wrapper is a safe interface to that function. +create :: (Storable e) => (forall s . ST s (STMatrix s e)) -> Matrix e +create mx = runST $ mx >>= unsafeFreeze +{-# INLINE create #-} + +-- | Converts a mutable matrix to an immutable one by taking a complete +-- copy of it. +freeze :: (RMatrix m, Storable e) => m e -> ST s (Matrix e) +freeze a = do + a' <- newCopy a + unsafeFreeze a' +{-# INLINE freeze #-} + + +-- | Read-only matrices +class RMatrix m where + -- | Get the dimensions of the matrix (number of rows and columns). + getDim :: (Storable e) => m e -> ST s (Int,Int) + + -- | Same as 'withCol' but does not range-check index. + unsafeWithCol :: (Storable e) + => m e + -> Int + -> (forall v. RVector v => v e -> ST s a) + -> ST s a + + -- | Perform an action with a list of views of the matrix columns. + withCols :: (Storable e) + => m e + -> (forall v . RVector v => [v e] -> ST s a) + -> ST s a + + -- | Same as 'withSlice' but does not range-check index. + unsafeWithSlice :: (Storable e) + => (Int,Int) + -> (Int,Int) + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a + + -- | Possibly view a matrix as a vector and perform an action on the + -- view. This only succeeds if the matrix is stored contiguously in + -- memory, i.e. if the matrix contains a single column or the \"lda\" + -- of the matrix is equal to the number of rows. + maybeWithVector :: (Storable e) + => m e + -> (forall v . RVector v => v e -> ST s a) + -> Maybe (ST s a) + + -- | Converts a read-only matrix into an immutable matrix. This simply + -- casts the matrix from one type to the other without copying. + -- Note that because the matrix is possibly not copied, any subsequent + -- modifications made to the read-only version of the matrix may be shared + -- with the immutable version. It is safe to use, therefore, if the + -- read-only version is never modified after the freeze operation. + unsafeFreeze :: (Storable e) => m e -> ST s (Matrix e) + + -- | Unsafe cast from a read-only matrix to a mutable matrix. + unsafeThaw :: (Storable e) + => m e -> ST s (STMatrix s e) + + -- | Execute an 'IO' action with a pointer to the first element in the + -- matrix and the leading dimension (lda). + unsafeWith :: (Storable e) => m e -> (Ptr e -> Int -> IO a) -> IO a + +instance RMatrix Matrix where + getDim = return . dim + {-# INLINE getDim #-} + unsafeWithCol a j f = f (unsafeCol a j) + {-# INLINE unsafeWithCol #-} + withCols a f = f (cols a) + {-# INLINE withCols #-} + unsafeWithSlice ij mn a f = f (unsafeSlice ij mn a) + {-# INLINE unsafeWithSlice #-} + maybeWithVector a f | isContig a = Just $ f (toVector a) + | otherwise = Nothing + {-# INLINE maybeWithVector #-} + unsafeWith = M.unsafeWith + {-# INLINE unsafeWith #-} + unsafeFreeze = return + {-# INLINE unsafeFreeze #-} + unsafeThaw = return . STMatrix + {-# INLINE unsafeThaw #-} + + +instance RMatrix (STMatrix s) where + getDim = return . dim . unSTMatrix + {-# INLINE getDim #-} + unsafeWithCol = unsafeWithCol . unSTMatrix + {-# INLINE unsafeWithCol #-} + withCols = withCols . unSTMatrix + {-# INLINE withCols #-} + unsafeWithSlice ij mn = unsafeWithSlice ij mn . unSTMatrix + {-# INLINE unsafeWithSlice #-} + maybeWithVector = maybeWithVector . unSTMatrix + {-# INLINE maybeWithVector #-} + unsafeWith = unsafeWith . unSTMatrix + {-# INLINE unsafeWith #-} + unsafeFreeze = return . unSTMatrix + {-# INLINE unsafeFreeze #-} + unsafeThaw v = return $ cast v + where + cast :: STMatrix s e -> STMatrix s' e + cast = unsafeCoerce + {-# INLINE unsafeThaw #-} + + + +-- | Perform an action with a view of a mutable matrix column +-- (no index checking). +unsafeWithColM :: (Storable e) + => STMatrix s e + -> Int + -> (STVector s e -> ST s a) + -> ST s a +unsafeWithColM a j f = + unsafeWithCol a j $ \c -> do + mc <- V.unsafeThaw c + f mc +{-# INLINE unsafeWithColM #-} + +-- | Perform an action with a list of views of the mutable matrix columns. See +-- also 'withCols'. +withColsM :: (Storable e) + => STMatrix s e + -> ([STVector s e] -> ST s a) + -> ST s a +withColsM a f = + withCols a $ \cs -> do + mcs <- thawVecs cs + f mcs + where + thawVecs [] = return [] + thawVecs (c:cs) = unsafeInterleaveST $ do + mc <- V.unsafeThaw c + mcs <- thawVecs cs + return $ mc:mcs +{-# INLINE withColsM #-} + + +-- | Possibly view a matrix as a vector and perform an action on the +-- view. This succeeds when the matrix is stored contiguously in memory, +-- i.e. if the matrix contains a single column or the \"lda\" of the matrix +-- is equal to the number of rows. See also 'maybeWithVector'. +maybeWithVectorM :: (Storable e) + => STMatrix s e + -> (STVector s e -> ST s a) + -> Maybe (ST s a) +maybeWithVectorM a f = + maybeWithVector a $ \v -> do + mv <- V.unsafeThaw v + f mv +{-# INLINE maybeWithVectorM #-} + + +-- | View a vector as a matrix of the given shape and pass it to +-- the specified function. +withFromVector :: (RVector v, Storable e) + => (Int,Int) + -> v e + -> (forall m . RMatrix m => m e -> ST s a) + -> ST s a +withFromVector mn@(m,n) v f = do + nv <- V.getDim v + when (nv /= m*n) $ error $ + printf ("withFromVector (%d,%d) :" + ++ " dimension mismatch") m n nv + iv <- V.unsafeFreeze v + f $ fromVector mn iv +{-# INLINE withFromVector #-} + + +-- | View a mutable vector as a mutable matrix of the given shape and pass it +-- to the specified function. +withFromVectorM :: (Storable e) + => (Int,Int) + -> STVector s e + -> (STMatrix s e -> ST s a) + -> ST s a +withFromVectorM mn@(m,n) v f = do + nv <- V.getDim v + when (nv /= m*n) $ error $ + printf ("withFromVectorM (%d,%d) :" + ++ " dimension mismatch") m n nv + withFromVector mn v $ \a -> do + ma <- unsafeThaw a + f ma +{-# INLINE withFromVectorM #-} + + +-- | View a vector as a matrix with one column and pass it to +-- the specified function. +withFromCol :: (RVector v, Storable e) + => v e + -> (forall m . RMatrix m => m e -> ST s a) + -> ST s a +withFromCol v f = do + m <- V.getDim v + withFromVector (m,1) v f +{-# INLINE withFromCol #-} + + +-- | View a mutable vector as a mutable matrix with one column and pass it to +-- the specified function. +withFromColM :: (Storable e) + => STVector s e + -> (STMatrix s e -> ST s a) + -> ST s a +withFromColM v f = do + m <- V.getDim v + withFromVectorM (m, 1) v f +{-# INLINE withFromColM #-} + + +-- | View a vector as a matrix with one row and pass it to +-- the specified function. +withFromRow :: (RVector v, Storable e) + => v e + -> (forall m . RMatrix m => m e -> ST s a) + -> ST s a +withFromRow v f = do + n <- V.getDim v + withFromVector (1,n) v f +{-# INLINE withFromRow #-} + +-- | View a mutable vector as a mutable matrix with one row and pass it to +-- the specified function. +withFromRowM :: (Storable e) + => STVector s e + -> (STMatrix s e -> ST s a) + -> ST s a +withFromRowM v f = do + n <- V.getDim v + withFromVectorM (1,n) v f +{-# INLINE withFromRowM #-} + +-- | Perform an action with a view of a matrix column. +withCol :: (RMatrix m, Storable e) + => m e + -> Int + -> (forall v . RVector v => v e -> ST s a) + -> ST s a +withCol a j f = do + (m,n) <- getDim a + when (j < 0 || j >= n) $ error $ + printf ("withCol %d:" + ++ " index out of range") m n j + + unsafeWithCol a j f +{-# INLINE withCol #-} + +-- | Like 'withCol', but perform the action with a mutable view. +withColM :: (Storable e) + => STMatrix s e + -> Int + -> (STVector s e -> ST s a) + -> ST s a +withColM a j f = do + (m,n) <- getDim a + when (j < 0 || j >= n) $ error $ + printf ("withColM %d:" + ++ " index out of range") m n j + + unsafeWithColM a j f +{-# INLINE withColM #-} + +-- | Create a new matrix of given shape, but do not initialize the elements. +new_ :: (Storable e) => (Int,Int) -> ST s (STMatrix s e) +new_ (m,n) + | m < 0 || n < 0 = error $ + printf "new_ (%d,%d): invalid dimensions" m n + | otherwise = unsafeIOToST $ do + f <- mallocForeignPtrArray (m*n) + return $ STMatrix $ M.unsafeFromForeignPtr f 0 (m,n) (max 1 m) + +-- | Create a matrix with every element initialized to the same value. +new :: (Storable e) => (Int,Int) -> e -> ST s (STMatrix s e) +new (m,n) e = do + a <- new_ (m,n) + setElems a $ replicate (m*n) e + return a + +-- | Creates a new matrix by copying another one. +newCopy :: (RMatrix m, Storable e) => m e -> ST s (STMatrix s e) +newCopy a = do + mn <- getDim a + b <- new_ mn + unsafeCopyTo b a + return b + +-- | @copyTo dst src@ replaces the values in @dst@ with those in +-- source. The operands must be the same shape. +copyTo :: (RMatrix m, Storable e) => STMatrix s e -> m e -> ST s () +copyTo = checkOp2 "copyTo" unsafeCopyTo +{-# INLINE copyTo #-} + +-- | Same as 'copyTo' but does not range-check indices. +unsafeCopyTo :: (RMatrix m, Storable e) => STMatrix s e -> m e -> ST s () +unsafeCopyTo = vectorOp2 V.unsafeCopyTo +{-# INLINE unsafeCopyTo #-} + +-- | Get the indices of the elements in the matrix, in column-major order. +getIndices :: (RMatrix m, Storable e) => m e -> ST s [(Int,Int)] +getIndices a = do + (m,n) <- getDim a + return $ [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ] + +-- | Lazily get the elements of the matrix, in column-major order. +getElems :: (RMatrix m, Storable e) => m e -> ST s [e] +getElems a = case maybeWithVector a V.getElems of + Just es -> es + Nothing -> withCols a $ \xs -> + concat `fmap` mapM V.getElems xs + +-- | Get the elements of the matrix, in column-major order. +getElems' :: (RMatrix m, Storable e) => m e -> ST s [e] +getElems' a = case maybeWithVector a V.getElems' of + Just es -> es + Nothing -> withCols a $ \xs -> + concat `fmap` mapM V.getElems' xs + +-- | Lazily get the association list of the matrix, in column-major order. +getAssocs :: (RMatrix m, Storable e) => m e -> ST s [((Int,Int),e)] +getAssocs a = do + is <- getIndices a + es <- getElems a + return $ zip is es + +-- | Get the association list of the matrix, in column-major order. +getAssocs' :: (RMatrix m, Storable e) => m e -> ST s [((Int,Int),e)] +getAssocs' a = do + is <- getIndices a + es <- getElems' a + return $ zip is es + +-- | Set all of the values of the matrix from the elements in the list, +-- in column-major order. +setElems :: (Storable e) => STMatrix s e -> [e] -> ST s () +setElems a es = + case maybeWithVectorM a (`V.setElems` es) of + Just st -> st + Nothing -> do + (m,n) <- getDim a + go m n 0 es + where + go _ n j [] | j == n = return () + go m n j [] | j < n = error $ + printf ("setElems " + ++ ": not enough elements)") m n (j*m) + go m n j es' = + let (es1', es2') = splitAt m es' + in do + withColM a j (`V.setElems` es1') + go m n (j+1) es2' + +-- | Set the given values in the matrix. If an index is repeated twice, +-- the value is implementation-defined. +setAssocs :: (Storable e) => STMatrix s e -> [((Int,Int),e)] -> ST s () +setAssocs a ies = + sequence_ [ write a i e | (i,e) <- ies ] + +-- | Same as 'setAssocs' but does not range-check indices. +unsafeSetAssocs :: (Storable e) => STMatrix s e -> [((Int,Int),e)] -> ST s () +unsafeSetAssocs a ies = + sequence_ [ unsafeWrite a i e | (i,e) <- ies ] + +-- | Set the specified row of the matrix to the given vector. +setRow :: (RVector v, Storable e) + => STMatrix s e -> Int -> v e -> ST s () +setRow a i x = do + (m,n) <- getDim a + nx <- V.getDim x + + when (i < 0 || i >= m) $ error $ + printf ("setRow %d:" + ++ " index out of range") m n i + when (nx /= n) $ error $ + printf ("setRow _" + ++ " :" + ++ " dimension mismatch") m n nx + + unsafeSetRow a i x +{-# INLINE setRow #-} + +-- | Same as 'setRow' but does not range-check index or check +-- vector dimension. +unsafeSetRow :: (RVector v, Storable e) + => STMatrix s e -> Int -> v e -> ST s () +unsafeSetRow a i x = do + jes <- V.getAssocs x + sequence_ [ unsafeWrite a (i,j) e | (j,e) <- jes ] +{-# INLINE unsafeSetRow #-} + +-- | Exchange corresponding elements in the given rows. +swapRows :: (BLAS1 e) + => STMatrix s e -> Int -> Int -> ST s () +swapRows a i1 i2 = do + (m,n) <- getDim a + when (i1 < 0 || i1 >= m || i2 < 0 || i2 >= m) $ error $ + printf ("swapRows %d %d" + ++ ": index out of range") m n i1 i2 + unsafeSwapRows a i1 i2 + +-- | Same as 'swapRows' but does not range-check indices. +unsafeSwapRows :: (BLAS1 e) + => STMatrix s e -> Int -> Int -> ST s () +unsafeSwapRows a i1 i2 = when (i1 /= i2) $ do + (_,n) <- getDim a + unsafeIOToST $ + unsafeWith a $ \pa lda -> + let px = pa `advancePtr` i1 + py = pa `advancePtr` i2 + incx = lda + incy = lda + in + BLAS.swap n px incx py incy + +-- | Exchange corresponding elements in the given columns. +swapCols :: (BLAS1 e) + => STMatrix s e -> Int -> Int -> ST s () +swapCols a j1 j2 = do + (m,n) <- getDim a + when (j1 < 0 || j1 >= n || j2 < 0 || j2 >= n) $ error $ + printf ("swapCols %d %d" + ++ ": index out of range") m n j1 j2 + unsafeSwapCols a j1 j2 + +-- | Same as 'swapCols' but does not range-check indices. +unsafeSwapCols :: (BLAS1 e) + => STMatrix s e -> Int -> Int -> ST s () +unsafeSwapCols a j1 j2 = when (j1 /= j2) $ do + (m,_) <- getDim a + unsafeIOToST $ + unsafeWith a $ \pa lda -> + let px = pa `advancePtr` (j1*lda) + py = pa `advancePtr` (j2*lda) + incx = 1 + incy = 1 + in + BLAS.swap m px incx py incy + +-- | Copy the specified row of the matrix to the vector. +rowTo :: (RMatrix m, Storable e) + => STVector s e -> m e -> Int -> ST s () +rowTo x a i = do + (m,n) <- getDim a + nx <- V.getDim x + when (i < 0 || i >= m) $ error $ + printf ("rowTo" + ++ " _" + ++ " " + ++ " %d:" + ++ ": index out of range" + ) m n i + when (nx /= n) $ error $ + printf ("rowTo" + ++ " " + ++ " " + ++ " _" + ++ ": dimension mismatch") nx m n + + unsafeRowTo x a i +{-# INLINE rowTo #-} + +-- | Same as 'rowTo' but does not range-check index or check dimension. +unsafeRowTo :: (RMatrix m, Storable e) + => STVector s e -> m e -> Int ->ST s () +unsafeRowTo x a i = do + (_,n) <- getDim a + forM_ [ 0..n-1 ] $ \j -> do + e <- unsafeRead a (i,j) + V.unsafeWrite x j e +{-# INLINE unsafeRowTo #-} + +-- | Set the diagonal of the matrix to the given vector. +setDiag :: (RVector v, Storable e) + => STMatrix s e -> v e -> ST s () +setDiag a x = do + (m,n) <- getDim a + nx <- V.getDim x + let mn = min m n + + when (nx /= mn) $ error $ + printf ("setRow " + ++ " :" + ++ " dimension mismatch") m n nx + + unsafeSetDiag a x +{-# INLINE setDiag #-} + +-- | Same as 'setDiag' but does not range-check index or check dimension. +unsafeSetDiag :: (RVector v, Storable e) + => STMatrix s e -> v e -> ST s () +unsafeSetDiag a x = do + ies <- V.getAssocs x + sequence_ [ unsafeWrite a (i,i) e | (i,e) <- ies ] +{-# INLINE unsafeSetDiag #-} + +-- | Copy the diagonal of the matrix to the vector. +diagTo :: (RMatrix m, Storable e) + => STVector s e -> m e -> ST s () +diagTo x a = do + nx <- V.getDim x + (m,n) <- getDim a + let mn = min m n + + when (nx /= mn) $ error $ + printf ("diagTo" + ++ " " + ++ " " + ++ ": dimension mismatch") nx m n + + unsafeDiagTo x a +{-# INLINE diagTo #-} + +-- | Same as 'diagTo' but does not range-check index or check dimensions. +unsafeDiagTo :: (RMatrix m, Storable e) + => STVector s e -> m e -> ST s () +unsafeDiagTo x a = do + (m,n) <- getDim a + let mn = min m n + forM_ [ 0..mn-1 ] $ \i -> do + e <- unsafeRead a (i,i) + V.unsafeWrite x i e +{-# INLINE unsafeDiagTo #-} + +-- | Get the element stored at the given index. +read :: (RMatrix m, Storable e) => m e -> (Int,Int) -> ST s e +read a (i,j) = do + (m,n) <- getDim a + when (i < 0 || i >= m || j < 0 || j >= n) $ error $ + printf ("read (%d,%d):" + ++ " index out of range") m n i j + unsafeRead a (i,j) +{-# INLINE read #-} + +-- | Same as 'read' but does not range-check index. +unsafeRead :: (RMatrix m, Storable e) => m e -> (Int,Int) -> ST s e +unsafeRead a (i,j) = unsafeIOToST $ + unsafeWith a $ \p lda -> + peekElemOff p (i + j * lda) +{-# INLINE unsafeRead #-} + +-- | Set the element stored at the given index. +write :: (Storable e) + => STMatrix s e -> (Int,Int) -> e -> ST s () +write a (i,j) e = do + (m,n) <- getDim a + when (i < 0 || i >= m || j < 0 || j >= n) $ error $ + printf ("write (%d,%d):" + ++ " index out of range") m n i j + unsafeWrite a (i,j) e + +{-# INLINE write #-} + +-- | Same as 'write' but does not range-check index. +unsafeWrite :: (Storable e) + => STMatrix s e -> (Int,Int) -> e -> ST s () +unsafeWrite a (i,j) e = unsafeIOToST $ + unsafeWith a $ \p lda -> + pokeElemOff p (i + j * lda) e +{-# INLINE unsafeWrite #-} + +-- | Modify the element stored at the given index. +modify :: (Storable e) + => STMatrix s e -> (Int,Int) -> (e -> e) -> ST s () +modify a (i,j) f = do + (m,n) <- getDim a + when (i < 0 || i >= m || j < 0 || j >= n) $ error $ + printf ("modify (%d,%d):" + ++ " index out of range") m n i j + unsafeModify a (i,j) f +{-# INLINE modify #-} + +-- | Same as 'modify' but does not range-check index. +unsafeModify :: (Storable e) + => STMatrix s e -> (Int,Int) -> (e -> e) -> ST s () +unsafeModify a (i,j) f = unsafeIOToST $ + unsafeWith a $ \p lda -> + let o = i + j * lda + in do + e <- peekElemOff p o + pokeElemOff p o $ f e +{-# INLINE unsafeModify #-} + +-- | @mapTo dst f src@ replaces @dst@ elementwise with @f(src)@. +mapTo :: (RMatrix m, Storable e, Storable f) + => STMatrix s f + -> (e -> f) + -> m e + -> ST s () +mapTo dst f src = (checkOp2 "mapTo _" $ \z x -> unsafeMapTo z f x) dst src +{-# INLINE mapTo #-} + +-- | Same as 'mapTo' but does not check dimensions. +unsafeMapTo :: (RMatrix m, Storable e, Storable f) + => STMatrix s f + -> (e -> f) + -> m e + -> ST s () +unsafeMapTo dst f src = + fromMaybe colwise $ maybeWithVectorM dst $ \vdst -> + fromMaybe colwise $ maybeWithVector src $ \vsrc -> + V.unsafeMapTo vdst f vsrc + where + colwise = withColsM dst $ \zs -> + withCols src $ \xs -> + sequence_ [ V.unsafeMapTo z f x + | (z,x) <- zip zs xs + ] + +-- | @zipWithTo dst f x y@ replaces @dst@ elementwise with @f(x, y)@. +zipWithTo :: (RMatrix m1, RMatrix m2, Storable e1, Storable e2, Storable f) + => STMatrix s f + -> (e1 -> e2 -> f) + -> m1 e1 + -> m2 e2 + -> ST s () +zipWithTo dst f x y = + (checkOp3 "zipWithTo _" $ \dst1 x1 y1 -> unsafeZipWithTo dst1 f x1 y1) + dst x y +{-# INLINE zipWithTo #-} + +-- | Same as 'zipWithTo' but does not check dimensions. +unsafeZipWithTo :: (RMatrix m1, RMatrix m2, Storable e1, Storable e2, Storable f) + => STMatrix s f + -> (e1 -> e2 -> f) + -> m1 e1 + -> m2 e2 + -> ST s () +unsafeZipWithTo dst f x y = + fromMaybe colwise $ maybeWithVectorM dst $ \vdst -> + fromMaybe colwise $ maybeWithVector x $ \vx -> + fromMaybe colwise $ maybeWithVector y $ \vy -> + V.unsafeZipWithTo vdst f vx vy + where + colwise = withColsM dst $ \vdsts -> + withCols x $ \vxs -> + withCols y $ \vys -> + + sequence_ [ V.unsafeZipWithTo vdst f vx vy + | (vdst,vx,vy) <- zip3 vdsts vxs vys + ] + +-- | Set every element in the matrix to a default value. For +-- standard numeric types (including 'Double', 'Complex Double', and 'Int'), +-- the default value is '0'. +clear :: (Storable e) => STMatrix s e -> ST s () +clear a = fromMaybe colwise $ maybeWithVectorM a V.clear + where + colwise = withColsM a $ mapM_ V.clear + +-- | @withSlice (i,j) (m,n) a@ performs an action with a view of the +-- submatrix of @a@ starting at index @(i,j)@ and having dimension @(m,n)@. +withSlice :: (RMatrix m, Storable e) + => (Int,Int) + -> (Int,Int) + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a +withSlice ij mn a f = do + ia <- unsafeFreeze a + f $ slice ij mn ia + +-- | Like 'withSlice', but perform the action with a mutable view. +withSliceM :: (Storable e) + => (Int,Int) + -> (Int,Int) + -> STMatrix s e + -> (STMatrix s e -> ST s a) + -> ST s a +withSliceM ij mn a f = + withSlice ij mn a $ \a' -> do + ma <- unsafeThaw a' + f ma + +-- | Perform an action with a view gotten from taking the given number of +-- rows from the start of the matrix. +withTakeRows :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a +withTakeRows i a f = do + ia <- unsafeFreeze a + f $ takeRows i ia + +-- | Like 'withTakeRows', but perform the action with a mutable view. +withTakeRowsM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> ST s a) + -> ST s a +withTakeRowsM i a f = + withTakeRows i a $ \a' -> do + ma <- unsafeThaw a' + f ma + +-- | Perform an action with a view gotten from dropping the given number of +-- rows from the start of the matrix. +withDropRows :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a +withDropRows n a f = do + ia <- unsafeFreeze a + f $ dropRows n ia + +-- | Like 'withDropRows', but perform the action with a mutable view. +withDropRowsM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> ST s a) + -> ST s a +withDropRowsM i a f = + withDropRows i a $ \a' -> do + ma <- unsafeThaw a' + f ma + +-- | Perform an action with views from splitting the matrix rows at the given +-- index. +withSplitRowsAt :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m1 m2. (RMatrix m1, RMatrix m2) => m1 e -> m2 e -> ST s a) + -> ST s a +withSplitRowsAt i a f = do + ia <- unsafeFreeze a + uncurry f $ splitRowsAt i ia + +-- | Like 'withSplitRowsAt', but perform the action with a mutable view. +withSplitRowsAtM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> STMatrix s e -> ST s a) + -> ST s a +withSplitRowsAtM i a f = + withSplitRowsAt i a $ \a1' a2' -> do + ma1 <- unsafeThaw a1' + ma2 <- unsafeThaw a2' + f ma1 ma2 + +-- | Perform an action with a view gotten from taking the given number of +-- columns from the start of the matrix. +withTakeCols :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a +withTakeCols i a f = do + ia <- unsafeFreeze a + f $ takeCols i ia + +-- | Like 'withTakeCols', but perform the action with a mutable view. +withTakeColsM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> ST s a) + -> ST s a +withTakeColsM i a f = + withTakeCols i a $ \a' -> do + ma <- unsafeThaw a' + f ma + +-- | Perform an action with a view gotten from dropping the given number of +-- columns from the start of the matrix. +withDropCols :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m'. RMatrix m' => m' e -> ST s a) + -> ST s a +withDropCols n a f = do + ia <- unsafeFreeze a + f $ dropCols n ia + +-- | Like 'withDropCols', but perform the action with a mutable view. +withDropColsM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> ST s a) + -> ST s a +withDropColsM i a f = + withDropCols i a $ \a' -> do + ma <- unsafeThaw a' + f ma + +-- | Perform an action with views from splitting the matrix columns at the given +-- index. +withSplitColsAt :: (RMatrix m, Storable e) + => Int + -> m e + -> (forall m1 m2. (RMatrix m1, RMatrix m2) => m1 e -> m2 e -> ST s a) + -> ST s a +withSplitColsAt i a f = do + ia <- unsafeFreeze a + uncurry f $ splitColsAt i ia + +-- | Like 'withSplitColsAt', but perform the action with mutable views. +withSplitColsAtM :: (Storable e) + => Int + -> STMatrix s e + -> (STMatrix s e -> STMatrix s e -> ST s a) + -> ST s a +withSplitColsAtM i a f = + withSplitColsAt i a $ \a1' a2' -> do + ma1 <- unsafeThaw a1' + ma2 <- unsafeThaw a2' + f ma1 ma2 + + +-- | Add a vector to the diagonal of a matrix. +shiftDiagM_ :: (RVector v, BLAS1 e) + => v e -> STMatrix s e -> ST s () +shiftDiagM_ s a = do + (m,n) <- getDim a + ns <- V.getDim s + let mn = min m n + + when (ns /= mn) $ error $ + printf ("shiftDiagM_" + ++ " " + ++ " " + ++ ": dimension mismatch") + ns + m n + + shiftDiagWithScaleM_ 1 s a + + +-- | Add a scaled vector to the diagonal of a matrix. +shiftDiagWithScaleM_ :: (RVector v, BLAS1 e) + => e -> v e -> STMatrix s e -> ST s () +shiftDiagWithScaleM_ e s a = do + (m,n) <- getDim a + ns <- V.getDim s + let mn = min m n + + when (ns /= mn) $ error $ + printf ("shiftDiagWithScaleM_" + ++ " _" + ++ " " + ++ " " + ++ ": dimension mismatch") + ns + m n + + unsafeIOToST $ + V.unsafeWith s $ \ps -> + unsafeWith a $ \pa lda -> + BLAS.axpy mn e ps 1 pa (lda+1) + + +-- | Add two matrices. +addTo :: (RMatrix m1, RMatrix m2, VNum e) + => STMatrix s e -> m1 e -> m2 e -> ST s () +addTo = checkOp3 "addTo" $ vectorOp3 V.addTo + +-- | Subtract two matrices. +subTo :: (RMatrix m1, RMatrix m2, VNum e) + => STMatrix s e -> m1 e -> m2 e -> ST s () +subTo = checkOp3 "subTo" $ vectorOp3 V.subTo + +-- | Conjugate the entries of a matrix. +conjugateTo :: (RMatrix m, VNum e) + => STMatrix s e -> m e -> ST s () +conjugateTo = checkOp2 "conjugateTo" $ + vectorOp2 V.conjugateTo + +-- | Negate the entries of a matrix. +negateTo :: (RMatrix m, VNum e) + => STMatrix s e -> m e -> ST s () +negateTo = checkOp2 "negateTo" $ + vectorOp2 V.negateTo + +-- | Scale the entries of a matrix by the given value. +scaleM_ :: (BLAS1 e) + => e -> STMatrix s e -> ST s () +scaleM_ e = vectorOp (V.scaleM_ e) + +-- | @addWithScaleM_ alpha x y@ sets @y := alpha * x + y@. +addWithScaleM_ :: (RMatrix m, BLAS1 e) + => e -> m e -> STMatrix s e -> ST s () +addWithScaleM_ e = checkOp2 "addWithScaleM_" $ + unsafeAddWithScaleM_ e + +unsafeAddWithScaleM_ :: (RMatrix m, BLAS1 e) + => e -> m e -> STMatrix s e -> ST s () +unsafeAddWithScaleM_ alpha x y = + fromMaybe colwise $ maybeWithVector x $ \vx -> + fromMaybe colwise $ maybeWithVectorM y $ \vy -> + V.unsafeAddWithScaleM_ alpha vx vy + where + colwise = withCols x $ \vxs -> + withColsM y $ \vys -> + sequence_ [ V.unsafeAddWithScaleM_ alpha vx vy + | (vx,vy) <- zip vxs vys ] + +-- | Scale the rows of a matrix; @scaleRowsM_ s a@ sets +-- @a := diag(s) * a@. +scaleRowsM_ :: (RVector v, BLAS1 e) + => v e -> STMatrix s e -> ST s () +scaleRowsM_ s a = do + (m,n) <- getDim a + ns <- V.getDim s + when (ns /= m) $ error $ + printf ("scaleRowsM_" + ++ " " + ++ " " + ++ ": dimension mismatch") + ns + m n + + unsafeIOToST $ + V.unsafeWith s $ \ps -> + unsafeWith a $ \pa lda -> + go m n lda pa ps 0 + where + go m n lda pa ps i | i == m = return () + | otherwise = do + e <- peek ps + BLAS.scal n e pa lda + go m n lda (pa `advancePtr` 1) + (ps `advancePtr` 1) + (i+1) + +-- | Scale the columns of a matrix; @scaleColBysM_ s a@ sets +-- @a := a * diag(s)@. +scaleColsM_ :: (RVector v, BLAS1 e) + => v e -> STMatrix s e -> ST s () +scaleColsM_ s a = do + (m,n) <- getDim a + ns <- V.getDim s + when (ns /= n) $ error $ + printf ("scaleColsM_" + ++ " " + ++ " " + ++ ": dimension mismatch") + ns + m n + + es <- V.getElems s + withColsM a $ \xs -> + sequence_ [ V.scaleM_ e x + | (e,x) <- zip es xs + ] + + +-- | @rank1UpdateM_ alpha x y a@ sets @a := alpha * x * y^H + a@. +rank1UpdateM_ :: (RVector v1, RVector v2, BLAS2 e) + => e -> v1 e -> v2 e -> STMatrix s e -> ST s () +rank1UpdateM_ alpha x y a = do + (m,n) <- getDim a + nx <- V.getDim x + ny <- V.getDim y + + when (nx /= m || ny /= n) $ error $ + printf ("rank1UpdateTo" + ++ " _" + ++ " " + ++ " " + ++ ": dimension mismatch" + ++ "" ) + nx + ny + m n + + unsafeIOToST $ + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + unsafeWith a $ \pa lda -> + BLAS.gerc m n alpha px 1 py 1 pa lda + + +-- | @transTo dst a@ sets @dst := trans(a)@. +transTo :: (RMatrix m, BLAS1 e) + => STMatrix s e + -> m e + -> ST s () +transTo a' a = do + (ma,na) <- getDim a + (ma',na') <- getDim a' + let (m,n) = (ma,na) + + when ((ma,na) /= (na',ma')) $ error $ + printf ( "transTo" + ++ " " + ++ " " + ++ ": dimension mismatch" + ) + ma' na' + ma na + + unsafeIOToST $ + unsafeWith a' $ \pa' lda' -> + unsafeWith a $ \pa lda -> let + go j px py | j == n = return () + | otherwise = do + BLAS.copy m px 1 py lda' + go (j+1) (px `advancePtr` lda) (py `advancePtr` 1) + in go 0 pa pa' + + +-- | @conjTransTo dst a@ sets @dst := conjugate(trans(a))@. +conjTransTo :: (RMatrix m, BLAS1 e) + => STMatrix s e + -> m e + -> ST s () +conjTransTo a' a = do + transTo a' a + conjugateTo a' a' + +-- | @mulVectorTo dst transa a x@ +-- sets @dst := op(a) * x@, where @op(a)@ is determined by @transa@. +mulVectorTo :: (RMatrix m, RVector v, BLAS2 e) + => STVector s e + -> Trans -> m e + -> v e + -> ST s () +mulVectorTo dst = mulVectorWithScaleTo dst 1 + +-- | @mulVectorWithScaleTo dst alpha transa a x@ +-- sets @dst := alpha * op(a) * x@, where @op(a)@ is determined by @transa@. +mulVectorWithScaleTo :: (RMatrix m, RVector v, BLAS2 e) + => STVector s e + -> e + -> Trans -> m e + -> v e + -> ST s () +mulVectorWithScaleTo dst alpha t a x = + addMulVectorWithScalesM_ alpha t a x 0 dst + +-- | @addMulVectorWithScalesM_ alpha transa a x beta y@ +-- sets @y := alpha * op(a) * x + beta * y@, where @op(a)@ is +-- determined by @transa@. +addMulVectorWithScalesM_ :: (RMatrix m, RVector v, BLAS2 e) + => e + -> Trans -> m e + -> v e + -> e + -> STVector s e + -> ST s () +addMulVectorWithScalesM_ alpha transa a x beta y = do + (ma,na) <- getDim a + nx <- V.getDim x + ny <- V.getDim y + let (m,n) = (ny,nx) + + when ((not . and) [ case transa of NoTrans -> (ma,na) == (m,n) + _ -> (ma,na) == (n,m) + , nx == n + , ny == m + ]) $ error $ + printf ("addMulVectorWithScalesTo" + ++ " _" + ++ " %s" + ++ " " + ++ " " + ++ " _" + ++ " " + ++ ": dimension mismatch") + (show transa) + ma na + nx + ny + + unsafeIOToST $ + unsafeWith a $ \pa lda -> + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + if n == 0 + then BLAS.scal m beta py 1 + else BLAS.gemv transa ma na alpha pa lda px 1 beta py 1 + +-- | @mulMatrixTo dst transa a transb b@ +-- sets @dst := op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined +-- by @transa@ and @transb@. +mulMatrixTo :: (RMatrix m1, RMatrix m2, BLAS3 e) + => STMatrix s e + -> Trans -> m1 e + -> Trans -> m2 e + -> ST s () +mulMatrixTo dst = mulMatrixWithScaleTo dst 1 + +-- | @mulMatrixWithScaleTo alpha transa a transb b c@ +-- sets @c := alpha * op(a) * op(b)@, where @op(a)@ and @op(b)@ are determined +-- by @transa@ and @transb@. +mulMatrixWithScaleTo :: (RMatrix m1, RMatrix m2, BLAS3 e) + => STMatrix s e + -> e + -> Trans -> m1 e + -> Trans -> m2 e + -> ST s () +mulMatrixWithScaleTo dst alpha ta a tb b = + addMulMatrixWithScalesM_ alpha ta a tb b 0 dst + +-- | @addMulMatrixWithScalesM_ alpha transa a transb b beta c@ +-- sets @c := alpha * op(a) * op(b) + beta * c@, where @op(a)@ and +-- @op(b)@ are determined by @transa@ and @transb@. +addMulMatrixWithScalesM_ :: (RMatrix m1, RMatrix m2, BLAS3 e) + => e + -> Trans -> m1 e + -> Trans -> m2 e + -> e + -> STMatrix s e + -> ST s () +addMulMatrixWithScalesM_ alpha transa a transb b beta c = do + (ma,na) <- getDim a + (mb,nb) <- getDim b + (mc,nc) <- getDim c + let (m,n) = (mc,nc) + k = case transa of NoTrans -> na + _ -> ma + + when ((not . and) [ case transa of NoTrans -> (ma,na) == (m,k) + _ -> (ma,na) == (k,m) + , case transb of NoTrans -> (mb,nb) == (k,n) + _ -> (mb,nb) == (n,k) + , (mc, nc) == (m,n) + ]) $ error $ + printf ("addMulMatrixWithScalesM_" + ++ " _" + ++ " %s " + ++ " %s " + ++ " _" + ++ " " + ++ ": dimension mismatch") + (show transa) ma na + (show transb) mb nb + mc nc + + unsafeIOToST $ + unsafeWith a $ \pa lda -> + unsafeWith b $ \pb ldb -> + unsafeWith c $ \pc ldc -> + BLAS.gemm transa transb m n k alpha pa lda pb ldb beta pc ldc + +checkOp2 :: (RMatrix x, RMatrix y, Storable e, Storable f) + => String + -> (x e -> y f -> ST s a) + -> x e + -> y f + -> ST s a +checkOp2 str f x y = do + (m1,n1) <- getDim x + (m2,n2) <- getDim y + when ((m1,n1) /= (m2,n2)) $ error $ + printf ("%s :" + ++ " dimension mismatch") str m1 n1 m2 n2 + f x y +{-# INLINE checkOp2 #-} + +checkOp3 :: (RMatrix x, RMatrix y, RMatrix z, Storable e, Storable f, Storable g) + => String + -> (x e -> y f -> z g -> ST s a) + -> x e + -> y f + -> z g + -> ST s a +checkOp3 str f x y z = do + (m1,n1) <- getDim x + (m2,n2) <- getDim y + (m3,n3) <- getDim z + when((m1,n1) /= (m2,n2) || (m1,n1) /= (m3,n3)) $ error $ + printf ("%s :" + ++ " dimension mismatch") + str m1 n1 m2 n2 m3 n3 + f x y z +{-# INLINE checkOp3 #-} + +vectorOp :: (Storable e) + => (STVector s e -> ST s ()) + -> STMatrix s e -> ST s () +vectorOp f x = + fromMaybe colwise $ maybeWithVectorM x $ \vx -> f vx + where + colwise = withColsM x $ \vxs -> + sequence_ [ f vx | vx <- vxs ] + +vectorOp2 :: (RMatrix m, Storable e, Storable f) + => (forall v . RVector v => STVector s f -> v e -> ST s ()) + -> STMatrix s f -> m e -> ST s () +vectorOp2 f dst x = + fromMaybe colwise $ maybeWithVectorM dst $ \vdst -> + fromMaybe colwise $ maybeWithVector x $ \vx -> + f vdst vx + where + colwise = withColsM dst $ \vdsts -> + withCols x $ \vxs -> + sequence_ [ f vdst vx | (vdst,vx) <- zip vdsts vxs ] +{-# INLINE vectorOp2 #-} + +vectorOp3 :: (RMatrix m1, RMatrix m2, Storable e1, Storable e2, Storable f) + => (forall v1 v2 . (RVector v1, RVector v2) => + STVector s f -> v1 e1 -> v2 e2 -> ST s ()) + -> STMatrix s f -> m1 e1 -> m2 e2 -> ST s () +vectorOp3 f dst x y = + fromMaybe colwise $ maybeWithVectorM dst $ \vdst -> + fromMaybe colwise $ maybeWithVector x $ \vx -> + fromMaybe colwise $ maybeWithVector y $ \vy -> + f vdst vx vy + where + colwise = withColsM dst $ \vdsts -> + withCols x $ \vxs -> + withCols y $ \vys -> + sequence_ [ f vdst vx vy + | (vdst,vx,vy) <- zip3 vdsts vxs vys ] +{-# INLINE vectorOp3 #-} diff --git a/lib/Numeric/LinearAlgebra/Matrix/Statistics.hs b/lib/Numeric/LinearAlgebra/Matrix/Statistics.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Statistics.hs @@ -0,0 +1,180 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Statistics +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Basic multivariate statistics. +-- + +module Numeric.LinearAlgebra.Matrix.Statistics ( + defaultCovUplo, + + -- * Immutable interface + cov, + covWithMean, + weightedCov, + weightedCovWithMean, + + -- * Mutable interface + covTo, + covWithMeanTo, + weightedCovTo, + weightedCovWithMeanTo, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST ) +import Data.List( foldl' ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Types + +import Numeric.LinearAlgebra.Vector( Vector, RVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +import Numeric.LinearAlgebra.Matrix.Base( Matrix ) +import Numeric.LinearAlgebra.Matrix.STBase( STMatrix ) +import qualified Numeric.LinearAlgebra.Matrix.STBase as M +import qualified Numeric.LinearAlgebra.Matrix.Herm as M + + +-- | Returns the default storage scheme for covariance matrices. +defaultCovUplo :: Uplo +defaultCovUplo = Lower + + +-- | Returns the sample covariance matrix as a hermitian matrix with storage +-- scheme equal to 'defaultCovUplo'. The first argument gives the dimension +-- of the vectors. +cov :: (BLAS3 e) + => Int -> CovMethod -> [Vector e] -> Herm Matrix e +cov p t xs = M.hermCreate $ do + c <- Herm uplo `fmap` M.new_ (p,p) + covTo c t xs + return c + where + uplo = defaultCovUplo + +-- | Given the pre-computed mean, returns the sample covariance matrix +-- with storage scheme equal to 'defaultCovUplo'. +covWithMean :: (BLAS3 e) + => Vector e -> CovMethod -> [Vector e] -> Herm Matrix e +covWithMean mu t xs = M.hermCreate $ do + p <- V.getDim mu + c <- Herm uplo `fmap` M.new_ (p,p) + covWithMeanTo c mu t xs + return c + where + uplo = defaultCovUplo + +-- | Returns the weighed sample covariance matrix with storage scheme equal +-- to 'defaultCovUplo'. The first argument gives the dimension of the vectors. +weightedCov :: (BLAS3 e) + => Int -> CovMethod -> [(Double, Vector e)] -> Herm Matrix e +weightedCov p t wxs = M.hermCreate $ do + c <- Herm uplo `fmap` M.new_ (p,p) + weightedCovTo c t wxs + return c + where + uplo = defaultCovUplo + +-- | Given the pre-computed mean, returns the weighed sample covariance matrix +-- with storage scheme equal to 'defaultCovUplo'. +weightedCovWithMean :: (BLAS3 e) + => Vector e -> CovMethod -> [(Double, Vector e)] + -> Herm Matrix e +weightedCovWithMean mu t wxs = M.hermCreate $ do + p <- V.getDim mu + c <- Herm uplo `fmap` M.new_ (p,p) + weightedCovWithMeanTo c mu t wxs + return c + where + uplo = defaultCovUplo + +-- | Computes and copies the sample covariance matrix to the given +-- destination. +covTo :: (RVector v, BLAS3 e) + => Herm (STMatrix s) e -> CovMethod -> [v e] -> ST s () +covTo c@(Herm _ a) t xs = do + (p,_) <- M.getDim a + mu <- V.new p 1 + V.meanTo mu xs + covWithMeanTo c mu t xs + + +-- | Given the pre-computed mean, computes and copies the sample covariance +-- matrix to the given destination. +covWithMeanTo :: (RVector v1, RVector v2, BLAS3 e) + => Herm (STMatrix s) e -> v1 e -> CovMethod -> [v2 e] -> ST s () +covWithMeanTo c@(Herm _ a) mu t xs = do + (ma,na) <- M.getDim a + p <- V.getDim mu + + when ((ma,na) /= (p,p)) $ error $ + printf ("covWithMeanTo" + ++ " (Herm _ )" + ++ " " + ++ " _ _" + ++ ": dimension mismatch") + ma na p + + xt <- M.new_ (p,n) + M.withColsM xt $ \xs' -> + sequence_ [ V.subTo x' mu x + | (x,x') <- zip xs xs' + ] + M.hermRankKUpdateM_ (1/df) NoTrans xt 0 c + where + + n = length xs + df = fromIntegral $ case t of { MLCov -> n ; UnbiasedCov -> n - 1 } + +-- | Computes and copies the weighed sample covariance matrix to the +-- given destination. +weightedCovTo :: (RVector v, BLAS3 e) + => Herm (STMatrix s) e -> CovMethod -> [(Double, v e)] -> ST s () +weightedCovTo c@(Herm _ a) t wxs = do + (p,_) <- M.getDim a + mu <- V.new p 1 + V.weightedMeanTo mu wxs + weightedCovWithMeanTo c mu t wxs + + +-- | Given the pre-computed mean, computes and copies the weighed sample +-- covariance matrix to the given destination. +weightedCovWithMeanTo :: (RVector v1, RVector v2, BLAS3 e) + => Herm (STMatrix s) e + -> v1 e -> CovMethod -> [(Double, v2 e)] + -> ST s () +weightedCovWithMeanTo c@(Herm _ a) mu t wxs = do + (ma,na) <- M.getDim a + p <- V.getDim mu + + when ((ma,na) /= (p,p)) $ error $ + printf ("weightedCovWithMeanTo" + ++ " (Herm _ ):" + ++ " " + ++ " _ _" + ++ " dimension mismatch") + ma na p + + xt <- M.new_ (p,n) + M.withColsM xt $ \xs' -> + sequence_ [ V.subTo x' mu x + >> V.scaleM_ (realToFrac $ sqrt (w / invscale)) x' + | (w,x,x') <- zip3 ws xs xs' + ] + M.hermRankKUpdateM_ 1 NoTrans xt 0 c + where + (ws0,xs) = unzip wxs + w_sum = foldl' (+) 0 ws0 + ws = if w_sum == 0 then ws0 else map (/w_sum) ws0 + w2s_sum = foldl' (+) 0 $ map (^^(2::Int)) ws + invscale = case t of + MLCov -> 1 + UnbiasedCov -> (1 - w2s_sum) + n = length ws0 diff --git a/lib/Numeric/LinearAlgebra/Matrix/Tri.hs b/lib/Numeric/LinearAlgebra/Matrix/Tri.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Matrix/Tri.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Matrix.Tri +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Triangular views of matrices. +-- + +module Numeric.LinearAlgebra.Matrix.Tri ( + -- * Immutable interface + + -- ** Vector multiplication + triMulVector, + + -- ** Matrix multiplication + triMulMatrix, + triMulMatrixWithScale, + + -- ** Vector solving + triSolvVector, + + -- ** Matrix solving + triSolvMatrix, + triSolvMatrixWithScale, + + -- * Mutable interface + triCreate, + + -- ** Vector multiplication + triMulVectorM_, + + -- ** Matrix multiplication + triMulMatrixM_, + triMulMatrixWithScaleM_, + + -- ** Vector solving + triSolvVectorM_, + + -- ** Matrix solving + triSolvMatrixM_, + triSolvMatrixWithScaleM_, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V +import Numeric.LinearAlgebra.Matrix.Base( Matrix ) +import Numeric.LinearAlgebra.Matrix.STBase( STMatrix, RMatrix ) +import qualified Numeric.LinearAlgebra.Matrix.STBase as M +import Numeric.LinearAlgebra.Types +import qualified Foreign.BLAS as BLAS + + +-- | A safe way to create and work with a mutable Tri Matrix before returning +-- an immutable one for later perusal. +triCreate :: (Storable e) + => (forall s. ST s (Tri (STMatrix s) e)) + -> Tri Matrix e +triCreate mt = runST $ do + (Tri u d ma) <- mt + a <- M.unsafeFreeze ma + return $ Tri u d a + +-- | @triMulVector trans a x@ returns @op(a) * x@, where @op(a)@ is +-- determined by @trans@. +triMulVector :: (BLAS2 e) + => Trans + -> Tri Matrix e + -> Vector e + -> Vector e +triMulVector trans a x = + V.create $ do + x' <- V.newCopy x + triMulVectorM_ trans a x' + return x' + +-- | @triMulMatrix side a b@ +-- returns @alpha * op(a) * b@ when @side@ is @LeftSide@ and +-- @alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triMulMatrix :: (BLAS3 e) + => Side + -> Trans -> Tri Matrix e + -> Matrix e + -> Matrix e +triMulMatrix side trans a b = + M.create $ do + b' <- M.newCopy b + triMulMatrixM_ side trans a b' + return b' + +-- | @triMulMatrixWithScale alpha side trans a b@ +-- returns @alpha * op(a) * b@ when @side@ is @LeftSide@ and +-- @alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triMulMatrixWithScale :: (BLAS3 e) + => e + -> Side + -> Trans -> Tri Matrix e + -> Matrix e + -> Matrix e +triMulMatrixWithScale alpha side trans a b = + M.create $ do + b' <- M.newCopy b + triMulMatrixWithScaleM_ alpha side trans a b' + return b' + +-- | @triMulVectorM_ a x@ sets @x := op(a) * x@, where @op(a)@ is determined +-- by @trans@. +triMulVectorM_ :: (RMatrix m, BLAS2 e) + => Trans -> Tri m e + -> STVector s e + -> ST s () +triMulVectorM_ trans (Tri uplo diag a) x = do + (ma,na) <- M.getDim a + nx <- V.getDim x + let n = nx + + when (ma /= na) $ error $ + printf ("triMulVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " _" + ++ ": matrix is not square") + ma na + + when ((not . and) [ (ma,na) == (n,n) + , nx == n + ]) $ error $ + printf ("triMulVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + ma na + nx + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + V.unsafeWith x $ \px -> + BLAS.trmv uplo trans diag n pa lda px 1 + + +-- | @triMulMatrixM_ side trans a b@ +-- sets @b := op(a) * b@ when @side@ is @LeftSide@ and +-- @b := b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triMulMatrixM_ :: (RMatrix m, BLAS3 e) + => Side + -> Trans -> Tri m e + -> STMatrix s e + -> ST s () +triMulMatrixM_ = triMulMatrixWithScaleM_ 1 + +-- | @triMulMatrixWithScaleM_ alpha side trans a b@ +-- sets @b := alpha * op(a) * b@ when @side@ is @LeftSide@ and +-- @b := alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triMulMatrixWithScaleM_ :: (RMatrix m, BLAS3 e) + => e + -> Side + -> Trans -> Tri m e + -> STMatrix s e + -> ST s () +triMulMatrixWithScaleM_ alpha side trans (Tri uplo diag a) b = do + (ma,na) <- M.getDim a + (mb,nb) <- M.getDim b + let (m,n) = (mb,nb) + + when (ma /= na) $ error $ + printf ("triMulMatrixWithScaleM_" + ++ " _" + ++ " _" + ++ " _" + ++ " (Tri _ _ )" + ++ " _" + ++ ": matrix is not square") + ma na + + when ((not . and) [ case side of LeftSide -> (ma,na) == (m,m) + RightSide -> (ma,na) == (n,n) + , (mb, nb ) == (m,n) + ]) $ error $ + printf ("triMulMatrixWithScaleM_" + ++ " _" + ++ " %s" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + (show side) + ma na + mb nb + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith b $ \pb ldb -> + BLAS.trmm side uplo trans diag m n alpha pa lda pb ldb + + +-- | @triSolvVector trans a x@ returns @op(a) \\ x@, where @op(a)@ is +-- determined by @trans@. +triSolvVector :: (BLAS2 e) + => Trans + -> Tri Matrix e + -> Vector e + -> Vector e +triSolvVector trans a x = + V.create $ do + x' <- V.newCopy x + triSolvVectorM_ trans a x' + return x' + +-- | @triSolvMatrix side a b@ +-- returns @alpha * op(a) \\ b@ when @side@ is @LeftSide@ and +-- @alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triSolvMatrix :: (BLAS3 e) + => Side + -> Trans -> Tri Matrix e + -> Matrix e + -> Matrix e +triSolvMatrix side trans a b = + M.create $ do + b' <- M.newCopy b + triSolvMatrixM_ side trans a b' + return b' + +-- | @triSolvMatrixWithScale alpha side trans a b@ +-- returns @alpha * op(a) \\ b@ when @side@ is @LeftSide@ and +-- @alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triSolvMatrixWithScale :: (BLAS3 e) + => e + -> Side + -> Trans -> Tri Matrix e + -> Matrix e + -> Matrix e +triSolvMatrixWithScale alpha side trans a b = + M.create $ do + b' <- M.newCopy b + triSolvMatrixWithScaleM_ alpha side trans a b' + return b' + +-- | @triSolvVectorM_ a x@ sets @x := op(a) \\ x@, where @op(a)@ is determined +-- by @trans@. +triSolvVectorM_ :: (RMatrix m, BLAS2 e) + => Trans -> Tri m e + -> STVector s e + -> ST s () +triSolvVectorM_ trans (Tri uplo diag a) x = do + (ma,na) <- M.getDim a + nx <- V.getDim x + let n = nx + + when (ma /= na) $ error $ + printf ("triSolvVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " _" + ++ ": matrix is not square") + ma na + + when ((not . and) [ (ma,na) == (n,n) + , nx == n + ]) $ error $ + printf ("triSolvVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + ma na + nx + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + V.unsafeWith x $ \px -> + BLAS.trsv uplo trans diag n pa lda px 1 + + +-- | @triSolvMatrixM_ side trans a b@ +-- sets @b := op(a) \\ b@ when @side@ is @LeftSide@ and +-- @b := b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triSolvMatrixM_ :: (RMatrix m, BLAS3 e) + => Side + -> Trans -> Tri m e + -> STMatrix s e + -> ST s () +triSolvMatrixM_ = triSolvMatrixWithScaleM_ 1 + +-- | @triSolvMatrixWithScaleM_ alpha side trans a b@ +-- sets @b := alpha * op(a) \\ b@ when @side@ is @LeftSide@ and +-- @b := alpha * b * op(a)@ when @side@ is @RightSide@. Operation +-- @op(a)@ is determined by @trans@. +triSolvMatrixWithScaleM_ :: (RMatrix m, BLAS3 e) + => e + -> Side + -> Trans -> Tri m e + -> STMatrix s e + -> ST s () +triSolvMatrixWithScaleM_ alpha side trans (Tri uplo diag a) b = do + (ma,na) <- M.getDim a + (mb,nb) <- M.getDim b + let (m,n) = (mb,nb) + + when (ma /= na) $ error $ + printf ("triSolvMatrixWithScaleM_" + ++ " _" + ++ " _" + ++ " _" + ++ " (Tri _ _ )" + ++ " _" + ++ ": matrix is not square") + ma na + + when ((not . and) [ case side of LeftSide -> (ma,na) == (m,m) + RightSide -> (ma,na) == (n,n) + , (mb, nb ) == (m,n) + ]) $ error $ + printf ("triSolvMatrixWithScaleM_" + ++ " _" + ++ " %s" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + (show side) + ma na + mb nb + + unsafeIOToST $ + M.unsafeWith a $ \pa lda -> + M.unsafeWith b $ \pb ldb -> + BLAS.trsm side uplo trans diag m n alpha pa lda pb ldb diff --git a/lib/Numeric/LinearAlgebra/Packed.hs b/lib/Numeric/LinearAlgebra/Packed.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Packed matrices. +-- +module Numeric.LinearAlgebra.Packed ( + -- * Immutable packed matrices + Packed, + dim, + + -- * Read-only packed matrices + RPacked(..), + + -- * Conversions between vectors and packed matrices + fromVector, + toVector, + + -- * Mutable interface + module Numeric.LinearAlgebra.Packed.ST, + + -- * Hermitian views + module Numeric.LinearAlgebra.Packed.Herm, + + -- * Triangular views + module Numeric.LinearAlgebra.Packed.Tri, + + -- * Cholesky factorizations + module Numeric.LinearAlgebra.Packed.Cholesky, + + -- * Basic multivariate statistics + module Numeric.LinearAlgebra.Packed.Statistics, + + ) where + +import Numeric.LinearAlgebra.Packed.Base +import Numeric.LinearAlgebra.Packed.ST hiding ( RPacked(..) ) +import Numeric.LinearAlgebra.Packed.Herm +import Numeric.LinearAlgebra.Packed.Tri +import Numeric.LinearAlgebra.Packed.Cholesky +import Numeric.LinearAlgebra.Packed.Statistics diff --git a/lib/Numeric/LinearAlgebra/Packed/Base.hs b/lib/Numeric/LinearAlgebra/Packed/Base.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/Base.hs @@ -0,0 +1,388 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.Base +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Packed matrices. +-- +module Numeric.LinearAlgebra.Packed.Base + where + +import Control.Monad( when ) +import Control.Monad.ST( ST, RealWorld, runST, unsafeIOToST ) +import Data.Typeable( Typeable ) +import Foreign( Storable, Ptr ) +import Text.Printf( printf ) +import Unsafe.Coerce( unsafeCoerce ) + +import Numeric.LinearAlgebra.Types( Herm(..) ) +import Numeric.LinearAlgebra.Vector( Vector, RVector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V +import Foreign.BLAS( BLAS2 ) +import qualified Foreign.BLAS as BLAS + + +-- | Immutable packed matrices, stored in column-major order. +data Packed e = Packed !Int !(Vector e) + deriving (Typeable) + +-- | Mutable packed matrices in the 'ST' monad. +newtype STPacked s e = STPacked { unSTPacked :: Packed e } + deriving (Typeable) + +-- | Mutable packed matrices in the 'IO' monad. +type IOPacked = STPacked RealWorld + +-- | The dimension of the packed matrix. +dim :: (Storable e) => Packed e -> Int +dim (Packed n _) = n +{-# INLINE dim #-} + +-- | Allocate a mutable packed matrix of the given dimension. +new_ :: (Storable e) => Int -> ST s (STPacked s e) +new_ n + | n < 0 = error $ + printf "new_ %d: negative dimension" n + | otherwise = do + mx <- V.new_ (n*(n+1) `div` 2) + x <- V.unsafeFreeze mx + return $ STPacked $ Packed n x +{-# INLINE new_ #-} + +-- | Create a packed matrix view of a vector, ensurint that the +-- vector has dimension @n * (n+1)/2@, where @n@ is the desired dimension. +fromVector :: (Storable e) => Int -> Vector e -> Packed e +fromVector n x + | not $ 2 * nx == n * (n+1) = error $ + printf ("fromVector %d : dimension mismatch") + n nx + | otherwise = + unsafeFromVector n x + where + nx = V.dim x +{-# INLINE fromVector #-} + +-- | Create a packed matrix view of a vector, wihtout checking +-- the dimension of the vector. +unsafeFromVector :: (Storable e) => Int -> Vector e -> Packed e +unsafeFromVector = Packed +{-# INLINE unsafeFromVector #-} + +-- | Returns the dimension and underlying vector storage of a +-- packed matrix. +toVector :: (Storable e) => Packed e -> (Int, Vector e) +toVector (Packed n v) = (n,v) +{-# INLINE toVector #-} + +{- +-- | Create a packed matrix view of a vector, ensurint that the +-- vector has dimension @n * (n+1)/2@, where @n@ is the desired dimension. +fromSTVector :: (Storable e) => Int -> STVector s e -> STPacked s e +fromSTVector n x + | not $ 2 * nx == n * (n+1) = error $ + printf ("fromVectorST %d : dimension mismatch") + n nx + | otherwise = + STPacked $ unsafeFromVector n x + where + nx = V.dim x +{-# INLINE fromSTVector #-} + +-- | Create a packed matrix view of a vector, wihtout checking +-- the dimension of the vector. +unsafeFromSTVector :: (Storable e) => Int -> STVector s e -> STPacked s e +unsafeFromSTVector = STPacked +{-# INLINE unsafeFromSTVector #-} + +-- | Returns the dimension and underlying vector storage of a +-- packed matrix. +toSTVector :: (Storable e) => STPacked s e -> (Int, STVector s e) +toSTVector (STPacked n v) = (n,v) +{-# INLINE toSTVector #-} +-} + +-- | Read-only packed matrices. +class RPacked p where + -- | Returns the dimension of the packed matrix. + getDim :: (Storable e) => p e -> ST s Int + + -- | Perform an action with the underlying vector storage of + -- the packed matrix. + withVector :: (Storable e) + => p e + -> (forall v . RVector v => v e -> ST s a) + -> ST s a + + -- | Perform an IO action with a pointer to the first element of + -- the packed matrix. + unsafeWith :: (Storable e) => p e -> (Ptr e -> IO a) -> IO a + + -- | Converts a read-only packed matrix into an immutable one. This simply + -- casts the matrix from one type to the other without copying the matrix. + -- Note that because the matrix is possibly not copied, any subsequent + -- modifications made to the mutable version of the matrix may be shared + -- with the immutable version. It is safe to use, therefore, if the mutable + -- version is never modified after the freeze operation. + unsafeFreeze :: (Storable e) => p e -> ST s (Packed e) + + unsafeThaw :: (Storable e) => p e -> ST s (STPacked s e) + + +-- | View a vector as a packed matrix and pass it to a function. +withFromVector :: (RVector v, Storable e) + => Int + -> v e + -> (forall p . RPacked p => p e -> ST s a) + -> ST s a +withFromVector n v f = do + iv <- V.unsafeFreeze v + f $ fromVector n iv +{-# INLINE withFromVector #-} + +-- | View a mutable vector as a mutable packed matrix and pass it +-- to a function. +withFromVectorM :: (Storable e) + => Int + -> STVector s e + -> (STPacked s e -> ST s a) + -> ST s a +withFromVectorM n v f = + withFromVector n v $ \p -> do + mp <- unsafeThaw p + f mp +{-# INLINE withFromVectorM #-} + +-- | Perform an action with the underlying vector storage of +-- the mutable packed matrix. See also 'withVectorView'. +withVectorM :: (Storable e) + => STPacked s e + -> (STVector s e -> ST s a) + -> ST s a +withVectorM mp f = + withVector mp $ \v -> do + mv <- V.unsafeThaw v + f mv +{-# INLINE withVectorM #-} + +instance RPacked Packed where + getDim = return . dim + {-# INLINE getDim #-} + withVector (Packed _ v) f = f v + {-# INLINE withVector #-} + unsafeWith (Packed _ v) = V.unsafeWith v + {-# INLINE unsafeWith #-} + unsafeFreeze = return + {-# INLINE unsafeFreeze #-} + unsafeThaw = return . STPacked + {-# INLINE unsafeThaw #-} + +instance RPacked (STPacked s) where + getDim = getDim . unSTPacked + {-# INLINE getDim #-} + withVector = withVector . unSTPacked + {-# INLINE withVector #-} + unsafeWith = unsafeWith . unSTPacked + {-# INLINE unsafeWith #-} + unsafeFreeze = return . unSTPacked + {-# INLINE unsafeFreeze #-} + unsafeThaw p = return $ cast p + where + cast :: STPacked s e -> STPacked s' e + cast = unsafeCoerce + {-# INLINE unsafeThaw #-} + + +-- | Create a new copy of a packed matrix. +newCopy :: (RPacked p, Storable e) + => p e -> ST s (STPacked s e) +newCopy p = do + n <- getDim p + p' <- new_ n + withVector p $ \v -> + withVectorM p' $ \v' -> + V.unsafeCopyTo v' v + return p' +{-# INLINE newCopy #-} + +-- | Converts a mutable packed matrix to an immutable one by taking a complete +-- copy of it. +freeze :: (RPacked p, Storable e) => p e -> ST s (Packed e) +freeze p = do + p' <- newCopy p + unsafeFreeze p' + +-- | A safe way to create and work with a mutable Packed before returning +-- an immutable one for later perusal. +create :: (Storable e) + => (forall s. ST s ((STPacked s) e)) + -> Packed e +create stmp = runST $ do + mp <- stmp + unsafeFreeze mp + + +-- | A safe way to create and work with a mutable Herm Packed before returning +-- an immutable one for later perusal. +hermCreate :: (Storable e) + => (forall s. ST s (Herm (STPacked s) e)) + -> Herm Packed e +hermCreate stmh = runST $ do + (Herm u mp) <- stmh + p <- unsafeFreeze mp + return $ Herm u p + +-- | @hermRank1Update alpha x a@ returns +-- @alpha * x * x^H + a@. +hermRank1Update :: (BLAS2 e) + => Double -> Vector e -> Herm Packed e -> Herm Packed e +hermRank1Update alpha x (Herm uplo ap) = hermCreate $ do + hp' <- Herm uplo `fmap` newCopy ap + hermRank1UpdateM_ alpha x hp' + return hp' + +-- | @hermRank2Update alpha x y a@ returns +-- @alpha * x * y^H + conj(alpha) * y * x^H + a@. +hermRank2Update :: (BLAS2 e) + => e -> Vector e -> Vector e -> Herm Packed e + -> Herm Packed e +hermRank2Update alpha x y (Herm uplo ap) = hermCreate $ do + hp' <- Herm uplo `fmap` newCopy ap + hermRank2UpdateM_ alpha x y hp' + return hp' + +-- | @hermRank1UpdateM_ alpha x a@ sets +-- @a := alpha * x * x^H + a@. +hermRank1UpdateM_ :: (RVector v, BLAS2 e) + => Double -> v e -> Herm (STPacked s) e -> ST s () +hermRank1UpdateM_ alpha x (Herm uplo a) = do + nx <- V.getDim x + na <- getDim a + let n = nx + + when ((not . and) [ nx == n, na == n ]) $ error $ + printf ("hermRank1UpdateM_ _ " + ++ " (Herm _ ):" + ++ " invalid dimensions") nx na + + unsafeIOToST $ + V.unsafeWith x $ \px -> + unsafeWith a $ \pa -> + BLAS.hpr uplo n alpha px 1 pa + + +-- | @hermRank2UpdateM_ alpha x y a@ sets +-- @a := alpha * x * y^H + conj(alpha) * y * x^H + a@. +hermRank2UpdateM_ :: (RVector v1, RVector v2, BLAS2 e) + => e -> v1 e -> v2 e -> Herm (STPacked s) e -> ST s () +hermRank2UpdateM_ alpha x y (Herm uplo a) = do + nx <- V.getDim x + ny <- V.getDim y + na <- getDim a + let n = nx + + when ((not . and) [ nx == n, ny == n, na == n ]) $ error $ + printf ("hermRank2UpdateM_ _ " + ++ " " + ++ " (Herm _ ):" + ++ " invalid dimensions") nx ny na + + unsafeIOToST $ + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + unsafeWith a $ \pa -> + BLAS.hpr2 uplo n alpha px 1 py 1 pa + + +-- | @hermMulVector a x@ returns @a * x@. +hermMulVector :: (BLAS2 e) + => Herm Packed e + -> Vector e + -> Vector e +hermMulVector a x = + V.create $ do + y <- V.new_ (V.dim x) + hermMulVectorTo y a x + return y + +-- | @hermMulVectorWithScale alpha a x@ retunrs @alpha * a * x@. +hermMulVectorWithScale :: (BLAS2 e) + => e + -> Herm Packed e + -> Vector e + -> Vector e +hermMulVectorWithScale alpha a x = + V.create $ do + y <- V.new_ (V.dim x) + hermMulVectorWithScaleTo y alpha a x + return y + +-- | @addHermMulVectorWithScales alpha a x y@ +-- returns @alpha * a * x + beta * y@. +addHermMulVectorWithScales :: (BLAS2 e) + => e + -> Herm Packed e + -> Vector e + -> e + -> Vector e + -> Vector e +addHermMulVectorWithScales alpha a x beta y = + V.create $ do + y' <- V.newCopy y + addHermMulVectorWithScalesM_ alpha a x beta y' + return y' + +-- | @hermMulVectorTo dst a x@ sets @dst := a * x@. +hermMulVectorTo :: (RPacked p, RVector v, BLAS2 e) + => STVector s e + -> Herm p e + -> v e + -> ST s () +hermMulVectorTo dst = hermMulVectorWithScaleTo dst 1 + +-- | @hermMulVectorWithScaleTo dst alpha a x@ +-- sets @dst := alpha * a * x@. +hermMulVectorWithScaleTo :: (RPacked p, RVector v, BLAS2 e) + => STVector s e + -> e + -> Herm p e + -> v e + -> ST s () +hermMulVectorWithScaleTo dst alpha a x = + addHermMulVectorWithScalesM_ alpha a x 0 dst + +-- | @addHermMulVectorWithScalesM_ alpha a x beta y@ +-- sets @y := alpha * a * x + beta * y@. +addHermMulVectorWithScalesM_ :: (RPacked p, RVector v, BLAS2 e) + => e + -> Herm p e + -> v e + -> e + -> STVector s e + -> ST s () +addHermMulVectorWithScalesM_ alpha (Herm uplo a) x beta y = do + na <- getDim a + nx <- V.getDim x + ny <- V.getDim y + let n = ny + + when ((not . and) [ na == n + , nx == n + , ny == n + ]) $ error $ + printf ("addHermMulVectorWithScalesM_ _" + ++ " (Herm %s )" + ++ " %s " + ++ " _" + ++ " : dimension mismatch") + (show uplo) na + nx ny + + unsafeIOToST $ + unsafeWith a $ \pa -> + V.unsafeWith x $ \px -> + V.unsafeWith y $ \py -> + BLAS.hpmv uplo n alpha pa px 1 beta py 1 diff --git a/lib/Numeric/LinearAlgebra/Packed/Cholesky.hs b/lib/Numeric/LinearAlgebra/Packed/Cholesky.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/Cholesky.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.Cholesky +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Cholesky factorizations of symmetric (Hermitian) positive-definite +-- matrices. +-- + +module Numeric.LinearAlgebra.Packed.Cholesky ( + -- * Immutable interface + cholFactor, + cholSolveVector, + cholSolveMatrix, + + -- * Mutable interface + cholFactorM, + cholSolveVectorM_, + cholSolveMatrixM_, + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Text.Printf( printf ) + +import qualified Foreign.LAPACK as LAPACK + +import Numeric.LinearAlgebra.Types + +import Numeric.LinearAlgebra.Packed.Base( Packed, RPacked, STPacked ) +import qualified Numeric.LinearAlgebra.Packed.Base as P + +import Numeric.LinearAlgebra.Matrix( Matrix, STMatrix ) +import qualified Numeric.LinearAlgebra.Matrix as M + +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +-- | @cholFactor a@ tries to compute the Cholesky +-- factorization of @a@. If @a@ is positive-definite then the routine +-- returns @Right@ with the factorization. If the leading minor of order @i@ +-- is not positive-definite then the routine returns @Left i@. +cholFactor :: (LAPACK e) + => Herm Packed e + -> Either Int (Chol Packed e) +cholFactor (Herm uplo a) = runST $ do + ma <- P.newCopy a + cholFactorM (Herm uplo ma) + >>= either (return . Left) (\(Chol uplo' ma') -> do + a' <- P.unsafeFreeze ma' + return $ Right (Chol uplo' a') + ) + +-- | @cholSolveVector a x@ returns @a \\ x@. +cholSolveVector :: (LAPACK e) + => Chol Packed e + -> Vector e + -> Vector e +cholSolveVector a x = V.create $ do + x' <- V.newCopy x + cholSolveVectorM_ a x' + return x' + +-- | @cholSolveMatrix a b@ returns @a \\ b@. +cholSolveMatrix :: (LAPACK e) + => Chol Packed e + -> Matrix e + -> Matrix e +cholSolveMatrix a c = M.create $ do + c' <- M.newCopy c + cholSolveMatrixM_ a c' + return c' + +-- | @cholFactorM a@ tries to compute the Cholesky +-- factorization of @a@ in place. If @a@ is positive-definite then the +-- routine returns @Right@ with the factorization, stored in the same +-- memory as @a@. If the leading minor of order @i@ is not +-- positive-definite then the routine returns @Left i@. +-- In either case, the original storage of @a@ is destroyed. +cholFactorM :: (LAPACK e) + => Herm (STPacked s) e + -> ST s (Either Int (Chol (STPacked s) e)) +cholFactorM (Herm uplo a) = do + n <- P.getDim a + unsafeIOToST $ + P.unsafeWith a $ \pa -> do + info <- LAPACK.pptrf uplo n pa + return $ if info > 0 then Left info + else Right (Chol uplo a) + +-- | @cholSolveVectorM_ a x@ sets @x := a \\ x@. +cholSolveVectorM_ :: (LAPACK e, RPacked p) + => Chol p e + -> STVector s e + -> ST s () +cholSolveVectorM_ a x = + M.withFromColM x $ \x' -> + cholSolveMatrixM_ a x' + +-- | @cholSolveMatrixM_ a b@ sets @b := a \\ b@. +cholSolveMatrixM_ :: (LAPACK e, RPacked p) + => Chol p e + -> STMatrix s e + -> ST s () +cholSolveMatrixM_ (Chol uplo a) b = do + na <- P.getDim a + (mb,nb) <- M.getDim b + let (n,nrhs) = (mb,nb) + + when ((not . and) [ na == n + , (mb,nb) == (n,nrhs) + ]) $ error $ + printf ("cholSolveMatrixM_" + ++ " (Chol _ )" + ++ " " + ++ ": dimension mismatch") + na mb nb + + unsafeIOToST $ + P.unsafeWith a $ \pa -> + M.unsafeWith b $ \pb ldb -> + LAPACK.pptrs uplo n nrhs pa pb ldb diff --git a/lib/Numeric/LinearAlgebra/Packed/Herm.hs b/lib/Numeric/LinearAlgebra/Packed/Herm.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/Herm.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.Herm +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Hermitian views of packed matrices. +-- +module Numeric.LinearAlgebra.Packed.Herm ( + -- * Immutable interface + + -- ** Vector multiplication + hermMulVector, + hermMulVectorWithScale, + addHermMulVectorWithScales, + + -- ** Updates + hermRank1Update, + hermRank2Update, + + -- * Mutable interface + hermCreate, + + -- ** Vector multiplication + hermMulVectorTo, + hermMulVectorWithScaleTo, + addHermMulVectorWithScalesM_, + + -- ** Updates + hermRank1UpdateM_, + hermRank2UpdateM_, + + ) where + +import Numeric.LinearAlgebra.Packed.Base diff --git a/lib/Numeric/LinearAlgebra/Packed/ST.hs b/lib/Numeric/LinearAlgebra/Packed/ST.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/ST.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.ST +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Mutable packed matrices. +-- +module Numeric.LinearAlgebra.Packed.ST ( + -- * Mutable packed matrices + STPacked, + IOPacked, + create, + + -- * Read-only packed matrices + RPacked(..), + + -- * Conversions between mutable and immutable packed matrices + freeze, + + -- * Creating new packed matrices + new_, + + -- * Copying matrices + newCopy, + + -- * Vector views of packed matrices + withVectorM, + + -- * Packed matrix views of vectors + withFromVector, + withFromVectorM, + + ) where + +import Numeric.LinearAlgebra.Packed.Base + diff --git a/lib/Numeric/LinearAlgebra/Packed/Statistics.hs b/lib/Numeric/LinearAlgebra/Packed/Statistics.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/Statistics.hs @@ -0,0 +1,188 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.Statistics +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Basic multivariate statistics. +-- + +module Numeric.LinearAlgebra.Packed.Statistics ( + defaultCovUplo, + + -- * Immutable interface + cov, + covWithMean, + weightedCov, + weightedCovWithMean, + + -- * Mutable interface + covTo, + covWithMeanTo, + weightedCovTo, + weightedCovWithMeanTo, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST ) +import Data.List( foldl' ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Types +import Numeric.LinearAlgebra.Packed.Base( Packed, STPacked ) +import qualified Numeric.LinearAlgebra.Packed.Base as P + +import Numeric.LinearAlgebra.Vector( Vector, RVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +import qualified Numeric.LinearAlgebra.Matrix as M + + +-- | Returns the default storage scheme for covariance matrices. +defaultCovUplo :: Uplo +defaultCovUplo = Lower + +-- | Returns the sample covariance matrix hermitian matrix (in packed form) +-- with storage scheme equal to 'defaultCovUplo'. The first argument gives +-- the dimension of the vectors. +cov :: (BLAS2 e) + => Int -> CovMethod -> [Vector e] -> Herm Packed e +cov p t xs = P.hermCreate $ do + c <- Herm uplo `fmap` P.new_ p + covTo c t xs + return c + where + uplo = defaultCovUplo + +-- | Given the pre-computed mean, returns the sample covariance matrix +-- (in packed form) with storage scheme equal to 'defaultCovUplo'. +covWithMean :: (BLAS2 e) + => Vector e -> CovMethod -> [Vector e] -> Herm Packed e +covWithMean mu t xs = P.hermCreate $ do + c <- Herm uplo `fmap` P.new_ p + covWithMeanTo c mu t xs + return c + where + p = V.dim mu + uplo = defaultCovUplo + +-- | Returns the weighed sample covariance matrix (in packed form) with +-- storage scheme equal to 'defaultCovUplo'. The first argument gives the +-- dimension of the vectors. +weightedCov :: (BLAS2 e) + => Int -> CovMethod -> [(Double, Vector e)] -> Herm Packed e +weightedCov p t wxs = P.hermCreate $ do + c <- Herm uplo `fmap` P.new_ p + weightedCovTo c t wxs + return c + where + uplo = defaultCovUplo + +-- | Given the pre-computed mean, returns the weighed sample covariance matrix +-- (in packed form) with storage scheme equal to 'defaultCovUplo'. +weightedCovWithMean :: (BLAS2 e) + => Vector e -> CovMethod -> [(Double, Vector e)] + -> Herm Packed e +weightedCovWithMean mu t wxs = P.hermCreate $ do + c <- Herm uplo `fmap` P.new_ p + weightedCovWithMeanTo c mu t wxs + return c + where + p = V.dim mu + uplo = defaultCovUplo + +-- | Computes and copies the sample covariance matrix (in packed form) +-- to the given destination. +covTo :: (RVector v, BLAS2 e) + => Herm (STPacked s) e -> CovMethod -> [v e] -> ST s () +covTo c@(Herm _ a) t xs = do + p <- P.getDim a + mu <- V.new p 1 + V.meanTo mu xs + covWithMeanTo c mu t xs + + +-- | Given the pre-computed mean, computes and copies the sample covariance +-- matrix (in packed form) to the given destination. +covWithMeanTo :: (RVector v1, RVector v2, BLAS2 e) + => Herm (STPacked s) e + -> v1 e -> CovMethod -> [v2 e] + -> ST s () +covWithMeanTo c@(Herm _ a) mu t xs = do + pa <- P.getDim a + p <- V.getDim mu + + when (pa /= p) $ error $ + printf ("covWithMeanTo" + ++ " (Herm _ )" + ++ " " + ++ " _ _" + ++ ": dimension mismatch") + pa p + + xt <- M.new_ (p,n) + M.withColsM xt $ \xs' -> + sequence_ [ V.subTo x' mu x + | (x,x') <- zip xs xs' + ] + P.withVectorM a V.clear + M.withColsM xt $ \xs' -> + sequence_ [ P.hermRank1UpdateM_ scale x' c | x' <- xs' ] + where + n = length xs + df = fromIntegral $ case t of { MLCov -> n ; UnbiasedCov -> n - 1 } + scale = 1/df + + +-- | Computes and copies the weighed sample covariance matrix (in packed +-- form) to the given destination. +weightedCovTo :: (RVector v, BLAS2 e) + => Herm (STPacked s) e + -> CovMethod -> [(Double, v e)] + -> ST s () +weightedCovTo c@(Herm _ a) t wxs = do + p <- P.getDim a + mu <- V.new p 1 + V.weightedMeanTo mu wxs + weightedCovWithMeanTo c mu t wxs + + +-- | Given the pre-computed mean, computes and copies the weighed sample +-- covariance matrix (in packed form) to the given destination. +weightedCovWithMeanTo :: (RVector v1, RVector v2, BLAS2 e) + => Herm (STPacked s) e + -> v1 e -> CovMethod -> [(Double, v2 e)] + -> ST s () +weightedCovWithMeanTo c@(Herm _ a) mu t wxs = do + pa <- P.getDim a + p <- V.getDim mu + + when (pa /= p) $ error $ + printf ("weightedCovWithMeanTo" + ++ " (Herm _ )" + ++ " " + ++ " _ _" + ++ ": dimension mismatch") + pa p + + xt <- M.new_ (p,n) + M.withColsM xt $ \xs' -> + sequence_ [ V.subTo x' mu x + >> V.scaleM_ (realToFrac $ sqrt (w / invscale)) x' + | (w,x,x') <- zip3 ws xs xs' + ] + P.withVectorM a V.clear + M.withCols xt $ \xs' -> + sequence_ [ P.hermRank1UpdateM_ 1 x' c | x' <- xs' ] + where + (ws0,xs) = unzip wxs + w_sum = foldl' (+) 0 ws0 + ws = if w_sum == 0 then ws0 else map (/w_sum) ws0 + w2s_sum = foldl' (+) 0 $ map (^^(2::Int)) ws + invscale = case t of + MLCov -> 1 + UnbiasedCov -> (1 - w2s_sum) + n = length ws0 diff --git a/lib/Numeric/LinearAlgebra/Packed/Tri.hs b/lib/Numeric/LinearAlgebra/Packed/Tri.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Packed/Tri.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Packed.Tri +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Triangular views of packed matrices. +-- + +module Numeric.LinearAlgebra.Packed.Tri ( + -- * Immutable interface + + -- ** Vector multiplication + triMulVector, + + -- ** Vector solving + triSolvVector, + + -- * Mutable interface + triCreate, + + -- ** Vector multiplication + triMulVectorM_, + + -- ** Vector solving + triSolvVectorM_, + + ) where + +import Control.Monad( when ) +import Control.Monad.ST( ST, runST, unsafeIOToST ) +import Text.Printf( printf ) + +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V +import Numeric.LinearAlgebra.Packed.Base( Packed, RPacked, STPacked ) +import qualified Numeric.LinearAlgebra.Packed.Base as P +import Numeric.LinearAlgebra.Types +import qualified Foreign.BLAS as BLAS + + +-- | A safe way to create and work with a mutable Tri Packed before returning +-- an immutable one for later perusal. +triCreate :: (Storable e) + => (forall s. ST s (Tri (STPacked s) e)) + -> Tri Packed e +triCreate mt = runST $ do + (Tri u d ma) <- mt + a <- P.unsafeFreeze ma + return $ Tri u d a + +-- | @triMulVector trans a x@ returns @op(a) * x@, where @op(a)@ is +-- determined by @trans@. +triMulVector :: (BLAS2 e) + => Trans + -> Tri Packed e + -> Vector e + -> Vector e +triMulVector trans a x = + V.create $ do + x' <- V.newCopy x + triMulVectorM_ trans a x' + return x' + +-- | @triMulVectorM_ a x@ sets @x := op(a) * x@, where @op(a)@ is determined +-- by @trans@. +triMulVectorM_ :: (RPacked p, BLAS2 e) + => Trans -> Tri p e + -> STVector s e + -> ST s () +triMulVectorM_ trans (Tri uplo diag a) x = do + na <- P.getDim a + nx <- V.getDim x + let n = nx + + when (nx /= n) $ error $ + printf ("triMulVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + na + nx + + unsafeIOToST $ + P.unsafeWith a $ \pa -> + V.unsafeWith x $ \px -> + BLAS.tpmv uplo trans diag n pa px 1 + + +-- | @triSolvVector trans a x@ returns @op(a) \\ x@, where @op(a)@ is +-- determined by @trans@. +triSolvVector :: (BLAS2 e) + => Trans + -> Tri Packed e + -> Vector e + -> Vector e +triSolvVector trans a x = + V.create $ do + x' <- V.newCopy x + triSolvVectorM_ trans a x' + return x' + +-- | @triSolvVectorM_ a x@ sets @x := op(a) \\ x@, where @op(a)@ is determined +-- by @trans@. +triSolvVectorM_ :: (RPacked p, BLAS2 e) + => Trans -> Tri p e + -> STVector s e + -> ST s () +triSolvVectorM_ trans (Tri uplo diag a) x = do + na <- P.getDim a + nx <- V.getDim x + let n = nx + + when (nx /= n) $ error $ + printf ("triMulVectorM_" + ++ " _" + ++ " (Tri _ _ )" + ++ " " + ++ ": dimension mismatch") + na + nx + + unsafeIOToST $ + P.unsafeWith a $ \pa -> + V.unsafeWith x $ \px -> + BLAS.tpsv uplo trans diag n pa px 1 diff --git a/lib/Numeric/LinearAlgebra/Types.hs b/lib/Numeric/LinearAlgebra/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Types.hs @@ -0,0 +1,92 @@ +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Types +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Basic type classes and enums. +-- + +module Numeric.LinearAlgebra.Types ( + + -- * Matrix views + Herm(..), + Tri(..), + + -- * Matrix factorization views + Chol(..), + + -- * Vector math types + VNum, + VFractional, + VFloating, + + -- * BLAS element types + BLAS1, + BLAS2, + BLAS3, + + -- * LAPACK element types + LAPACK, + + -- * Enums + Trans(..), + Uplo(..), + Side(..), + Diag(..), + + -- * Algorithm-specific parameters + CovMethod(..), + + -- * Re-export of Complex from Data.Complex + module Data.Complex, + + -- * Re-export of Storable from Foreign.Storable + module Foreign.Storable, + + ) where + +import Foreign.VMath( VNum, VFractional, VFloating ) +import Foreign.BLAS( Trans(..), Uplo(..), Side(..), Diag(..), BLAS1, BLAS2, BLAS3 ) +import Foreign.LAPACK( LAPACK ) +import Data.Complex( Complex(..) ) +import Foreign.Storable( Storable() ) + +-- | A hermitian view of an underlying matrix. The view can either be +-- of the upper or lower triangular part of the matrix. The type arguments +-- are as follows: +-- +-- * @m@: the underlyting matrix type. +-- +-- * @e@: the element type of the matrix. +-- +data Herm m e = Herm Uplo (m e) deriving (Show) + +-- | A triangular view of an underlying matrix. The view can either be +-- upper or lower triangular, with a unit or non-unit diagonal. The type +-- arguments are as follows: +-- +-- * @m@: the underlyting matrix type. +-- +-- * @e@: the element type of the matrix. +-- +data Tri m e = Tri Uplo Diag (m e) deriving (Show) + +-- | A Cholesky decomposition view of a matrix. +data Chol m e = Chol Uplo (m e) deriving (Show) + +-- | The method of scaling the sample covariance matrix. +data CovMethod = + UnbiasedCov -- ^ This is the default behavior. Corresponds to a + -- scaling of @n/(n-1)@ in the unweighed case, and + -- @1/(1 - \\sum w_i^2)@ in the weighted case, where @w_i@ + -- is the normalized weight. Note the unweighted and + -- weighted cases agree when @w_i = 1/n@. + + | MLCov -- ^ Returns the centered second moment matrix without + -- scaling the result. + deriving (Eq, Show) + diff --git a/lib/Numeric/LinearAlgebra/Vector.hs b/lib/Numeric/LinearAlgebra/Vector.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Vector.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE Rank2Types #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Vector +-- Copyright : Copyright (c) , Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Immutable dense vectors. + +module Numeric.LinearAlgebra.Vector ( + -- * Immutable vectors + Vector, + dim, + + -- * Vector construction + fromList, + zero, + constant, + + -- * Accessing vectors + at, + unsafeAt, + indices, + elems, + assocs, + + -- * Incremental vector updates + update, + unsafeUpdate, + accum, + unsafeAccum, + + -- * Derived vectors + map, + zipWith, + unsafeZipWith, + concat, + + -- * Vector views + slice, + unsafeSlice, + splitAt, + drop, + take, + + -- * Vector properties + sumAbs, + norm2, + whichMaxAbs, + dot, + unsafeDot, + kronecker, + + -- * Vector math operations + -- ** Num + add, + addWithScale, + sub, + scale, + mul, + negate, + conjugate, + abs, + signum, + + -- ** Fractional + div, + recip, + + -- ** Floating + sqrt, + exp, + log, + pow, + sin, + cos, + tan, + asin, + acos, + atan, + sinh, + cosh, + tanh, + asinh, + acosh, + atanh, + + -- * Conversions between foreign pointers + unsafeFromForeignPtr, + unsafeToForeignPtr, + + -- * Mutable interface + module Numeric.LinearAlgebra.Vector.ST, + + -- * Basic multivariate statistics + module Numeric.LinearAlgebra.Vector.Statistics, + + ) where + +import Prelude( Int, Double, ($), (*), return ) +import Control.Monad.ST( runST, ST ) +import Foreign( Storable ) +import Foreign.BLAS( BLAS1, BLAS2 ) +import Foreign.VMath( VNum, VFractional, VFloating ) + +import Numeric.LinearAlgebra.Vector.Base +import Numeric.LinearAlgebra.Vector.ST +import Numeric.LinearAlgebra.Vector.Statistics + +infixr 8 `pow` +infixl 7 `div` +infixl 7 `mul`, `scale`, `kronecker` +infixl 6 `add`, `sub` + + +-- | Compute the sum of absolute values of entries in the vector. +sumAbs :: (BLAS1 e) => Vector e -> Double +sumAbs v = runST $ getSumAbs v +{-# INLINE sumAbs #-} + +-- | Compute the 2-norm (Euclidean norm) of a vector. +norm2 :: (BLAS1 e) => Vector e -> Double +norm2 v = runST $ getNorm2 v +{-# INLINE norm2 #-} + +-- | Get the index and norm of the element with absulte value. Not valid +-- if any of the vector entries are @NaN@. Raises an exception if the +-- vector has length @0@. +whichMaxAbs :: (BLAS1 e) => Vector e -> (Int, e) +whichMaxAbs v = runST $ getWhichMaxAbs v +{-# INLINE whichMaxAbs #-} + +-- | Compute the dot product of two vectors. +dot :: (BLAS1 e) => Vector e -> Vector e -> e +dot v v' = runST $ getDot v v' +{-# INLINE dot #-} + +unsafeDot :: (BLAS1 e) => Vector e -> Vector e -> e +unsafeDot v v' = runST $ unsafeGetDot v v' +{-# INLINE unsafeDot #-} + +-- | Compute the kronecker product of two vectors. +kronecker :: (BLAS2 e) => Vector e -> Vector e -> Vector e +kronecker x y = create $ do + z <- new_ (dim x * dim y) + kroneckerTo z x y + return z + +-- | @add x y@ returns @x + y@. +add :: (VNum e) => Vector e -> Vector e -> Vector e +add = result2 addTo + +-- | @sub x y@ returns @x - y@. +sub :: (VNum e) => Vector e -> Vector e -> Vector e +sub = result2 subTo + +-- | @scale k x@ returns @k * x@. +scale :: (BLAS1 e) => e -> Vector e -> Vector e +scale k x = create $ do + x' <- newCopy x + scaleM_ k x' + return x' + +-- | @addWithScale alpha x y@ return @alpha * x + y@. +addWithScale :: (BLAS1 e) => e -> Vector e -> Vector e -> Vector e +addWithScale alpha x y = create $ do + y' <- newCopy y + addWithScaleM_ alpha x y' + return y' + +-- | @mul x y@ returns @x * y@. +mul :: (VNum e) => Vector e -> Vector e -> Vector e +mul = result2 mulTo + +-- | @negate x@ returns @-x@. +negate :: (VNum e) => Vector e -> Vector e +negate = result negateTo + +-- | @conjugate x@ returns @conjugate(x)@. +conjugate :: (VNum e) => Vector e -> Vector e +conjugate = result conjugateTo + +-- | @abs x@ returns @abs(x)@. +abs :: (VNum e) => Vector e -> Vector e +abs = result absTo + +-- | @signum x@ returns @signum(x)@. +signum :: (VNum e) => Vector e -> Vector e +signum = result signumTo + +-- | @div x y@ returns @x / y@. +div :: (VFractional e) => Vector e -> Vector e -> Vector e +div = result2 divTo + +-- | @recip x y@ returns @1 / x@. +recip :: (VFractional e) => Vector e -> Vector e +recip = result recipTo + +-- | @sqrt x@ returns @sqrt(x)@. +sqrt :: (VFloating e) => Vector e -> Vector e +sqrt = result sqrtTo + +-- | @exp x@ returns @exp(x)@. +exp :: (VFloating e) => Vector e -> Vector e +exp = result expTo + +-- | @log x@ returns @log(x)@. +log :: (VFloating e) => Vector e -> Vector e +log = result logTo + +-- | @pow x y@ returns @x ** y@. +pow :: (VFloating e) => Vector e -> Vector e -> Vector e +pow = result2 powTo + +-- | @sin x@ returns @sin(x)@. +sin :: (VFloating e) => Vector e -> Vector e +sin = result sinTo + +-- | @cos x@ returns @cos(x)@. +cos :: (VFloating e) => Vector e -> Vector e +cos = result cosTo + +-- | @tan x@ returns @tan(x)@. +tan :: (VFloating e) => Vector e -> Vector e +tan = result tanTo + +-- | @asin x@ returns @asin(x)@. +asin :: (VFloating e) => Vector e -> Vector e +asin = result asinTo + +-- | @acos x@ returns @acos(x)@. +acos :: (VFloating e) => Vector e -> Vector e +acos = result acosTo + +-- | @atan x@ returns @atan(x)@. +atan :: (VFloating e) => Vector e -> Vector e +atan = result atanTo + +-- | @sinh x@ returns @sinh(x)@. +sinh :: (VFloating e) => Vector e -> Vector e +sinh = result sinhTo + +-- | @cosh x@ returns @cosh(x)@. +cosh :: (VFloating e) => Vector e -> Vector e +cosh = result coshTo + +-- | @tanh x@ returns @tanh(x)@. +tanh :: (VFloating e) => Vector e -> Vector e +tanh = result tanhTo + +-- | @asinh x@ returns @asinh(x)@. +asinh :: (VFloating e) => Vector e -> Vector e +asinh = result asinhTo + +-- | @acosh x@ returns @acosh(x)@. +acosh :: (VFloating e) => Vector e -> Vector e +acosh = result acoshTo + +-- | @atanh x@ returns @atanh(x)@. +atanh :: (VFloating e) => Vector e -> Vector e +atanh = result atanhTo + + +result :: (Storable e, Storable f) + => (forall s . STVector s f -> Vector e -> ST s a) + -> Vector e + -> Vector f +result f v = create $ newResult f v +{-# INLINE result #-} + +result2 :: (Storable e, Storable f, Storable g) + => (forall s . STVector s g -> Vector e -> Vector f -> ST s a) + -> Vector e + -> Vector f + -> Vector g +result2 f v1 v2 = create $ newResult2 f v1 v2 +{-# INLINE result2 #-} + +newResult :: (RVector v, Storable e, Storable f) + => (STVector s f -> v e -> ST s a) + -> v e + -> ST s (STVector s f) +newResult f v = do + n <- getDim v + z <- new_ n + _ <- f z v + return z +{-# INLINE newResult #-} + +newResult2 :: (RVector v1, RVector v2, Storable e, Storable f, Storable g) + => (STVector s g -> v1 e -> v2 f -> ST s a) + -> v1 e + -> v2 f + -> ST s (STVector s g) +newResult2 f v1 v2 = do + n <- getDim v1 + z <- new_ n + _ <- f z v1 v2 + return z +{-# INLINE newResult2 #-} diff --git a/lib/Numeric/LinearAlgebra/Vector/Base.hs b/lib/Numeric/LinearAlgebra/Vector/Base.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Vector/Base.hs @@ -0,0 +1,288 @@ +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Vector.Base +-- Copyright : Copyright (c) , Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- + +module Numeric.LinearAlgebra.Vector.Base ( + Vector, + dim, + + fromList, + zero, + constant, + + at, + unsafeAt, + + indices, + elems, + assocs, + + update, + unsafeUpdate, + accum, + unsafeAccum, + + map, + zipWith, + unsafeZipWith, + concat, + + slice, + splitAt, + drop, + take, + + unsafeSlice, + unsafeFromForeignPtr, + unsafeToForeignPtr, + unsafeWith, + ) where + +import Prelude hiding ( concat, drop, map, read, splitAt, take, zipWith, + negate, signum, abs, div, recip, sqrt, exp, log, sin, cos, tan, asin, + acos, atan, sinh, cosh, tanh, asinh, acosh, atanh ) +import qualified Prelude as P + +import Data.AEq( AEq(..) ) +import Data.Vector.Storable( Vector ) +import qualified Data.Vector.Storable as Vector +import Foreign( ForeignPtr, Ptr, Storable ) +import Text.Printf( printf ) + + +-- | The dimension of a vector. This is equal to the number of +-- elements in the vector. +dim :: (Storable e) => Vector e -> Int +dim = Vector.length +{-# INLINE dim #-} + +-- | Create a vector of the given dimension with elements initialized +-- to the values from the list. The list must have at least as many +-- elements as the dimension of the vector; elements in the list past +-- the dimension of the vector are discarded. +fromList :: (Storable e) => Int -> [e] -> Vector e +fromList n es = Vector.fromListN n $ es ++ repeat (error msg) + where + msg = printf ( "fromList" + ++ " %d" + ++ " " + ++ ": not enough elements" + ) n n +{-# INLINE fromList #-} + +-- | Create a zero vector of the given dimension with all elements initialized +-- to the given zero. +zero :: (Storable e, Num e) => Int -> Vector e +zero n = constant n 0 +{-# INLINE zero #-} + +-- | Create a vector of the given dimension with all elements initialized +-- to the given value. +constant :: (Storable e) => Int -> e -> Vector e +constant n e + | n < 0 = error $ + printf ("constant %d: negative dimension") n + | otherwise = + Vector.fromListN n $ repeat e +{-# INLINE constant #-} + +-- | Returns the element of a vector at the specified index. +at :: (Storable e) => Vector e -> Int -> e +at v i + | i < 0 || i >= n = error $ + printf "at %d: invalid index" n i + | otherwise = + unsafeAt v i + where + n = dim v +{-# INLINE at #-} + +-- | Same as 'at' but does not range-check index. +unsafeAt :: (Storable e) => Vector e -> Int -> e +unsafeAt v i = Vector.unsafeIndex v i +{-# INLINE unsafeAt #-} + +-- | Get the indices of the elements in the vector, @[ 0..n-1 ]@, where +-- @n@ is the dimension of the vector. +indices :: (Storable e) => Vector e -> [Int] +indices x = [ 0..n-1 ] where n = dim x +{-# INLINE indices #-} + +-- | Returns a list of the elements of a vector, in the same order as their +-- indices. +elems :: (Storable e) => Vector e -> [e] +elems = Vector.toList +{-# INLINE elems #-} + +-- | Returns the contents of a vector as a list of associations. +assocs :: (Storable e) => Vector e -> [(Int,e)] +assocs x = zip (indices x) (elems x) +{-# INLINE assocs #-} + +-- | Same as 'update' but does not range-check indices. +unsafeUpdate :: (Storable e) => Vector e -> [(Int,e)] -> Vector e +unsafeUpdate = Vector.unsafeUpd + +-- | Create a new vector by replacing the values at the specified indices. +update :: (Storable e) => Vector e -> [(Int,e)] -> Vector e +update = (Vector.//) + +-- | @accum f@ takes a vector and an association list and accumulates +-- pairs from the list into the vector with the accumulating function @f@. +accum :: (Storable e) + => (e -> e' -> e) + -> Vector e + -> [(Int, e')] + -> Vector e +accum = Vector.accum +{-# INLINE accum #-} + +-- | Same as 'accum' but does not range-check indices. +unsafeAccum :: (Storable e) + => (e -> e' -> e) + -> Vector e + -> [(Int, e')] + -> Vector e +unsafeAccum = Vector.unsafeAccum +{-# INLINE unsafeAccum #-} + +-- | Construct a new vector by applying a function to every element of +-- a vector. +map :: (Storable e, Storable e') + => (e -> e') + -> Vector e + -> Vector e' +map = Vector.map +{-# INLINE map #-} + +-- | Construct a new vector by applying a function to every pair of elements +-- of two vectors. The two vectors must have identical dimensions. +zipWith :: (Storable e, Storable e', Storable f) + => (e -> e' -> f) + -> Vector e + -> Vector e' + -> Vector f +zipWith f v v' + | n /= n' = error $ + printf ("zipWith " + ++ " : lengths differ") n n' + | otherwise = + unsafeZipWith f v v' + where + n = dim v + n' = dim v' +{-# INLINE zipWith #-} + +-- | Same as 'zipWith' but does not check if the input vectors +-- have the same dimensions. +unsafeZipWith :: (Storable e, Storable e', Storable f) + => (e -> e' -> f) + -> Vector e + -> Vector e' + -> Vector f +unsafeZipWith = Vector.zipWith +{-# INLINE unsafeZipWith #-} + +-- | Create a new vector by concatenating a list of vectors. +concat :: (Storable e) => [Vector e] -> Vector e +concat = Vector.concat +{-# INLINE concat #-} + +-- | Same as 'slice' but does not range-change indices. +unsafeSlice :: (Storable e) + => Int + -> Int + -> Vector e + -> Vector e +unsafeSlice = Vector.unsafeSlice +{-# INLINE unsafeSlice #-} + +-- | @slice i n v@ creates a subvector view of @v@ starting at +-- index @i@ and having dimension @n@. +slice :: (Storable e) + => Int + -> Int + -> Vector e + -> Vector e +slice i n' v + | i < 0 || n' < 0 || i + n' > n = error $ + printf "slice %d %d : index out of range" + i n' n + | otherwise = + unsafeSlice i n' v + where + n = dim v +{-# INLINE slice #-} + +-- | @drop i v@ is equal to @slice i (n-i) v@, where @n@ is +-- the dimension of the vector. +drop :: (Storable e) => Int -> Vector e -> Vector e +drop i v = slice i (dim v - i) v +{-# INLINE drop #-} + +-- | @take n v@ is equal to @slice 0 n v@. +take :: (Storable e) => Int -> Vector e -> Vector e +take n v = slice 0 n v +{-# INLINE take #-} + +-- | Split a vector into two blocks and returns views into the blocks. If +-- @(v1, v2) = splitAt i v@, then +-- @v1 = slice 0 i v@ and +-- @v2 = slice i (dim v - i) v@. +splitAt :: (Storable e) => Int -> Vector e -> (Vector e, Vector e) +splitAt i v + | i < 0 || i > n = error $ + printf "splitAt %d : invalid index" i n + | otherwise = let + v1 = unsafeSlice 0 i v + v2 = unsafeSlice i (n-i) v + in (v1, v2) + where + n = dim v + +-- | Create a vector from a 'ForeignPtr' with an offset and a dimension. The +-- data may not be modified through the ForeignPtr afterwards. +unsafeFromForeignPtr :: (Storable e) + => ForeignPtr e -- ^ pointer + -> Int -- ^ offset + -> Int -- ^ dimension + -> Vector e +unsafeFromForeignPtr = Vector.unsafeFromForeignPtr +{-# INLINE unsafeFromForeignPtr #-} + +-- | Yield the underlying 'ForeignPtr' together with the offset to the data +-- and its length. The data may not be modified through the 'ForeignPtr'. +unsafeToForeignPtr :: (Storable e) => Vector e -> (ForeignPtr e, Int, Int) +unsafeToForeignPtr = Vector.unsafeToForeignPtr +{-# INLINE unsafeToForeignPtr #-} + +-- | Pass a pointer to the vector's data to the 'IO' action. The data may +-- not be modified through the 'Ptr'. +unsafeWith :: (Storable e) => Vector e -> (Ptr e -> IO a) -> IO a +unsafeWith = Vector.unsafeWith + + +instance (Storable e, AEq e) => AEq (Vector e) where + (===) = compareWith (===) + {-# INLINE (===) #-} + (~==) = compareWith (~==) + {-# INLINE (~==) #-} + +compareWith :: (Storable e, Storable e') + => (e -> e' -> Bool) + -> Vector e + -> Vector e' + -> Bool +compareWith cmp v v' = + dim v == dim v' + && and (P.zipWith cmp (elems v) (elems v')) +{-# INLINE compareWith #-} + diff --git a/lib/Numeric/LinearAlgebra/Vector/ST.hs b/lib/Numeric/LinearAlgebra/Vector/ST.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Vector/ST.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Vector.ST +-- Copyright : Copyright (c) , Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Mutable vectors in the ST monad. + +module Numeric.LinearAlgebra.Vector.ST ( + -- * Mutable vectors + STVector, + IOVector, + create, + + -- * Read-only vectors + RVector(..), + + -- * Creating new vectors + new_, + new, + + -- * Copying vectors + newCopy, + copyTo, + swap, + + -- * Reading and writing vector elements + read, + write, + modify, + getIndices, + getElems, + getElems', + getAssocs, + getAssocs', + setElems, + setAssocs, + clear, + + -- * List-like operations + mapTo, + zipWithTo, + + -- * Vector linear algebra + getSumAbs, + getNorm2, + getWhichMaxAbs, + getDot, + scaleM_, + addWithScaleM_, + kroneckerTo, + + -- * Vector views + withSlice, + withDrop, + withTake, + withSplitAt, + + withSliceM, + withDropM, + withTakeM, + withSplitAtM, + + -- * Vector math operations + -- ** Num + addTo, + subTo, + mulTo, + negateTo, + conjugateTo, + absTo, + signumTo, + + -- ** Fractional + divTo, + recipTo, + + -- ** Floating + sqrtTo, + expTo, + logTo, + powTo, + sinTo, + cosTo, + tanTo, + asinTo, + acosTo, + atanTo, + sinhTo, + coshTo, + tanhTo, + asinhTo, + acoshTo, + atanhTo, + + -- * Conversions between mutable and immutable vectors + freeze, + + -- * Unsafe operations + unsafeCopyTo, + unsafeSwap, + unsafeRead, + unsafeWrite, + unsafeModify, + unsafeMapTo, + unsafeZipWithTo, + unsafeAddWithScaleM_, + unsafeGetDot, + + ) where + +import Prelude() +import Numeric.LinearAlgebra.Vector.STBase diff --git a/lib/Numeric/LinearAlgebra/Vector/STBase.hs b/lib/Numeric/LinearAlgebra/Vector/STBase.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Vector/STBase.hs @@ -0,0 +1,925 @@ +{-# LANGUAGE Rank2Types, DeriveDataTypeable #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Vector.STBase +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : asinerimental +-- + +module Numeric.LinearAlgebra.Vector.STBase ( + STVector, + IOVector, + RVector(..), + + create, + freeze, + + new_, + new, + newCopy, + + clear, + copyTo, + unsafeCopyTo, + swap, + unsafeSwap, + + getIndices, + getElems, + getElems', + getAssocs, + getAssocs', + setElems, + setAssocs, + unsafeSetAssocs, + + read, + unsafeRead, + write, + unsafeWrite, + modify, + unsafeModify, + unsafeSwapElems, + + mapTo, + unsafeMapTo, + zipWithTo, + unsafeZipWithTo, + + withSlice, + withDrop, + withTake, + withSplitAt, + + withSliceM, + withDropM, + withTakeM, + withSplitAtM, + + getSumAbs, + getNorm2, + getWhichMaxAbs, + getDot, + unsafeGetDot, + scaleM_, + addWithScaleM_, + unsafeAddWithScaleM_, + kroneckerTo, + + addTo, + subTo, + mulTo, + negateTo, + conjugateTo, + absTo, + signumTo, + divTo, + recipTo, + sqrtTo, + expTo, + logTo, + powTo, + sinTo, + cosTo, + tanTo, + asinTo, + acosTo, + atanTo, + sinhTo, + coshTo, + tanhTo, + asinhTo, + acoshTo, + atanhTo, + ) where + +import Prelude hiding ( drop, read, splitAt, take ) + +import Control.Monad( when, liftM2 ) +import Control.Monad.ST( RealWorld, ST, runST, stToIO, unsafeIOToST ) +import Data.Complex( Complex ) +import Data.Typeable( Typeable ) +import Foreign( Ptr, Storable, advancePtr, peek, poke, peekElemOff, + pokeElemOff, copyArray, mallocForeignPtrArray ) +import System.IO.Unsafe( unsafeInterleaveIO ) +import Text.Printf( printf ) +import Unsafe.Coerce( unsafeCoerce ) + +import Foreign.BLAS( BLAS1, BLAS2 ) +import qualified Foreign.BLAS as BLAS +import Foreign.VMath( VNum, VFractional, VFloating ) +import qualified Foreign.VMath as VMath + +import Numeric.LinearAlgebra.Internal( clearArray ) +import Numeric.LinearAlgebra.Vector.Base hiding ( unsafeWith ) +import qualified Numeric.LinearAlgebra.Vector.Base as V + + +-- | Mutable vectors in the 'ST' monad. +newtype STVector s e = STVector { unSTVector :: Vector e } + deriving (Typeable) + +-- | Mutable vectors in the 'IO' monad. Note that 'IO' operations +-- aren't directly supported; to perform an operation in the 'IO' +-- monad, perform the action in 'ST' 'RealWorld' and then convert +-- it via 'stToIO'. +type IOVector s = STVector RealWorld + +-- | A safe way to create and work with a mutable vector before returning +-- an immutable vector for later perusal. This function avoids copying +-- the vector before returning it - it uses 'unsafeFreeze' internally, +-- but this wrapper is a safe interface to that function. +create :: (Storable e) => (forall s . ST s (STVector s e)) -> Vector e +create stmv = runST $ do + mv <- stmv + unsafeFreeze mv +{-# INLINE create #-} + +-- | Converts a mutable vector to an immutable one by taking a complete +-- copy of it. +freeze :: (RVector v, Storable e) => v e -> ST s (Vector e) +freeze mv = do + mv' <- newCopy mv + unsafeFreeze mv' +{-# INLINE freeze #-} + + + +-- | Read-only vectors +class RVector v where + -- | Get the dimension of the vector. This is equal to the number of + -- elements in the vector. + getDim :: (Storable e) => v e -> ST s Int + + -- | Same as 'withSlice' but does not range-check indices. + unsafeWithSlice :: (Storable e) + => Int -> Int -> v e + -> (forall v'. RVector v' => v' e -> ST s a) + -> ST s a + + -- | Execute an 'IO' action with a pointer to the first element in the + -- vector. + unsafeWith :: (Storable e) => v e -> (Ptr e -> IO a) -> IO a + + -- | Converts a read-only vector into an immutable vector. This simply + -- casts the vector from one type to the other without copying the vector. + -- Note that because the vector is possibly not copied, any subsequent + -- modifications made to the mutable version of the vector may be shared + -- with the immutable version. It is safe to use, therefore, if the + -- mutable version is never modified after the freeze operation. + unsafeFreeze :: (Storable e) => v e -> ST s (Vector e) + + -- | Unsafe cast from a read-only vector to a mutable vector. + unsafeThaw :: (Storable e) + => v e -> ST s (STVector s e) + + +instance RVector Vector where + getDim = return . dim + {-# INLINE getDim #-} + + unsafeWith = V.unsafeWith + {-# INLINE unsafeWith #-} + + unsafeWithSlice i n' v f = + f (V.unsafeSlice i n' v) + {-# INLINE unsafeWithSlice #-} + + unsafeFreeze = return . id + {-# INLINE unsafeFreeze #-} + + unsafeThaw = return . STVector + {-# INLINE unsafeThaw #-} + + +instance RVector (STVector s) where + getDim = return . dim . unSTVector + {-# INLINE getDim #-} + + unsafeWith v f = V.unsafeWith (unSTVector v) f + {-# INLINE unsafeWith #-} + + unsafeWithSlice i n' v f = + f $ unsafeSlice i n' (unSTVector v) + {-# INLINE unsafeWithSlice #-} + + unsafeFreeze = return . unSTVector + {-# INLINE unsafeFreeze #-} + + unsafeThaw v = return $ cast v + where + cast :: STVector s e -> STVector s' e + cast = unsafeCoerce + {-# INLINE unsafeThaw #-} + + +-- | @withSlice i n v@ performs an action with a view of the +-- @n@-dimensional subvector of @v@ starting at index @i@. +withSlice :: (RVector v, Storable e) + => Int + -> Int + -> v e + -> (forall v'. RVector v' => v' e -> ST s a) + -> ST s a +withSlice i n' v f = do + n <- getDim v + when (i < 0 || n' < 0 || i + n' > n) $ error $ + printf "withSlice %d %d : index out of range" + i n' n + unsafeWithSlice i n' v f + +-- | Same as 'withSliceM' but does not range-check indices. +unsafeWithSliceM :: (Storable e) + => Int + -> Int + -> STVector s e + -> (STVector s e -> ST s a) + -> ST s a +unsafeWithSliceM i n' v f = + f $ STVector $ unsafeSlice i n' (unSTVector v) + +-- | Like 'withSlice', but perform the action with a mutable view +-- of the vector. +withSliceM :: (Storable e) + => Int + -> Int + -> STVector s e + -> (STVector s e -> ST s a) + -> ST s a +withSliceM i n' v f = do + n <- getDim v + when (i < 0 || n' < 0 || i + n' > n) $ error $ + printf "withSlice %d %d : index out of range" + i n' n + unsafeWithSliceM i n' v f + +-- | Like 'withDrop', but perform the action with a mutable view +-- of the vector. +withDropM :: (Storable e) + => Int + -> STVector s e + -> (STVector s e -> ST s a) + -> ST s a +withDropM i v f = do + n <- getDim v + withSliceM i (n-i) v f + +-- | Like 'withTake', but perform the action with a mutable view +-- of the vector. +withTakeM :: (Storable e) + => Int + -> STVector s e + -> (STVector s e -> ST s a) + -> ST s a +withTakeM = withSliceM 0 + +-- | Like 'withSplitAt' but perform the action with mutable views +-- of the vector. +withSplitAtM :: (Storable e) + => Int + -> STVector s e + -> (STVector s e -> STVector s e -> ST s a) + -> ST s a +withSplitAtM i v f = do + n <- getDim v + withSliceM 0 i v $ \v1 -> + withSliceM i (n-i) v $ \v2 -> + f v1 v2 + +-- | Perform an action the a view gotten from dropping the given +-- number of elements from the start of the vector. +withDrop :: (RVector v, Storable e) + => Int + -> v e + -> (forall v'. RVector v' => v' e -> ST s a) + -> ST s a +withDrop i v f = do + mv <- unsafeThaw v + withDropM i mv f + +-- | Perform an action with a view gotten from taking the given +-- number of elements from the start of the vector. +withTake :: (RVector v, Storable e) + => Int + -> v e + -> (forall v'. RVector v' => v' e -> ST s a) + -> ST s a +withTake n v f = do + mv <- unsafeThaw v + withTakeM n mv f + +-- | Perform an action with views from splitting the vector at the +-- given index. +withSplitAt :: (RVector v, Storable e) + => Int + -> v e + -> (forall v1' v2'. (RVector v1', RVector v2') => v1' e -> v2' e -> ST s a) + -> ST s a +withSplitAt i v f = do + mv <- unsafeThaw v + withSplitAtM i mv f + +-- | Creates a new vector of the given length. The elements will be +-- uninitialized. +new_ :: (Storable e) => Int -> ST s (STVector s e) +new_ n + | n < 0 = error $ + printf "new_ %d: invalid dimension" n + | otherwise = unsafeIOToST $ do + f <- mallocForeignPtrArray n + return $ STVector $ V.unsafeFromForeignPtr f 0 n + +-- | Create a vector with every element initialized to the same value. +new :: (Storable e) => Int -> e -> ST s (STVector s e) +new n e = do + x <- new_ n + setElems x $ replicate n e + return x + +-- | Creates a new vector by copying another one. +newCopy :: (RVector v, Storable e) => v e -> ST s (STVector s e) +newCopy x = do + n <- getDim x + y <- new_ n + unsafeCopyTo y x + return y + +-- | @copyTo dst src@ replaces the values in @dst@ with those in +-- source. The operands must be the same shape. +copyTo :: (RVector v, Storable e) => STVector s e -> v e -> ST s () +copyTo = checkOp2 "copyTo" unsafeCopyTo +{-# INLINE copyTo #-} + +-- | Same as 'copyTo' but does not check the dimensions. +unsafeCopyTo :: (RVector v, Storable e) => STVector s e -> v e -> ST s () +unsafeCopyTo dst src = do + n <- getDim dst + unsafeIOToST $ + unsafeWith dst $ \pdst -> + unsafeWith src $ \psrc -> + copyArray pdst psrc n +{-# INLINE unsafeCopyTo #-} + +-- | Swap the values stored in two vectors. +swap :: (BLAS1 e) => STVector s e -> STVector s e -> ST s () +swap = checkOp2 "swap" unsafeSwap +{-# INLINE swap #-} + +-- | Same as 'swap' but does not check the dimensions. +unsafeSwap :: (BLAS1 e) => STVector s e -> STVector s e -> ST s () +unsafeSwap = strideCall2 BLAS.swap +{-# INLINE unsafeSwap #-} + +-- | Get the indices of the elements in the vector, @[ 0..n-1 ]@, where +-- @n@ is the dimension of the vector. +getIndices :: (RVector v, Storable e) => v e -> ST s [Int] +getIndices v = do + n <- getDim v + return $ [ 0..n-1 ] +{-# INLINE getIndices #-} + +-- | Lazily get the elements of the vector. +getElems :: (RVector v, Storable e) => v e -> ST s [e] +getElems v = let + go end p' | p' == end = do + touch v + return [] + | otherwise = unsafeInterleaveIO $ do + e <- peek p' + es <- go end (p' `advancePtr` 1) + return $ e `seq` (e:es) + in do + n <- getDim v + unsafeIOToST $ + unsafeWith v $ \p -> + go (p `advancePtr` n) p + where + touch v' = unsafeWith v' $ const (return ()) +{-# SPECIALIZE INLINE getElems :: STVector s Double -> ST s [Double] #-} +{-# SPECIALIZE INLINE getElems :: STVector s (Complex Double) -> ST s [Complex Double] #-} + +-- | Get the elements of the vector. +getElems' :: (RVector v, Storable e) => v e -> ST s [e] +getElems' v = let + go end p' es | p' == end = + return es + | otherwise = do + e <- peek p' + go end (p' `advancePtr` (-1)) (e:es) + in do + n <- getDim v + unsafeIOToST $ + unsafeWith v $ \p -> + go (p `advancePtr` (-1)) (p `advancePtr` (n-1)) [] +{-# SPECIALIZE INLINE getElems' :: STVector s Double -> ST s [Double] #-} +{-# SPECIALIZE INLINE getElems' :: STVector s (Complex Double) -> ST s [Complex Double] #-} + +-- | Lazily get the association list of the vector. +getAssocs :: (RVector v, Storable e) => v e -> ST s [(Int,e)] +getAssocs x = liftM2 zip (getIndices x) (getElems x) +{-# INLINE getAssocs #-} + +-- | Get the association list of the vector. +getAssocs' :: (RVector v, Storable e) => v e -> ST s [(Int,e)] +getAssocs' x = liftM2 zip (getIndices x) (getElems' x) +{-# INLINE getAssocs' #-} + +-- | Set all of the values of the vector from the elements in the list. +setElems :: (Storable e) => STVector s e -> [e] -> ST s () +setElems x es = let + go n [] i _ | i < n = error $ + printf ("setElems " + ++ " :" + ++ " not enough elements") n i + go n (_:_) i _ | i == n = error $ + printf ("setElems " + ++ " :" + ++ " too many elements") n (i+1) + go _ [] _ _ = return () + go n (f:fs) i p = do + poke p f + go n fs (i+1) (p `advancePtr` 1) + + in do + n <- getDim x + unsafeIOToST $ unsafeWith x $ go n es 0 + +-- | Set the given values in the vector. If an index is repeated twice, +-- the value is implementation-defined. +setAssocs :: (Storable e) => STVector s e -> [(Int,e)] -> ST s () +setAssocs x ies = + let go n p ((i,e):ies') = do + when (i < 0 || i >= n) $ error $ + printf ("setAssocs " + ++ " [ ..., (%d,_), ... ]: invalid index") n i + pokeElemOff p i e + go n p ies' + go _ _ [] = return () + in do + n <- getDim x + unsafeIOToST $ unsafeWith x $ \p -> go n p ies + +unsafeSetAssocs :: (Storable e) => STVector s e -> [(Int,e)] -> ST s () +unsafeSetAssocs x ies = + let go p ((i,e):ies') = do + pokeElemOff p i e + go p ies' + go _ [] = return () + in unsafeIOToST $ unsafeWith x $ \p -> go p ies + +-- | Get the element stored at the given index. +read :: (RVector v, Storable e) => v e -> Int -> ST s e +read x i = do + n <- getDim x + when (i < 0 || i >= n) $ error $ + printf ("read %d:" + ++ " invalid index") n i + unsafeRead x i +{-# SPECIALIZE INLINE read :: STVector s Double -> Int -> ST s (Double) #-} +{-# SPECIALIZE INLINE read :: STVector s (Complex Double) -> Int -> ST s (Complex Double) #-} + +-- | Same as 'read' but does not range check the index. +unsafeRead :: (RVector v, Storable e) => v e -> Int -> ST s e +unsafeRead x i = + unsafeIOToST $ unsafeWith x $ \p -> peekElemOff p i +{-# SPECIALIZE INLINE unsafeRead :: STVector s Double -> Int -> ST s (Double) #-} +{-# SPECIALIZE INLINE unsafeRead :: STVector s (Complex Double) -> Int -> ST s (Complex Double) #-} + +-- | Set the element stored at the given index. +write :: (Storable e) => STVector s e -> Int -> e -> ST s () +write x i e = do + n <- getDim x + when (i < 0 || i >= n) $ error $ + printf ("write %d:" + ++ " invalid index") n i + unsafeWrite x i e +{-# SPECIALIZE INLINE write :: STVector s Double -> Int -> Double -> ST s () #-} +{-# SPECIALIZE INLINE write :: STVector s (Complex Double) -> Int -> Complex Double -> ST s () #-} + +-- | Same as 'write' but does not range check the index. +unsafeWrite :: (Storable e) => STVector s e -> Int -> e -> ST s () +unsafeWrite x i e = + unsafeIOToST $ unsafeWith x $ \p -> pokeElemOff p i e +{-# SPECIALIZE INLINE unsafeWrite :: STVector s Double -> Int -> Double -> ST s () #-} +{-# SPECIALIZE INLINE unsafeWrite :: STVector s (Complex Double) -> Int -> Complex Double -> ST s () #-} + +-- | Modify the element stored at the given index. +modify :: (Storable e) => STVector s e -> Int -> (e -> e) -> ST s () +modify x i f = do + n <- getDim x + when (i < 0 || i >= n) $ error $ + printf ("modify %d:" + ++ " invalid index") n i + unsafeModify x i f +{-# SPECIALIZE INLINE modify :: STVector s Double -> Int -> (Double -> Double) -> ST s () #-} +{-# SPECIALIZE INLINE modify :: STVector s (Complex Double) -> Int -> (Complex Double -> Complex Double) -> ST s () #-} + +-- | Same as 'modify' but does not range check the index. +unsafeModify :: (Storable e) => STVector s e -> Int -> (e -> e) -> ST s () +unsafeModify x i f = + unsafeIOToST $ unsafeWith x $ \p -> do + e <- peekElemOff p i + pokeElemOff p i $ f e +{-# SPECIALIZE INLINE unsafeModify :: STVector s Double -> Int -> (Double -> Double) -> ST s () #-} +{-# SPECIALIZE INLINE unsafeModify :: STVector s (Complex Double) -> Int -> (Complex Double -> Complex Double) -> ST s () #-} + +unsafeSwapElems :: (Storable e) => STVector s e -> Int -> Int -> ST s () +unsafeSwapElems x i1 i2 = unsafeIOToST $ unsafeWith x $ \p -> + let p1 = p `advancePtr` i1 + p2 = p `advancePtr` i2 + in do + e1 <- peek p1 + e2 <- peek p2 + poke p2 e1 + poke p1 e2 +{-# SPECIALIZE INLINE unsafeSwapElems :: STVector s Double -> Int -> Int -> ST s () #-} +{-# SPECIALIZE INLINE unsafeSwapElems :: STVector s (Complex Double) -> Int -> Int -> ST s () #-} + +-- | @mapTo dst f src@ replaces @dst@ elementwise with @f(src)@. +mapTo :: (RVector v, Storable e, Storable f) + => STVector s f + -> (e -> f) + -> v e + -> ST s () +mapTo dst f src = (checkOp2 "mapTo _" $ \z x -> unsafeMapTo z f x) dst src +{-# INLINE mapTo #-} + +-- | Same as 'mapTo' but does not check dimensions. +unsafeMapTo :: (RVector v, Storable e, Storable f) + => STVector s f + -> (e -> f) + -> v e + -> ST s () +unsafeMapTo dst f src = + let go end pdst psrc + | pdst == end = + return () + | otherwise = do + e <- peek psrc + poke pdst (f e) + go end (pdst `advancePtr` 1) (psrc `advancePtr` 1) + in do + ndst <- getDim dst + unsafeIOToST $ + unsafeWith dst $ \pdst -> + unsafeWith src $ \psrc -> + go (pdst `advancePtr` ndst) pdst psrc + where + +{-# INLINE unsafeMapTo #-} + +-- | @zipWithTo dst f x y@ replaces @dst@ elementwise with @f(x,y)@. +zipWithTo :: (RVector v1, RVector v2, Storable e1, Storable e2, Storable f) + => STVector s f + -> (e1 -> e2 -> f) + -> v1 e1 + -> v2 e2 + -> ST s () +zipWithTo dst f x y = + (checkOp3 "zipWithTo _" $ \dst1 x1 y1 -> unsafeZipWithTo dst1 f x1 y1) + dst x y +{-# INLINE zipWithTo #-} + +-- | Same as 'zipWithTo' but does not range-check dimensions. +unsafeZipWithTo :: (RVector v1, RVector v2, Storable e1, Storable e2, Storable f) + => STVector s f + -> (e1 -> e2 -> f) + -> v1 e1 + -> v2 e2 + -> ST s () +unsafeZipWithTo dst f src1 src2 = + let go end pdst psrc1 psrc2 + | pdst == end = + return () + | otherwise = do + e1 <- peek psrc1 + e2 <- peek psrc2 + poke pdst (f e1 e2) + go end (pdst `advancePtr` 1) (psrc1 `advancePtr` 1) + (psrc2 `advancePtr` 1) + in do + ndst <- getDim dst + unsafeIOToST $ + unsafeWith dst $ \pdst -> + unsafeWith src1 $ \psrc1 -> + unsafeWith src2 $ \psrc2 -> + go (pdst `advancePtr` ndst) pdst psrc1 psrc2 +{-# INLINE unsafeZipWithTo #-} + + +-- | Set every element in the vector to a default value. For +-- standard numeric types (including 'Double', 'Complex Double', and 'Int'), +-- the default value is '0'. +clear :: (Storable e) => STVector s e -> ST s () +clear x = do + n <- getDim x + unsafeIOToST $ unsafeWith x $ \p -> clearArray p n + +-- | @negateTo dst x@ replaces @dst@ with @negate(x)@. +negateTo :: (RVector v, VNum e) => STVector s e -> v e -> ST s () +negateTo = checkOp2 "negateTo" $ \dst x -> + call2 VMath.vNeg x dst +{-# INLINE negateTo #-} + +-- | @absTo dst x@ replaces @dst@ with @abs(x)@. +absTo :: (RVector v, VNum e) => STVector s e -> v e -> ST s () +absTo = checkOp2 "absTo" $ \dst x -> + call2 VMath.vAbs x dst +{-# INLINE absTo #-} + +-- | @signumTo dst x@ replaces @dst@ with @signum(x)@. +signumTo :: (RVector v, VNum e) => STVector s e -> v e -> ST s () +signumTo = checkOp2 "signumTo" $ \dst x -> + call2 VMath.vSgn x dst +{-# INLINE signumTo #-} + + +-- | @conjugateTo dst x@ replaces @dst@ with @conjugate(x)@. +conjugateTo :: (RVector v, VNum e) => STVector s e -> v e -> ST s () +conjugateTo = checkOp2 "conjugateTo" $ \dst x -> + call2 VMath.vConj x dst +{-# INLINE conjugateTo #-} + +-- | @addTo dst x y@ replaces @dst@ with @x+y@. +addTo :: (RVector v1, RVector v2, VNum e) + => STVector s e -> v1 e -> v2 e -> ST s () +addTo = checkOp3 "addTo" $ \dst x y -> call3 VMath.vAdd x y dst +{-# INLINE addTo #-} + +-- | @subTo dst x y@ replaces @dst@ with @x-y@. +subTo :: (RVector v1, RVector v2, VNum e) + => STVector s e -> v1 e -> v2 e -> ST s () +subTo = checkOp3 "subTo" $ \dst x y -> call3 VMath.vSub x y dst +{-# INLINE subTo #-} + +-- | @mulTo dst x y@ replaces @dst@ with @x*y@. +mulTo :: (RVector v1, RVector v2, VNum e) + => STVector s e -> v1 e -> v2 e -> ST s () +mulTo = checkOp3 "mulTo" $ \dst x y -> call3 VMath.vMul x y dst +{-# INLINE mulTo #-} + +-- | @divTo dst x y@ replaces @dst@ with @x/y@. +divTo :: (RVector v1, RVector v2, VFractional e) + => STVector s e -> v1 e -> v2 e -> ST s () +divTo = checkOp3 "divTo" $ \dst x y -> call3 VMath.vDiv x y dst +{-# INLINE divTo #-} + +-- | @recipTo dst x@ replaces @dst@ with @1/x@. +recipTo :: (RVector v, VFractional e) + => STVector s e -> v e -> ST s () +recipTo = checkOp2 "recipTo" $ \dst x -> call2 VMath.vInv x dst +{-# INLINE recipTo #-} + +-- | @sqrtTo dst x@ replaces @dst@ with @sqrt(x)@. +sqrtTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +sqrtTo = checkOp2 "sqrtTo" $ \dst x -> call2 VMath.vSqrt x dst +{-# INLINE sqrtTo #-} + +-- | @expTo dst x@ replaces @dst@ with @exp(x)@. +expTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +expTo = checkOp2 "expTo" $ \dst x -> call2 VMath.vExp x dst +{-# INLINE expTo #-} + +-- | @logTo dst x@ replaces @dst@ with @log(x)@. +logTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +logTo = checkOp2 "logTo" $ \dst x -> call2 VMath.vLog x dst +{-# INLINE logTo #-} + +-- | @powTo dst x y@ replaces @dst@ with @x ** y@. +powTo :: (RVector v1, RVector v2, VFloating e) + => STVector s e -> v1 e -> v2 e -> ST s () +powTo = checkOp3 "powTo" $ \dst x y -> call3 VMath.vPow x y dst +{-# INLINE powTo #-} + +-- | @sinTo dst x@ replaces @dst@ with @sin(x)@. +sinTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +sinTo = checkOp2 "sinTo" $ \dst x -> call2 VMath.vSin x dst +{-# INLINE sinTo #-} + +-- | @cosTo dst x@ replaces @dst@ with @cos(x)@. +cosTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +cosTo = checkOp2 "cosTo" $ \dst x -> call2 VMath.vCos x dst +{-# INLINE cosTo #-} + +-- | @tanTo dst x@ replaces @dst@ with @tan(x)@. +tanTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +tanTo = checkOp2 "tanTo" $ \dst x -> call2 VMath.vTan x dst +{-# INLINE tanTo #-} + +-- | @asinTo dst x@ replaces @dst@ with @asin(x)@. +asinTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +asinTo = checkOp2 "asinTo" $ \dst x -> call2 VMath.vASin x dst +{-# INLINE asinTo #-} + +-- | @acosTo dst x@ replaces @dst@ with @acos(x)@. +acosTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +acosTo = checkOp2 "acosTo" $ \dst x -> call2 VMath.vACos x dst +{-# INLINE acosTo #-} + +-- | @atanTo dst x@ replaces @dst@ with @atan(x)@. +atanTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +atanTo = checkOp2 "atanTo" $ \dst x -> call2 VMath.vATan x dst +{-# INLINE atanTo #-} + +-- | @sinhTo dst x@ replaces @dst@ with @sinh(x)@. +sinhTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +sinhTo = checkOp2 "sinhTo" $ \dst x -> call2 VMath.vSinh x dst +{-# INLINE sinhTo #-} + +-- | @coshTo dst x@ replaces @dst@ with @cosh(x)@. +coshTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +coshTo = checkOp2 "coshTo" $ \dst x -> call2 VMath.vCosh x dst +{-# INLINE coshTo #-} + +-- | @tanhTo dst x@ replaces @dst@ with @tanh(x)@. +tanhTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +tanhTo = checkOp2 "tanhTo" $ \dst x -> call2 VMath.vTanh x dst +{-# INLINE tanhTo #-} + +-- | @asinhTo dst x@ replaces @dst@ with @asinh(x)@. +asinhTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +asinhTo = checkOp2 "asinhTo" $ \dst x -> call2 VMath.vASinh x dst +{-# INLINE asinhTo #-} + +-- | @acoshTo dst x@ replaces @dst@ with @acosh(x)@. +acoshTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +acoshTo = checkOp2 "acoshTo" $ \dst x -> call2 VMath.vACosh x dst +{-# INLINE acoshTo #-} + +-- | @atanhTo dst x@ replaces @dst@ with @atanh(x)@. +atanhTo :: (RVector v, VFloating e) => STVector s e -> v e -> ST s () +atanhTo = checkOp2 "atanhTo" $ \dst x -> call2 VMath.vATanh x dst +{-# INLINE atanhTo #-} + + +-- | Gets the sum of the absolute values of the vector entries. +getSumAbs :: (RVector v, BLAS1 e) => v e -> ST s Double +getSumAbs = strideCall BLAS.asum +{-# INLINE getSumAbs #-} + +-- | Gets the 2-norm of a vector. +getNorm2 :: (RVector v, BLAS1 e) => v e -> ST s Double +getNorm2 = strideCall BLAS.nrm2 +{-# INLINE getNorm2 #-} + +-- | Gets the index and norm of the element with maximum magnitude. This is +-- undefined if any of the elements are @NaN@. It will throw an exception if +-- the dimension of the vector is 0. +getWhichMaxAbs :: (RVector v, BLAS1 e) => v e -> ST s (Int, e) +getWhichMaxAbs x = do + n <- getDim x + when (n == 0) $ error $ + "getWhichMaxAbs : empty vector" + + i <- strideCall BLAS.iamax x + e <- unsafeRead x i + return (i,e) +{-# INLINE getWhichMaxAbs #-} + +-- | Computes the dot product of two vectors. +getDot :: (RVector v, RVector v', BLAS1 e) + => v e -> v' e -> ST s e +getDot = checkOp2 "getDot" unsafeGetDot +{-# INLINE getDot #-} + +-- | Same as 'getDot' but does not check dimensions. +unsafeGetDot :: (RVector x, RVector y, BLAS1 e) + => x e -> y e -> ST s e +unsafeGetDot x y = (strideCall2 BLAS.dotc) y x +{-# INLINE unsafeGetDot #-} + +-- | @scaleM k x@ sets @x := k * x@. +scaleM_ :: (Storable e, BLAS1 e) => e -> STVector s e -> ST s () +scaleM_ k x = do + n <- getDim x + unsafeIOToST $ + unsafeWith x $ \px -> + BLAS.scal n k px 1 +{-# INLINE scaleM_ #-} + +-- | @addWithScaleM_ alpha x y@ sets @y := alpha * x + y@. +addWithScaleM_ :: (RVector v, BLAS1 e) => e -> v e -> STVector s e -> ST s () +addWithScaleM_ alpha x y = + (checkOp2 "addWithScaleM_" $ \x1 y1 -> unsafeAddWithScaleM_ alpha x1 y1) + x y +{-# INLINE addWithScaleM_ #-} + +-- | Same as 'addWithScaleM_' but does not check dimensions. +unsafeAddWithScaleM_ :: (RVector v, BLAS1 e) + => e -> v e -> STVector s e -> ST s () +unsafeAddWithScaleM_ alpha x y = + (strideCall2 $ flip BLAS.axpy alpha) x y +{-# INLINE unsafeAddWithScaleM_ #-} + +-- | @kroneckerTo dst x y@ sets @dst := x \otimes y@. +kroneckerTo :: (RVector v1, RVector v2, BLAS2 e) + => STVector s e -> v1 e -> v2 e -> ST s () +kroneckerTo dst x y = do + m <- getDim x + n <- getDim y + dimdst <- getDim dst + + when (dimdst /= m * n) $ error $ + printf ("kroneckerTo" + ++ " " + ++ " " + ++ " :" + ++ " dimension mismatch") dimdst m n + + clear dst + unsafeIOToST $ + unsafeWith dst $ \pdst -> + unsafeWith x $ \px -> + unsafeWith y $ \py -> + BLAS.geru n m 1 py 1 px 1 pdst (max n 1) + +call2 :: (RVector x, RVector y, Storable e, Storable f) + => (Int -> Ptr e -> Ptr f -> IO a) + -> x e -> y f -> ST s a +call2 f x y = do + n <- getDim x + unsafeIOToST $ + unsafeWith x $ \pX -> + unsafeWith y $ \pY -> + f n pX pY +{-# INLINE call2 #-} + +call3 :: (RVector x, RVector y, RVector z, Storable e, Storable f, Storable g) + => (Int -> Ptr e -> Ptr f -> Ptr g -> IO a) + -> x e -> y f -> z g -> ST s a +call3 f x y z = do + n <- getDim x + unsafeIOToST $ + unsafeWith x $ \pX -> + unsafeWith y $ \pY -> + unsafeWith z $ \pZ -> + f n pX pY pZ +{-# INLINE call3 #-} + +strideCall :: (RVector x, Storable e) + => (Int -> Ptr e -> Int -> IO a) + -> x e -> ST s a +strideCall f x = do + n <- getDim x + unsafeIOToST $ + unsafeWith x $ \pX -> + f n pX incX + where + incX = 1 +{-# INLINE strideCall #-} + +strideCall2 :: (RVector x, RVector y, Storable e, Storable f) + => (Int -> Ptr e -> Int -> Ptr f -> Int -> IO a) + -> x e -> y f -> ST s a +strideCall2 f x y = do + n <- getDim x + unsafeIOToST $ + unsafeWith x $ \pX -> + unsafeWith y $ \pY -> + f n pX incX pY incY + where + incX = 1 + incY = 1 +{-# INLINE strideCall2 #-} + +checkOp2 :: (RVector x, RVector y, Storable e, Storable f) + => String + -> (x e -> y f -> ST s a) + -> x e + -> y f + -> ST s a +checkOp2 str f x y = do + n1 <- getDim x + n2 <- getDim y + + when (n1 /= n2) $ error $ + printf ("%s :" + ++ " dimension mismatch") str n1 n2 + + f x y +{-# INLINE checkOp2 #-} + +checkOp3 :: (RVector x, RVector y, RVector z, Storable e, Storable f, Storable g) + => String + -> (x e -> y f -> z g -> ST s a) + -> x e + -> y f + -> z g + -> ST s a +checkOp3 str f x y z = do + n1 <- getDim x + n2 <- getDim y + n3 <- getDim z + + when (n1 /= n2 || n1 /= n3) $ error $ + printf ("%s " + ++ " :" + ++ " dimension mismatch") str n1 n2 n3 + + f x y z +{-# INLINE checkOp3 #-} + diff --git a/lib/Numeric/LinearAlgebra/Vector/Statistics.hs b/lib/Numeric/LinearAlgebra/Vector/Statistics.hs new file mode 100644 --- /dev/null +++ b/lib/Numeric/LinearAlgebra/Vector/Statistics.hs @@ -0,0 +1,121 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Numeric.LinearAlgebra.Vector.Statistics +-- Copyright : Copyright (c) 2010, Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- Basic multivariate statistics. +-- + +module Numeric.LinearAlgebra.Vector.Statistics ( + -- * Immutable interface + sum, + mean, + weightedSum, + weightedMean, + + -- * Mutable interface + addSumTo, + meanTo, + addWeightedSumTo, + weightedMeanTo, + + ) where + +import Prelude hiding ( sum ) + +import Control.Monad( forM_ ) +import Control.Monad.ST( ST ) + +import Numeric.LinearAlgebra.Types + +import Numeric.LinearAlgebra.Vector.Base( Vector ) +import Numeric.LinearAlgebra.Vector.STBase( RVector, STVector ) +import qualified Numeric.LinearAlgebra.Vector.STBase as V + + +-- | Returns the sum of the vectors. The first argument gives the dimension +-- of the vectors. +sum :: (BLAS1 e) => Int -> [Vector e] -> Vector e +sum p xs = V.create $ do + s <- V.new_ p + V.clear s + addSumTo s xs + return s + +-- | Returns the mean of the vectors. The first argument gives the dimension +-- of the vectors. +mean :: (BLAS1 e) => Int -> [Vector e] -> Vector e +mean p xs = V.create $ do + m <- V.new_ p + meanTo m xs + return m + +-- | Returns the weighted sum of the vectors. The first argument gives the +-- dimension of the vectors. +weightedSum :: (BLAS1 e) => Int -> [(e, Vector e)] -> Vector e +weightedSum p wxs = V.create $ do + s <- V.new_ p + V.clear s + addWeightedSumTo s wxs + return s + +-- | Returns the weighted mean of the vectors. The first argument gives the +-- dimension of the vectors. +weightedMean :: (BLAS1 e) + => Int -> [(Double, Vector e)] -> Vector e +weightedMean p wxs = V.create $ do + m <- V.new_ p + weightedMeanTo m wxs + return m + +-- | Adds the sum of the vectors to the target vector. +addSumTo :: (RVector v, BLAS1 e) => STVector s e -> [v e] -> ST s () +addSumTo dst = addWeightedSumTo dst . zip (repeat 1) + +-- | Sets the target vector to the mean of the vectors. +meanTo :: (RVector v, BLAS1 e) + => STVector s e -> [v e] -> ST s() +meanTo dst = weightedMeanTo dst . zip (repeat 1) + +-- | Adds the weigthed sum of the vectors to the target vector. +addWeightedSumTo :: (RVector v, BLAS1 e) + => STVector s e -> [(e, v e)] -> ST s () +addWeightedSumTo s wxs = do + n <- V.getDim s + err <- V.new n 0 + old_s <- V.new_ n + diff <- V.new_ n + val <- V.new_ n + + forM_ wxs $ \(w,x) -> do + V.unsafeCopyTo old_s s -- old_s := s + + V.unsafeCopyTo val x -- val := w * x + V.scaleM_ w val + + V.addTo err err val -- err := err + val + V.addTo s s err -- s := s + err + + V.subTo diff old_s s -- diff := old_s - s + V.addTo err diff val -- err := diff + val + +-- | Sets the target vector to the weighted mean of the vectors. +weightedMeanTo :: (RVector v, BLAS1 e) + => STVector s e -> [(Double, v e)] -> ST s () +weightedMeanTo m wxs = let + go _ _ [] = return () + go diff w_sum ((w,x):wxs') | w == 0 = go diff w_sum wxs' + | otherwise = let w_sum' = w_sum + w + in do + V.subTo diff x m + V.addWithScaleM_ + (realToFrac $ w/w_sum') diff m + go diff w_sum' wxs' + in do + n <- V.getDim m + diff <- V.new_ n + V.clear m + go diff 0 wxs diff --git a/lib/Test/QuickCheck/LinearAlgebra.hs b/lib/Test/QuickCheck/LinearAlgebra.hs new file mode 100644 --- /dev/null +++ b/lib/Test/QuickCheck/LinearAlgebra.hs @@ -0,0 +1,511 @@ +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Test.QuickCheck.LinearAlgebra +-- Copyright : Copyright (c) , Patrick Perry +-- License : BSD3 +-- Maintainer : Patrick Perry +-- Stability : experimental +-- +-- +-- Test generators for linear algebra types. +-- + +module Test.QuickCheck.LinearAlgebra ( + -- Testable element types + TestElem(..), + + -- * Generating random objects + -- ** Dimensions + dim, + dim2, + Dim(..), + Dim2(..), + + -- ** Indices + index, + index2, + Index(..), + Index2(..), + + -- ** Elements + elem, + elems, + -- realElem, + -- realElems, + + -- ** Association lists + assocs, + assocs2, + Assocs(..), + Assocs2(..), + -- bandedAssocs, + + -- ** Vectors + vector, + VectorPair(..), + VectorTriple(..), + VectorList(..), + WeightedVectorList(..), + NonEmptyVectorList(..), + NonEmptyWeightedVectorList(..), + + -- ** Matrices + matrix, + MatrixPair(..), + MatrixTriple(..), + -- hermMatrix, + -- triMatrix, + + -- Banded matrices + -- bandwidths, + -- banded, + -- bandedWith, + -- hermBanded, + -- triBanded, + + -- BandedAssocs(..), + + ) where + +import Prelude hiding ( elem ) + +-- import BLAS.Types( UpLoEnum(..), DiagEnum(..) ) +import Control.Monad +import Data.Complex( magnitude ) +import Data.Maybe( fromJust ) + +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra.Types +import Numeric.LinearAlgebra.Vector( Vector ) +import qualified Numeric.LinearAlgebra.Vector as V +import Numeric.LinearAlgebra.Matrix( Matrix ) +import qualified Numeric.LinearAlgebra.Matrix as M +-- import Data.Matrix.Banded( Banded, maybeBandedFromMatrixStorage ) +-- import Data.Matrix.Banded.ST( runSTBanded, unsafeThawBanded, +-- diagViewBanded ) + + +class TestElem e where + maybeToReal :: e -> Maybe Double + toReal :: e -> Double + norm1 :: e -> Double + norm :: e -> Double + conjugate :: e -> e + + toReal = fromJust . maybeToReal + +instance (TestElem Double) where + maybeToReal = Just + toReal = id + norm1 = abs + norm = abs + conjugate = id + +instance (TestElem (Complex Double)) where + maybeToReal (x :+ y) | y == 0 = Just x + | otherwise = Nothing + norm1 (x :+ y) = abs x + abs y + norm z = magnitude z + conjugate (x :+ y) = x :+ (-y) + +{- +-- | Element types that can be tested with QuickCheck properties. +class (Storable e, Arbitrary e, CoArbitrary e) => TestElem e where + -- | Inicates whether or not the value should be used in tests. For + -- 'Double's, @isTestElem e@ is defined as + -- @not (isNaN e || isInfinite e || isDenormalized e)@. + isTestElem :: e -> Bool + +instance TestElem Double where + isTestElem e = not (isNaN e || isInfinite e || isDenormalized e) + {-# INLINE isTestElem #-} + +instance TestElem (Complex Double) where + isTestElem (x :+ y) = isTestElem x && isTestElem y + {-# INLINE isTestElem #-} +-} + +minit:: Int ->Int +minit n= n `mod` 20 + +-- | Generate a random element. +elem :: (Arbitrary e) => Gen e +elem = arbitrary + +-- | Generate a list of elements suitable for testing with. +elems :: (Arbitrary e) => Int -> Gen [e] +elems n = replicateM n elem + +-- Generate a random element that has no imaginary part. +-- realElem :: (TestElem e) => Gen e +-- realElem = liftM fromReal elem + +-- Generate a list of elements for testing that have no imaginary part. +-- realElems :: (TestElem e) => Int -> Gen [e] +-- realElems n = replicateM n realElem + +-- | Get an appropriate dimension for a random vector +dim :: Gen Int +dim = sized $ \s -> do + (NonNegative n) <- resize (s `div` 4) $ arbitrary + return (minit n) + +-- | Get an appropriate dimension for a random matrix +dim2 :: Gen (Int,Int) +dim2 = sized $ \s -> do + m <- resize (s `div` 2) $ dim + n <- resize (s `div` 2) $ dim + return (m,n) + +-- | A vector dimension. +newtype Dim = Dim Int + deriving (Eq, Ord, Num, Integral, Real, Enum, Show, Read) + +instance Arbitrary Dim where + arbitrary = sized $ \s -> do + (NonNegative n) <- resize (s `div` 4) $ arbitrary + return $ Dim n + + shrink (Dim a) = + [ Dim a' | (NonNegative a') <- shrink (NonNegative a) ] + +-- | A matrix dimension. +newtype Dim2 = Dim2 (Int,Int) + deriving (Eq, Show, Read) + +instance Arbitrary Dim2 where + arbitrary = do + mn <- dim2 + return $ Dim2 mn + + +-- | Given a dimension generate a valid index. The dimension must be positive. +index :: Int -> Gen Int +index n | n <= 0 = + error $ "index " ++ (show n) ++ ":" + ++ " dimension must be positive (QuickCheck error)" + | otherwise = + choose (0,n-1) + +-- | Given a matrix dimension generate a valid index. +index2 :: (Int,Int) -> Gen (Int,Int) +index2 (m,n) = do + i <- index m + j <- index n + return (i,j) + +-- | A dimension and a valid index for it. +data Index = Index Int Int deriving (Eq,Show) +instance Arbitrary Index where + arbitrary = do + n <- (1+) `fmap` dim + i <- index n + return $ Index n i + +-- | A matrix dimension and a valid index for it. +data Index2 = Index2 (Int,Int) (Int,Int) deriving (Eq,Show) +instance Arbitrary Index2 where + arbitrary = do + (m',n') <- dim2 + let mn = (m' + 1, n' + 1) + ij <- index2 mn + return $ Index2 mn ij + + +-- | Generate an associations list for a vector of the given dimension. +assocs :: (Arbitrary e) => Int -> Gen [(Int,e)] +assocs n | n == 0 = return [] + | otherwise = do + l <- choose(0, 2*n) + is <- replicateM l $ index n + es <- elems l + return $ zip is es + +-- | Generate an associations list for a matrix of the given shape. +assocs2 :: (Arbitrary e) => (Int,Int) -> Gen [((Int,Int),e)] +assocs2 (m,n) | m*n == 0 = return [] + | otherwise = do + l <- choose(0, 2*m*n) + is <- replicateM l $ index2 (m,n) + es <- elems l + return $ zip is es + + +-- | A dimension and an associations list. +data Assocs e = Assocs Int [(Int,e)] deriving (Eq,Show) + +instance (Arbitrary e) => Arbitrary (Assocs e) where + arbitrary = do + n <- dim + ies <- assocs n + return $ Assocs n ies + + shrink (Assocs n ies) = + [ Assocs n' $ filter ((< n') . fst) ies + | n' <- shrink n + ] ++ + [ Assocs n ies' + | ies' <- shrink ies + ] + +-- | A shape and an associations list. +data Assocs2 e = Assocs2 (Int,Int) [((Int,Int),e)] deriving (Eq,Show) +instance (Arbitrary e) => Arbitrary (Assocs2 e) where + arbitrary = do + mn <- dim2 + ies <- assocs2 mn + return $ Assocs2 mn ies + + +-- | Generate a random vector of the given size. +vector :: (Arbitrary e, Storable e) => Int -> Gen (Vector e) +vector n = do + es <- elems n + return $ V.fromList n es + +instance (Arbitrary e, Storable e) => Arbitrary (Vector e) where + arbitrary = dim >>= vector + + shrink x = + [ V.slice 0 n x + | (NonNegative n) <- shrink (NonNegative $ V.dim x) + ] + +-- | Two vectors with the same dimension. +data VectorPair e f = + VectorPair (Vector e) (Vector f) deriving (Eq, Show) +instance (Arbitrary e, Storable e, Arbitrary f, Storable f) => + Arbitrary (VectorPair e f) where + arbitrary = do + x <- arbitrary + y <- vector (V.dim x) + return $ VectorPair x y + + shrink (VectorPair x y) = + [ VectorPair (V.slice 0 n' x) (V.slice 0 n' y) + | n' <- shrink (V.dim x) + ] + +-- | Three vectors with the same dimension. +data VectorTriple e f g = + VectorTriple (Vector e) (Vector f) (Vector g) deriving (Eq, Show) +instance (Arbitrary e, Storable e, Arbitrary f, Storable f, + Arbitrary g, Storable g) => + Arbitrary (VectorTriple e f g) where + arbitrary = do + x <- arbitrary + y <- vector (V.dim x) + z <- vector (V.dim x) + return $ VectorTriple x y z + +-- | A nonempty list of vectors with the same dimension. +data NonEmptyVectorList e = NonEmptyVectorList Int [Vector e] deriving (Eq, Show) +instance (Arbitrary e, Storable e) => Arbitrary (NonEmptyVectorList e) where + arbitrary = do + x <- arbitrary + n <- choose (0,20) + let p = V.dim x + xs <- replicateM n $ vector p + return $ NonEmptyVectorList p $ x:xs + +-- | A nonempty list of (weight, vector) pairs, with the weights all non-negative +-- and the vectors all having the same dimension. +data NonEmptyWeightedVectorList e = NonEmptyWeightedVectorList Int [(e, Vector e)] + deriving (Eq, Show) +instance (Arbitrary e, Storable e, Num e) => Arbitrary (NonEmptyWeightedVectorList e) where + arbitrary = do + (NonEmptyVectorList p xs) <- arbitrary + ws <- replicateM (length xs) $ fmap abs arbitrary + return $ NonEmptyWeightedVectorList p $ zip ws xs + +-- | A list of vectors with the same dimension. +data VectorList e = VectorList Int [Vector e] deriving (Eq, Show) +instance (Arbitrary e, Storable e) => Arbitrary (VectorList e) where + arbitrary = do + (NonEmptyVectorList p (_:xs)) <- arbitrary + return $ VectorList p xs + +-- | A list of (weight, vector) pairs, with the weights all non-negative +-- and the vectors all having the same dimension. +data WeightedVectorList e = WeightedVectorList Int [(e, Vector e)] + deriving (Eq, Show) +instance (Arbitrary e, Storable e, Num e) => Arbitrary (WeightedVectorList e) where + arbitrary = do + (NonEmptyWeightedVectorList p (_:wxs)) <- arbitrary + return $ WeightedVectorList p wxs + +-- | Generate a random matrix of the given size. +matrix :: (Arbitrary e, Storable e) => (Int,Int) -> Gen (Matrix e) +matrix (m,n) = + oneof [ raw, sub ] + where + raw = do + es <- elems $ m * n + return $ M.fromList (m,n) es + sub = do + m' <- choose (m, 2*m) + es <- elems $ m' * n + return $ M.slice (0,0) (m,n) (M.fromList (m',n) es) + +instance (Arbitrary e, Storable e) => Arbitrary (Matrix e) where + arbitrary = dim2 >>= matrix + +-- | Two matrices with the same dimension. +data MatrixPair e f = + MatrixPair (Matrix e) (Matrix f) deriving (Eq, Show) +instance (Arbitrary e, Storable e, Arbitrary f, Storable f) => + Arbitrary (MatrixPair e f) where + arbitrary = do + x <- arbitrary + y <- matrix (M.dim x) + return $ MatrixPair x y + +-- | Three matrices with the same dimension. +data MatrixTriple e f g = + MatrixTriple (Matrix e) (Matrix f) (Matrix g) deriving (Eq, Show) +instance (Arbitrary e, Storable e, Arbitrary f, Storable f, + Arbitrary g, Storable g) => + Arbitrary (MatrixTriple e f g) where + arbitrary = do + x <- arbitrary + y <- matrix (M.dim x) + z <- matrix (M.dim x) + return $ MatrixTriple x y z + +instance Arbitrary Trans where + arbitrary = elements [ NoTrans, Trans, ConjTrans ] +{- + +-- | Generate a triangular dense matrix. +triMatrix :: (TestElem e) => (Int,Int) -> Gen (Tri Matrix e) +triMatrix (m,n) = do + a <- matrix (m,n) + u <- QC.elements [ Lower, Upper ] + d <- QC.elements [ Unit, NonUnit ] + return $ Tri u d a + +-- | Generate a Hermitian dense matrix. +hermMatrix :: (TestElem e) => Int -> Gen (Herm Matrix e) +hermMatrix n = do + a <- matrix (n,n) + d <- realElems n + let a' = runSTMatrix $ do + ma <- unsafeThawMatrix a + setElems (diagView ma 0) d + return ma + u <- QC.elements [ Lower, Upper ] + return $ Herm u a' + +rawMatrix :: (TestElem e) => (Int,Int) -> Gen (Matrix e) +rawMatrix (m,n) = do + es <- elems (m*n) + return $ M.fromList (m,n) es + + +subMatrix :: (TestElem e) => (Int,Int) -> Gen (SubMatrix e) +subMatrix (m,n) = + oneof [ rawSubMatrix (m,n) + , rawSubMatrix (n,m) >>= \(SubMatrix a (i,j) (m',n')) -> + return $ SubMatrix (herm a) (j,i) (n',m') + ] + +rawSubMatrix :: (TestElem e) => (Int,Int) -> Gen (SubMatrix e) +rawSubMatrix (m,n) = do + i <- choose (0,5) + j <- choose (0,5) + e <- choose (0,5) + f <- choose (0,5) + x <- rawMatrix (i+m+e, j+n+f) + return $ SubMatrix x (i,j) (m,n) + +instance (TestElem e) => Arbitrary (SubMatrix e) where + arbitrary = do + (m,n) <- shape + (SubMatrix a ij mn) <- subMatrix (m,n) + return $ SubMatrix a ij mn + +-- | Generate valid bandwidth for a given matrix dimension size +bandwidth :: Int -> Gen Int +bandwidth n = if n == 0 then return 0 else choose (0,n-1) + +-- | Generate valid bandwidths for the given matrix shape. +bandwidths :: (Int,Int) -> Gen (Int,Int) +bandwidths (m,n) = liftM2 (,) (bandwidth m) (bandwidth n) + +-- | Generate a random banded matrix of the given shape. +banded :: (TestElem e) => (Int,Int) -> Gen (Banded e) +banded mn = do + lu <- bandwidths mn + bandedWith lu mn + +-- | Generate a random banded matrix with the given bandwidths. +bandedWith :: (TestElem e) + => (Int,Int) -> (Int,Int) -> Gen (Banded e) +bandedWith lu mn = frequency [ (3, rawBanded mn lu) + , (2, hermedBanded mn lu) + ] + +-- | Generate a triangular banded matrix. +triBanded :: (TestElem e) => Int -> Gen (Tri Banded e) +triBanded n = do + a <- banded (n,n) + u <- QC.elements [ Lower, Upper ] + d <- QC.elements [ Unit, NonUnit ] + return $ Tri u d a + +-- | Generate a Hermitian banded matrix. +hermBanded :: (TestElem e) => Int -> Gen (Herm Banded e) +hermBanded n = do + a <- banded (n,n) + d <- realElems n + let a' = runSTBanded $ do + ma <- unsafeThawBanded a + setElems (diagViewBanded ma 0) d + return ma + u <- QC.elements [ Lower, Upper ] + return $ Herm u a' + +rawBanded :: (TestElem e) => + (Int,Int) -> (Int,Int) -> Gen (Banded e) +rawBanded (m,n) (kl,ku) = + let bw = kl+ku+1 + in do + a <- frequency [ (2, rawMatrix (bw,n)) + , (1, rawSubMatrix (bw,n) >>= \(SubMatrix b ij _) -> + return $ submatrix b ij (bw,n)) + ] + return $ fromJust (maybeBandedFromMatrixStorage (m,n) (kl,ku) a) + +hermedBanded :: (TestElem e) => + (Int,Int) -> (Int,Int) -> Gen (Banded e) +hermedBanded (m,n) (kl,ku) = do + x <- rawBanded (n,m) (ku,kl) + return $ herm x + +-- | Generate an associations list for a banded matrix of the given shape +-- and bandwidths. +bandedAssocs :: (TestElem e) => (Int,Int) -> (Int,Int) -> Gen [((Int,Int),e)] +bandedAssocs (m,n) (kl,ku) | m*n == 0 = return [] + | otherwise = do + (Nat l) <- arbitrary + ijs <- replicateM l $ index2 (kl+1+ku,n) + let ijs' = mapMaybe (\(i,j) -> let i' = i - j - ku in + if 0 <= i' && i' < m then Just (i',j) + else Nothing ) ijs + es <- replicateM l elem + return $ zip ijs' es + + +-- | A shape, bandwidths, and an associations list. +data BandedAssocs e = BandedAssocs (Int,Int) (Int,Int) [((Int,Int),e)] deriving (Eq,Show) +instance (TestElem e) => Arbitrary (BandedAssocs e) where + arbitrary = do + mn <- shape + bw <- bandwidths mn + ies <- bandedAssocs mn bw + return $ BandedAssocs mn bw ies +-} diff --git a/linear-algebra-cblas.cabal b/linear-algebra-cblas.cabal new file mode 100644 --- /dev/null +++ b/linear-algebra-cblas.cabal @@ -0,0 +1,146 @@ +name: linear-algebra-cblas +version: 0.1 +homepage: http://github.com/cartazio/hs-cblas +synopsis: A linear algebra library with bindings to BLAS and LAPACK +description: + Note There are some known bugs in this code, do not use it in production! + this package is meant mostly for easy cblas vs haskell benchmarks, not real use. + . + . + The BLAS (Basic Linear Algebra Subprograms) are routines that provide + standard building blocks for performing basic vector and matrix operations. + The Level 1 BLAS perform scalar, vector and vector-vector operations, the + Level 2 BLAS perform matrix-vector operations, and the Level 3 BLAS perform + matrix-matrix operations. Because the BLAS are efficient, portable, and + widely available, they are commonly used in the development of high quality + linear algebra software, LAPACK for example. + . + For more information, see the Netlib BLAS webpage: + + . +category: Math +license: BSD3 +license-file: COPYING +copyright: (c) 2010. Patrick Perry , Carter Schonwald 2012 +author: Patrick Perry, Carter Schonwald +maintainer: Carter Schonwald +cabal-version: >= 1.2.3 +build-type: Configure +tested-with: GHC == 7.6.2 + +extra-source-files: NEWS README TODO configure.ac configure + aclocal.m4 m4/ax_check_blas.m4 + m4/ax_check_lapack.m4 + linear-algebra.buildinfo.in cbits/config.h.in + tests/Makefile.in + + examples/LU.hs + + +extra-tmp-files: config.log config.status autom4te.cache + linear-algebra.buildinfo cbits/config.h + tests/Makefile + +Library + hs-source-dirs: lib + exposed-modules: + Foreign.BLAS + Foreign.LAPACK + Foreign.VMath + + Numeric.LinearAlgebra + + Numeric.LinearAlgebra.Matrix + Numeric.LinearAlgebra.Matrix.Cholesky + Numeric.LinearAlgebra.Matrix.Eigen + Numeric.LinearAlgebra.Matrix.Herm + Numeric.LinearAlgebra.Matrix.ST + Numeric.LinearAlgebra.Matrix.Statistics + Numeric.LinearAlgebra.Matrix.Tri + + Numeric.LinearAlgebra.Packed + Numeric.LinearAlgebra.Packed.Cholesky + Numeric.LinearAlgebra.Packed.Herm + Numeric.LinearAlgebra.Packed.ST + Numeric.LinearAlgebra.Packed.Statistics + Numeric.LinearAlgebra.Packed.Tri + + Numeric.LinearAlgebra.Vector + Numeric.LinearAlgebra.Vector.ST + Numeric.LinearAlgebra.Vector.Statistics + + Test.QuickCheck.LinearAlgebra + + other-modules: + Foreign.BLAS.Types + Foreign.BLAS.Level1 + Foreign.BLAS.Level2 + Foreign.BLAS.Level3 + Foreign.BLAS.Double + Foreign.BLAS.Zomplex + + Foreign.LAPACK.Types + Foreign.LAPACK.Double + Foreign.LAPACK.Zomplex + + Foreign.VMath.VNum + Foreign.VMath.VFractional + Foreign.VMath.VFloating + Foreign.VMath.Double + Foreign.VMath.Zomplex + + Numeric.LinearAlgebra.Types + Numeric.LinearAlgebra.Internal + Numeric.LinearAlgebra.Vector.Base + Numeric.LinearAlgebra.Vector.STBase + Numeric.LinearAlgebra.Matrix.Base + Numeric.LinearAlgebra.Matrix.STBase + Numeric.LinearAlgebra.Packed.Base + + includes: cbits/config.h + cbits/f77_func-hsc.h + cbits/vmath.h + include-dirs: cbits + + c-sources: cbits/vmath-double.c + cbits/vmath-zomplex.c + + ghc-options: -Wall -funbox-strict-fields + + extensions: BangPatterns, + CPP, + DeriveDataTypeable, + FlexibleContexts, + FlexibleInstances, + GeneralizedNewtypeDeriving, + ForeignFunctionInterface, + Rank2Types + + build-depends: base >= 4 && < 5, ieee754, storable-complex, + vector >= 0.7, QuickCheck >= 2.1.1 && < 3 + +Executable test-hs-linear-algebra + hs-source-dirs: lib, tests + main-is: Main.hs + other-modules: Vector + STVector, + Matrix, + STMatrix, + Statistics, + Typed + Foreign.BLAS.Double + Foreign.BLAS.Zomplex + Foreign.LAPACK.Double + Foreign.LAPACK.Zomplex + + includes: cbits/config.h + cbits/f77_func-hsc.h + cbits/vmath.h + include-dirs: cbits + + c-sources: cbits/vmath-double.c + cbits/vmath-zomplex.c + + build-depends: QuickCheck >= 2.1 && < 3, + test-framework >= 0.3.1, + test-framework-quickcheck2 >= 0.2.7 diff --git a/linear-algebra.buildinfo.in b/linear-algebra.buildinfo.in new file mode 100644 --- /dev/null +++ b/linear-algebra.buildinfo.in @@ -0,0 +1,7 @@ + +buildable: @BUILD_PACKAGE_BOOL@ +ld-options: @LDFLAGS@ @LAPACK_LIBS@ @BLAS_LIBS@ @LIBS@ + +executable: test-hs-linear-algebra +buildable: @BUILD_PACKAGE_BOOL@ +ld-options: @LDFLAGS@ @LAPACK_LIBS@ @BLAS_LIBS@ @LIBS@ diff --git a/m4/ax_check_blas.m4 b/m4/ax_check_blas.m4 new file mode 100644 --- /dev/null +++ b/m4/ax_check_blas.m4 @@ -0,0 +1,238 @@ +# SYNOPSIS +# +# AX_CHECK_BLAS([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro looks for a library that implements the BLAS linear-algebra +# interface (see http://www.netlib.org/blas/). On success, it sets the +# BLAS_LIBS output variable to hold the requisite library linkages. +# +# To link with BLAS, you should link with: +# +# $BLAS_LIBS $LIBS $FLIBS +# +# in that order. +# +# To call a BLAS function, use the F77_FUNC macro, defined in config.h +# +# Many libraries are searched for, from ATLAS to CXML to ESSL. The user +# may also use --with-blas= in order to use some specific BLAS +# library . +# +# ACTION-IF-FOUND is a list of shell commands to run if a BLAS library is +# found, and ACTION-IF-NOT-FOUND is a list of commands to run it if it is +# not found. If ACTION-IF-FOUND is not specified, the default action will +# define HAVE_BLAS. +# +# This macro requires autoconf 2.50 or later. +# +# The macro is a modified version of ACX_BLAS, from the autoconf macro +# archive. The original macro depends on a Fortran compiler, and this +# version does not. This version has not been tested extensively, but +# it is known to work with ATLAS and vecLib. +# +# LAST MODIFICATION +# +# 2009-10-8 +# +# COPYLEFT +# +# Copyright (c) 2009 Patrick O. Perry +# Copyright (c) 2008 Steven G. Johnson +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Macro Archive. When you make and +# distribute a modified version of the Autoconf Macro, you may extend this +# special exception to the GPL to apply to your modified version as well. + +AC_DEFUN([AX_CHECK_BLAS], [ +AC_PREREQ(2.50) +ax_blas_ok=no + +AC_ARG_WITH([blas], + [AC_HELP_STRING([--with-blas=], [use BLAS library ])]) +case $with_blas in + yes | "") ;; + no) ax_blas_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) BLAS_LIBS="$with_blas" ;; + *) BLAS_LIBS="-l$with_blas" ;; +esac + +_AX_CHECK_BLAS([gemm_]) +if test x$ax_blas_ok = xyes; then + ax_blas_underscore=yes +else + _AX_CHECK_BLAS([gemm]) + if test x$ax_blas_ok = xyes; then + ax_blas_undersore=no + fi +fi +AC_SUBST([BLAS_LIBS]) + +if test x$ax_blas_ok = xyes; then + ifelse([$1],, [ + AC_DEFINE(HAVE_BLAS,1, [Define if you have a BLAS library.]) + AH_TEMPLATE([F77_FUNC], + [Define to a macro mangling the given Fortan function name]) + if test x$ax_blas_underscore = xyes; then + AC_DEFINE([F77_FUNC(name)], [name ## _]) + else + AC_DEFINE([F77_FUNC(name)], [name]) + fi], + [$1]) + : +else + ax_blas_ok=no + [$2] +fi + +])dnl AX_CHECK_BLAS + + +# _AX_CHECK_BLAS(GEMM) +# -------------------------------------------------------- +# Look for a BLAS library in all of the standard places by checking for the +# functions s$GEMM and d$GEMM. On success, define BLAS_LIBS, set +# ax_blas_ok to yes, and execute ACTION-IF-FOUND. On failure, set ax_blas_ok +# to no and execute ACTION-IF-NOT-FOUND. +AC_DEFUN([_AX_CHECK_BLAS], [ +AC_PREREQ([2.50]) + +m4_pushdef([sgemm],[[s$1]]) +m4_pushdef([dgemm],[[d$1]]) + +ax_blas_save_LIBS="$LIBS" +LIBS="$LIBS $FLIBS" + +# First, check BLAS_LIBS environment variable +if test x$ax_blas_ok = xno; then + if test x$BLAS_LIBS != x; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + AC_MSG_CHECKING([for ]sgemm[ in $BLAS_LIBS]) + AC_TRY_LINK_FUNC(sgemm, [ax_blas_ok=yes], [BLAS_LIBS=""]) + AC_MSG_RESULT([$ax_blas_ok]) + LIBS="$save_LIBS" + fi +fi + +# BLAS linked to by default? (happens on some supercomputers) +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="$LIBS" + AC_CHECK_FUNC(sgemm, [ax_blas_ok=yes]) + LIBS="$save_LIBS" +fi + +# BLAS in ATLAS library? (http://math-atlas.sourceforge.net/) +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([atlas], [ATL_xerbla], + [AC_CHECK_LIB([f77blas], sgemm, + [AC_CHECK_LIB([cblas], [cblas_dgemm], + [ax_blas_ok=yes + BLAS_LIBS="-lcblas -lf77blas -latlas"], + [], + [-lf77blas -latlas])], + [], + [-latlas])]) +fi + +# BLAS in Intel MKL library? +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([mkl], sgemm, [ax_blas_ok=yes;BLAS_LIBS="-lmkl"]) +fi + +# BLAS in Apple vecLib library? +if test x$ax_blas_ok = xno; then + save_LIBS="$LIBS"; LIBS="-framework vecLib $LIBS" + unset ac_cv_func_[]sgemm + AC_CHECK_FUNC(sgemm, [ax_blas_ok=yes;BLAS_LIBS="-lblas"]) + LIBS="$save_LIBS" +fi + +# BLAS in PhiPACK libraries? (requires generic BLAS lib, too) +if test $ax_blas_ok = no; then + AC_CHECK_LIB([blas], sgemm, + [AC_CHECK_LIB([dgemm], dgemm, + [AC_CHECK_LIB([sgemm], sgemm, + [ax_blas_ok=yes; BLAS_LIBS="-lsgemm -ldgemm -lblas"], + [], + [-lblas])], + [], + [-lblas])]) +fi + +# BLAS in Alpha CXML library? +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([cxml], sgemm, [ax_blas_ok=yes;BLAS_LIBS="-lcxml"]) +fi + +# BLAS in Alpha DXML library? (now called CXML, see above) +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([dxml], sgemm, [ax_blas_ok=yes;BLAS_LIBS="-ldxml"]) +fi + +# BLAS in Sun Performance library? +if test x$ax_blas_ok = xno; then + if test "x$GCC" != xyes; then # only works with Sun CC + AC_CHECK_LIB([sunmath], [acosp], + [AC_CHECK_LIB([sunperf], sgemm, + [BLAS_LIBS="-xlic_lib=sunperf -lsunmath" + ax_blas_ok=yes], + [], + [-lsunmath])]) + fi +fi + +# BLAS in SCSL library? (SGI/Cray Scientific Library) +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([scs], sgemm, [ax_blas_ok=yes; BLAS_LIBS="-lscs"]) +fi + +# BLAS in SGIMATH library? +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([complib.sgimath], sgemm, + [ax_blas_ok=yes; BLAS_LIBS="-lcomplib.sgimath"]) +fi + +# BLAS in IBM ESSL library? (requires generic BLAS lib, too) +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([blas], sgemm, + [AC_CHECK_LIB([essl], sgemm, + [ax_blas_ok=yes; BLAS_LIBS="-lessl -lblas"], + [], + [-lblas $FLIBS])]) +fi + +# Generic BLAS library? +if test x$ax_blas_ok = xno; then + AC_CHECK_LIB([blas], sgemm, [ax_blas_ok=yes; BLAS_LIBS="-lblas"]) +fi + +LIBS="$ax_blas_save_LIBS" + +m4_popdef([sgemm]) +m4_popdef([dgemm]) + +])dnl _AX_CHECK_BLAS + diff --git a/m4/ax_check_lapack.m4 b/m4/ax_check_lapack.m4 new file mode 100644 --- /dev/null +++ b/m4/ax_check_lapack.m4 @@ -0,0 +1,131 @@ +# SYNOPSIS +# +# AX_CHECK_LAPACK([ACTION-IF-FOUND[, ACTION-IF-NOT-FOUND]]) +# +# DESCRIPTION +# +# This macro looks for a library that implements the LAPACK linear-algebra +# interface (see http://www.netlib.org/lapack/). On success, it sets the +# LAPACK_LIBS output variable to hold the requisite library linkages. +# +# To link with LAPACK, you should link with: +# +# $LAPACK_LIBS $BLAS_LIBS $LIBS +# +# in that order. BLAS_LIBS is the output variable of the AX_BLAS macro, +# called automatically. +# +# The user may also use --with-lapack= in order to use some specific +# LAPACK library . +# +# ACTION-IF-FOUND is a list of shell commands to run if a LAPACK library +# is found, and ACTION-IF-NOT-FOUND is a list of commands to run it if it +# is not found. If ACTION-IF-FOUND is not specified, the default action +# will define HAVE_LAPACK. +# +# The macro is a modified version of ACX_LAPACK, from the autoconf macro +# archive. The original macro depends on a Fortran compiler, and this +# version does not. This version has not been tested extensively, but +# it is known to work with ATLAS and vecLib. +# +# LAST MODIFICATION +# +# 2008-12-29 +# +# COPYLEFT +# +# Copyright (c) 2008 Patrick O. Perry +# Copyright (c) 2008 Steven G. Johnson +# +# This program is free software: you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by the +# Free Software Foundation, either version 3 of the License, or (at your +# option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General +# Public License for more details. +# +# You should have received a copy of the GNU General Public License along +# with this program. If not, see . +# +# As a special exception, the respective Autoconf Macro's copyright owner +# gives unlimited permission to copy, distribute and modify the configure +# scripts that are the output of Autoconf when processing the Macro. You +# need not follow the terms of the GNU General Public License when using +# or distributing such scripts, even though portions of the text of the +# Macro appear in them. The GNU General Public License (GPL) does govern +# all other use of the material that constitutes the Autoconf Macro. +# +# This special exception to the GPL applies to versions of the Autoconf +# Macro released by the Autoconf Macro Archive. When you make and +# distribute a modified version of the Autoconf Macro, you may extend this +# special exception to the GPL to apply to your modified version as well. + +AC_DEFUN([AX_CHECK_LAPACK], [ +AC_REQUIRE([AX_CHECK_BLAS]) +ax_lapack_ok=no + +AC_ARG_WITH(lapack, + [AC_HELP_STRING([--with-lapack=], [use LAPACK library ])]) +case $with_lapack in + yes | "") ;; + no) ax_lapack_ok=disable ;; + -* | */* | *.a | *.so | *.so.* | *.o) LAPACK_LIBS="$with_lapack" ;; + *) LAPACK_LIBS="-l$with_lapack" ;; +esac + +# Get fortran linker name of LAPACK function to check for. +if test x"$ax_blas_underscore" = xyes; then + cheev=cheev_ +else + cheev=cheev +fi + +# We cannot use LAPACK if BLAS is not found +if test "x$ax_blas_ok" != xyes; then + ax_lapack_ok=noblas + LAPACK_LIBS="" +fi + +# First, check LAPACK_LIBS environment variable +if test "x$LAPACK_LIBS" != x; then + save_LIBS="$LIBS"; LIBS="$LAPACK_LIBS $BLAS_LIBS $LIBS" + AC_MSG_CHECKING([for $cheev in $LAPACK_LIBS]) + AC_TRY_LINK_FUNC($cheev, [ax_lapack_ok=yes], [LAPACK_LIBS=""]) + AC_MSG_RESULT($ax_lapack_ok) + LIBS="$save_LIBS" + if test $ax_lapack_ok = no; then + LAPACK_LIBS="" + fi +fi + +# LAPACK linked to by default? (is sometimes included in BLAS lib) +if test $ax_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$LIBS $BLAS_LIBS" + AC_CHECK_FUNC($cheev, [ax_lapack_ok=yes]) + LIBS="$save_LIBS" +fi + +# Generic LAPACK library? +for lapack in lapack lapack_rs6k; do + if test $ax_lapack_ok = no; then + save_LIBS="$LIBS"; LIBS="$BLAS_LIBS $LIBS" + AC_CHECK_LIB($lapack, $cheev, + [ax_lapack_ok=yes; LAPACK_LIBS="-l$lapack"], [], []) + LIBS="$save_LIBS" + fi +done + +AC_SUBST(LAPACK_LIBS) + +# Finally, execute ACTION-IF-FOUND/ACTION-IF-NOT-FOUND: +if test x"$ax_lapack_ok" = xyes; then + ifelse([$1],,AC_DEFINE(HAVE_LAPACK,1,[Define if you have LAPACK library.]),[$1]) + : +else + ax_lapack_ok=no + $2 +fi +])dnl AX_LAPACK diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,19 @@ + +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Vector +import STVector +import Matrix +import STMatrix +import Statistics + +main :: IO () +main = defaultMain tests + where + tests = [ tests_Vector + , tests_STVector + , tests_Matrix + , tests_STMatrix + , tests_Statistics + ] diff --git a/tests/Makefile.in b/tests/Makefile.in new file mode 100644 --- /dev/null +++ b/tests/Makefile.in diff --git a/tests/Matrix.hs b/tests/Matrix.hs new file mode 100644 --- /dev/null +++ b/tests/Matrix.hs @@ -0,0 +1,433 @@ +module Matrix ( + tests_Matrix + ) where + +import Control.Monad( replicateM, zipWithM_ ) +import Data.AEq +import Data.List( transpose ) +import Debug.Trace +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra +import qualified Numeric.LinearAlgebra.Matrix as M +import qualified Numeric.LinearAlgebra.Vector as V + +import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim2(..), Index2(..), + Assocs2(..), MatrixPair(..) ) +import qualified Test.QuickCheck.LinearAlgebra as Test + +import Typed + + +tests_Matrix = testGroup "Matrix" + [ testPropertyI "dim . fromList" prop_dim_fromList + , testPropertyI "at . fromList" prop_at_fromList + , testPropertyI "fromCols" prop_fromCols + , testPropertyI "fromRows" prop_fromRows + , testPropertyI "constant" prop_constant + , testPropertyI "indices" prop_indices + , testPropertyI "elems" prop_elems + , testPropertyI "assocs" prop_assocs + , testPropertyI "update" prop_update + , testPropertyI "accum" prop_accum + , testPropertyI "map" prop_map + , testPropertyI "zipWith" prop_zipWith + , testPropertyI "col" prop_col + , testPropertyI "cols" prop_cols + , testPropertyD "row" prop_row + , testPropertyD "rows" prop_rows + , testPropertyI "diag" prop_diag + , testPropertyI "slice" prop_slice + , testPropertyI "splitRowsAt" prop_splitRowsAt + , testPropertyI "splitColsAt" prop_splitColsAt + , testPropertyI "viewVector" prop_viewVector + , testPropertyDZ "shiftDiag" prop_shiftDiag prop_shiftDiag + , testPropertyDZ "shiftDiagWithScale" + prop_shiftDiagWithScale prop_shiftDiagWithScale + , testPropertyDZ "add" prop_add prop_add + , testPropertyDZ "sub" prop_sub prop_sub + , testPropertyDZ "scale" prop_scale prop_scale + , testPropertyDZ "scaleRows" prop_scaleRows prop_scaleRows + , testPropertyDZ "scaleCols" prop_scaleCols prop_scaleCols + , testPropertyDZ "negate" prop_negate prop_negate + , testPropertyDZ "conjugate" prop_conjugate prop_conjugate + , testPropertyDZ "trans" prop_trans prop_trans + , testPropertyDZ "conjTrans" prop_conjTrans prop_conjTrans + , testPropertyDZ "rank1Update" prop_rank1Update prop_rank1Update + , testPropertyDZ "mulVector" prop_mulVector prop_mulVector + , testPropertyDZ "mulVectorWithScale" prop_mulVectorWithScale prop_mulVectorWithScale + , testPropertyDZ "addMulVectorWithScales" prop_addMulVectorWithScales prop_addMulVectorWithScales + , testPropertyDZ "mulMatrix" prop_mulMatrix prop_mulMatrix + , testPropertyDZ "mulMatrixWithScale" prop_mulMatrixWithScale prop_mulMatrixWithScale + , testPropertyDZ "addMulMatrixWithScales" prop_addMulMatrixWithScales prop_addMulMatrixWithScales + + ] + + + +------------------------- Matrix Construction ------------------------------ + +prop_dim_fromList t (Dim2 (m,n)) = + forAll (QC.vector $ m*n) $ \es -> let + a = typed t $ M.fromList (m,n) es + in M.dim a == (m,n) + +prop_at_fromList t (Dim2 (m,n)) = + forAll (QC.vector $ m*n) $ \es -> let + a = typed t $ M.fromList (m,n) es + in and [ M.at a (i,j) === e + | ((i,j),e) <- zip [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ] + es + ] + +prop_fromCols t (Dim2 (m,n)) = + forAll (replicateM n $ Test.vector m) $ \cs -> + M.fromCols (m,n) cs === (typed t $ M.fromList (m,n) $ + concatMap V.elems cs) + +prop_fromRows t (Dim2 (m,n)) = + forAll (replicateM m $ Test.vector n) $ \rs -> + M.fromRows (m,n) rs === (typed t $ M.fromList (m,n) $ + concat $ transpose $ map V.elems rs) + +prop_constant t (Dim2 (m,n)) e = + M.constant (m,n) e === M.fromList (m,n) (replicate (m*n) e) + where + _ = typed t [e] + + +-------------------------- Accessing Matrices ------------------------------ + +prop_indices t x = + M.indices x === [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ] + where + (m,n) = M.dim x + _ = immutableMatrix x + _ = typed t x + +prop_elems t x = + M.elems x === [ M.at x i | i <- M.indices x ] + where + _ = typed t x + +prop_assocs t x = + M.assocs x === zip (M.indices x) (M.elems x) + where + _ = typed t x + + +------------------------- Incremental Updates ------------------------------ + +prop_update t (Assocs2 mn ies) = + forAll (typed t `fmap` Test.matrix mn) $ \x -> let + x' = M.update x ies + is = M.indices x + is1 = (fst . unzip) ies + is0 = [ i | i <- is, i `notElem` is1 ] + in and $ + [ M.at x' i `elem` [ e | (i',e) <- ies, i' == i ] + | i <- is1 + ] ++ + [ M.at x' i === M.at x i + | i <- is0 + ] + +prop_accum t (Blind f) (Assocs2 mn ies) = + forAll (typed t `fmap` Test.matrix mn) $ \x -> let + x' = M.accum f x ies + in x' === M.fromList mn [ foldl f e [ e' | (i',e') <- ies, i' == i] + | (i,e) <- M.assocs x ] + where + _ = typed t $ (snd . unzip) ies + +-------------------------- Derived Matrices ------------------------------ + +prop_map t (Blind f) x = + M.map f x === M.fromList (M.dim x) (map f $ M.elems x) + where + _ = typed t x + _ = typed t $ M.map f x + +prop_zipWith t (Blind f) (MatrixPair x y) = + M.zipWith f x y === (M.fromList (M.dim x) $ + zipWith f (M.elems x) (M.elems y)) + where + _ = typed t x + _ = typed t y + _ = typed t $ M.zipWith f x y + + +------------------------------ Matrix Views -------------------------------- + +prop_col t (Index2 (m,n) (_,j)) = + forAll (typed t `fmap` Test.matrix (m,n)) $ \a -> + M.col a j === V.fromList m [ M.at a (i,j) | i <- [ 0..m-1 ] ] + +prop_cols t a = + M.cols a === [ M.col a j | j <- [ 0..n-1 ] ] + where + (_,n) = M.dim a + _ = typed t $ immutableMatrix a + +prop_row t (Index2 (m,n) (i,_)) = + forAll (typed t `fmap` Test.matrix (m,n)) $ \a -> + M.row a i === V.fromList n [ M.at a (i,j) | j <- [ 0..n-1 ] ] + +prop_rows t a = + M.rows a === [ M.row a i | i <- [ 0..m-1 ] ] + where + (m,_) = M.dim a + _ = typed t $ immutableMatrix a + +prop_diag t a = + M.diag a === V.fromList mn [ M.at a (i,i) | i <- [ 0..mn-1 ] ] + where + (m,n) = M.dim a + mn = min m n + _ = typed t $ immutableMatrix a + +prop_slice t a = + forAll (choose (0,m)) $ \m' -> + forAll (choose (0,n)) $ \n' -> + forAll (choose (0,m-m')) $ \i -> + forAll (choose (0,n-n')) $ \j -> + M.slice (i,j) (m',n') a + === M.fromCols (m',n') [ V.slice i m' (M.col a j') + | j' <- [ j..j+n'-1 ] ] + where + (m,n) = M.dim a + _ = typed t a + +prop_splitRowsAt t a = + forAll (choose (0,m)) $ \i -> + M.splitRowsAt i a + === ( M.slice (0,0) (i,n) a + , M.slice (i,0) (m-i,n) a + ) + where + (m,n) = M.dim a + _ = typed t $ immutableMatrix a + +prop_splitColsAt t a = + forAll (choose (0,n)) $ \j -> + M.splitColsAt j a + === ( M.slice (0,0) (m,j) a + , M.slice (0,j) (m,n-j) a + ) + where + (m,n) = M.dim a + _ = typed t $ immutableMatrix a + +prop_viewVector t (Dim2 (m,n)) = + forAll (Test.vector $ m*n) $ \x -> let _ = typed t x in + M.elems (M.fromVector (m,n) x) === V.elems x + + +-------------------------- Num Matrix Operations -------------------------- + +prop_shiftDiag t a = + forAll (Test.vector (min m n)) $ \d -> + M.shiftDiag d a + === M.accum (+) a [ ((i,i),e) | (i,e) <- V.assocs d ] + where + (m,n) = M.dim a + _ = typed t a + +prop_shiftDiagWithScale t k a = + forAll (Test.vector (min m n)) $ \d -> + M.shiftDiagWithScale k d a + ~== M.accum (+) a [ ((i,i),k * e) | (i,e) <- V.assocs d ] + where + (m,n) = M.dim a + _ = typed t a + +prop_add t (MatrixPair x y) = + x `M.add` y === M.zipWith (+) x y + where + _ = typed t x + +prop_sub t (MatrixPair x y) = + x `M.sub` y === M.zipWith (-) x y + where + _ = typed t x + +prop_scale t k x = + M.scale k x ~== M.map (k*) x + where + _ = typed t x + +prop_scaleRows t a = + forAll (Test.vector m) $ \s -> + M.scaleRows s a + ~== M.fromCols (m,n) [ V.mul s x | x <- M.cols a ] + where + (m,n) = M.dim a + _ = typed t a + +prop_scaleCols t a = + forAll (Test.vector n) $ \s -> + M.scaleCols s a + ~== M.fromCols (m,n) + [ V.scale e x + | (e,x) <- zip (V.elems s) (M.cols a) ] + where + (m,n) = M.dim a + _ = typed t a + +prop_negate t x = + M.negate x === M.map negate x + where + _ = typed t x + +prop_conjugate t x = + M.conjugate x === M.map conjugate x + where + _ = typed t x + + +-------------------------- Linear Algebra -------------------------- + +prop_trans t a = + M.trans a + === + M.update (M.zero (swap $ M.dim a)) [ (swap ij, e) | (ij,e) <- M.assocs a ] + where + swap (i,j) = (j,i) + _ = typed t a + +prop_conjTrans t a = + M.conjTrans a === M.conjugate (M.trans a) + where + _ = typed t a + +prop_rank1Update t alpha a = + forAll (Test.vector m) $ \x -> + forAll (Test.vector n) $ \y -> let y' = V.conjugate y in + M.rank1Update alpha x y a + ~== + M.update (M.zero (m,n)) + [ ((i,j), alpha * V.at x i * V.at y' j + e) + | ((i,j),e) <- M.assocs a + ] + where + (m,n)= M.dim a + _ = typed t a + +data MulMatrixAddVector e = + MulMatrixAddVector Trans (Matrix e) (Vector e) (Vector e) deriving (Show) + +instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddVector e) where + arbitrary = do + transa <- arbitrary + a <- arbitrary + let (ma,na) = M.dim a + (m,n) = case transa of NoTrans -> (ma,na) + _ -> (na,ma) + x <- Test.vector n + y <- Test.vector m + return $ MulMatrixAddVector transa a x y + +data MulMatrixVector e = + MulMatrixVector Trans (Matrix e) (Vector e) deriving (Show) +instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixVector e) where + arbitrary = do + (MulMatrixAddVector transa a x _) <- arbitrary + return $ MulMatrixVector transa a x + +prop_mulVector t (MulMatrixVector transa a x) = + M.mulVector transa a x + ~== + case transa of + NoTrans -> V.fromList (fst $ M.dim a) + [ V.dot x (V.conjugate r) + | r <- M.rows a ] + + Trans -> V.fromList (snd $ M.dim a) + [ V.dot x (V.conjugate c) + | c <- M.cols a ] + + ConjTrans -> V.fromList (snd $ M.dim a) + [ V.dot x c + | c <- M.cols a ] + where + _ = typed t a + +prop_mulVectorWithScale t alpha (MulMatrixVector transa a x) = + M.mulVectorWithScale alpha transa a x + ~== + M.mulVector transa a (V.scale alpha x) + where + _ = typed t a + +prop_addMulVectorWithScales t alpha beta (MulMatrixAddVector transa a x y) = + M.addMulVectorWithScales alpha transa a x beta y + ~== + V.add (M.mulVectorWithScale alpha transa a x) + (V.scale beta y) + where + _ = typed t a + +data MulMatrixAddMatrix e = + MulMatrixAddMatrix Trans (Matrix e) Trans (Matrix e) (Matrix e) deriving (Show) + +instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddMatrix e) where + arbitrary = do + transa <- arbitrary + transb <- arbitrary + c <- arbitrary + k <- fst `fmap` Test.dim2 + + let (m,n) = M.dim c + (ma,na) = case transa of NoTrans -> (m,k) + _ -> (k,m) + (mb,nb) = case transb of NoTrans -> (k,n) + _ -> (n,k) + a <- Test.matrix (ma,na) + b <- Test.matrix (mb,nb) + + return $ MulMatrixAddMatrix transa a transb b c + +data MulMatrixMatrix e = + MulMatrixMatrix Trans (Matrix e) Trans (Matrix e) deriving (Show) +instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixMatrix e) where + arbitrary = do + (MulMatrixAddMatrix transa a transb b _) <- arbitrary + return $ MulMatrixMatrix transa a transb b + +prop_mulMatrix t (MulMatrixMatrix transa a transb b) = + M.mulMatrix transa a transb b + ~== + M.fromCols (m,n) [ M.mulVector transa a x | x <- M.cols b' ] + where + m = case transa of NoTrans -> (fst $ M.dim a) + _ -> (snd $ M.dim a) + n = case transb of NoTrans -> (snd $ M.dim b) + _ -> (fst $ M.dim b) + b' = case transb of NoTrans -> b + Trans -> M.trans b + ConjTrans -> M.conjTrans b + _ = typed t a + +prop_mulMatrixWithScale t alpha (MulMatrixMatrix transa a transb b) = + M.mulMatrixWithScale alpha transa a transb b + ~== + M.scale alpha (M.mulMatrix transa a transb b) + where + _ = typed t a + +prop_addMulMatrixWithScales t alpha beta (MulMatrixAddMatrix transa a transb b c) = + M.addMulMatrixWithScales alpha transa a transb b beta c + ~== + M.add (M.scale alpha (M.mulMatrix transa a transb b)) + (M.scale beta c) + where + _ = typed t a + + + +testAEq a b = + if a ~== b then True + else trace ("expected: " ++ show b ++ "\nactual: " ++ show a) False diff --git a/tests/STMatrix.hs b/tests/STMatrix.hs new file mode 100644 --- /dev/null +++ b/tests/STMatrix.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE NoMonomorphismRestriction, Rank2Types #-} +module STMatrix ( + tests_STMatrix, + mutatesToMatrix, + readOnlyMatrix, + + ) where + +import Control.Monad +import Control.Monad.ST +import Data.AEq +import Data.Complex( magnitude ) +import Debug.Trace +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra +import qualified Numeric.LinearAlgebra.Vector as V +import qualified Numeric.LinearAlgebra.Matrix as M + +import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim2(..), Index2(..), + Assocs2(..), MatrixPair(..), MatrixTriple(..) ) +import qualified Test.QuickCheck.LinearAlgebra as Test + +import STVector( readOnlyVector ) +import Typed + + +tests_STMatrix = testGroup "STMatrix" + [ testPropertyI "new_" prop_new_ + , testPropertyI "new" prop_new + , testPropertyI "newCopy" prop_newCopy + , testPropertyI "copyTo" prop_copyTo + , testPropertyI "read" prop_read + , testPropertyI "write" prop_write + , testPropertyI "modify" prop_modify + , testPropertyI "getElems" prop_getElems + , testPropertyI "getElems'" prop_getElems' + , testPropertyI "getAssocs" prop_getAssocs + , testPropertyI "getAssocs'" prop_getAssocs' + , testPropertyI "setElems" prop_setElems + , testPropertyI "setAssocs" prop_setAssocs + , testPropertyI "mapTo" prop_mapTo + , testPropertyI "zipWithTo" prop_zipWithTo + , testPropertyDZ "shiftDiagM_" prop_shiftDiagM_ prop_shiftDiagM_ + , testPropertyDZ "shiftDiagWithScaleToM_" + prop_shiftDiagWithScaleM_ prop_shiftDiagWithScaleM_ + , testPropertyDZ "addTo" prop_addTo prop_addTo + , testPropertyDZ "subTo" prop_subTo prop_subTo + , testPropertyDZ "scaleM_" prop_scaleM_ prop_scaleM_ + , testPropertyDZ "addWithScaleM_" prop_addWithScaleM_ prop_addWithScaleM_ + , testPropertyDZ "scaleRowsM" prop_scaleRowsM_ prop_scaleRowsM_ + , testPropertyDZ "scaleColsM_" prop_scaleColsM_ prop_scaleColsM_ + , testPropertyDZ "negateTo" prop_negateTo prop_negateTo + , testPropertyDZ "conjugateTo" prop_conjugateTo prop_conjugateTo + , testPropertyDZ "swapRows" prop_swapRows prop_swapRows + , testPropertyDZ "swapCols" prop_swapCols prop_swapCols + ] + + +prop_new_ t (Dim2 n) = + (M.dim $ typed t $ M.create $ M.new_ n) === n + +prop_new t (Dim2 n) e = + (M.create $ M.new n e) === (typed t $ M.constant n e) + +prop_newCopy t x = + (M.create $ M.newCopy x) === x + where + _ = typed t x + +prop_copyTo t (MatrixPair x y) = runST $ + x `readOnlyMatrix` \mx -> + y `mutatesToMatrix` x $ \my -> + M.copyTo my mx + where + _ = typed t x + +prop_read t (Index2 n i) = + forAll (typed t `fmap` Test.matrix n) $ \x -> runST $ + x `readOnlyMatrix` \mx -> do + e <- M.read mx i + return $ e === M.at x i + +prop_write t (Index2 n i) e = + forAll (Test.matrix n) $ \x -> runST $ + x `mutatesToMatrix` (x `M.update` [(i,e)]) $ \mx -> do + M.write mx i e + where + _ = e == t + +prop_modify t (Index2 n i) (Blind f) = + forAll (Test.matrix n) $ \x -> runST $ + x `mutatesToMatrix` + (typed t $ x `M.update` [(i, f $ M.at x i)]) $ \mx -> + M.modify mx i f + +prop_getElems t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToMatrix` (M.map f x) $ \mx -> do + es <- M.getElems mx + M.mapTo mx f mx + return $ es === M.elems (M.map f x) + where + _ = typed t x + +prop_getElems' t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToMatrix` (M.map f x) $ \mx -> do + es <- M.getElems' mx + M.mapTo mx f mx + return $ es === M.elems x + where + _ = typed t x + +prop_getAssocs t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToMatrix` (M.map f x) $ \mx -> do + ies <- M.getAssocs mx + M.mapTo mx f mx + return $ ies === M.assocs (M.map f x) + where + _ = typed t x + +prop_getAssocs' t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToMatrix` (M.map f x) $ \mx -> do + ies <- M.getAssocs' mx + M.mapTo mx f mx + return $ ies === M.assocs x + where + _ = typed t x + +prop_setElems t x = + forAll (QC.vector $ m*n) $ \es -> runST $ + x `mutatesToMatrix` (M.fromList (m,n) es) $ \mx -> + M.setElems mx es + where + (m,n) = M.dim x + _ = typed t x + +prop_setAssocs t (Assocs2 mn ies) = + forAll (Test.matrix mn) $ \x -> runST $ + x `mutatesToMatrix` (typed t $ M.update x ies) $ \mx -> + M.setAssocs mx ies + +prop_mapTo t (Blind f) = binaryProp t + (\x -> M.map f x) + (\dst mx -> M.mapTo dst f mx) + +prop_zipWithTo t (Blind f) = ternaryProp t + (\x y -> M.zipWith f x y) + (\dst mx my -> M.zipWithTo dst f mx my) + +prop_shiftDiagM_ t a = + forAll (Test.vector (min m n)) $ \s -> runST $ + s `readOnlyVector` \ms -> + a `mutatesToMatrix` (M.shiftDiag s a) $ \ma -> + M.shiftDiagM_ ms ma + where + (m,n) = M.dim a + _ = typed t a + +prop_shiftDiagWithScaleM_ t e a = + forAll (Test.vector (min m n)) $ \s -> runST $ + s `readOnlyVector` \ms -> + a `mutatesToMatrix` (M.shiftDiagWithScale e s a) $ \ma -> + M.shiftDiagWithScaleM_ e ms ma + where + (m,n) = M.dim a + _ = typed t a + +prop_addTo t = ternaryProp t M.add M.addTo + +prop_subTo t = ternaryProp t M.sub M.subTo + +prop_scaleM_ t e a = runST $ + a `mutatesToMatrix` (M.scale e a) $ \ma -> + M.scaleM_ e ma + where + _ = typed t a + +prop_addWithScaleM_ t alpha (MatrixPair x y) = runST $ + x `readOnlyMatrix` \mx -> + y `mutatesToMatrix` (M.addWithScale alpha x y) $ \my -> + M.addWithScaleM_ alpha mx my + where + _ = typed t x + +prop_scaleRowsM_ t a = + forAll (Test.vector m) $ \s -> runST $ + s `readOnlyVector` \ms -> + a `mutatesToMatrix` (M.scaleRows s a) $ \ma -> + M.scaleRowsM_ ms ma + where + (m,n) = M.dim a + _ = typed t a + +prop_scaleColsM_ t a = + forAll (Test.vector n) $ \s -> runST $ + s `readOnlyVector` \ms -> + a `mutatesToMatrix` (M.scaleCols s a) $ \ma -> + M.scaleColsM_ ms ma + where + (m,n) = M.dim a + _ = typed t a + +prop_negateTo t = binaryProp t M.negate M.negateTo + +prop_conjugateTo t = binaryProp t M.conjugate M.conjugateTo + +prop_swapRows t = + forAll arbitrary $ \(Index2 (m,n) (i1,_)) -> + forAll (choose (0,m-1)) $ \i2 -> + forAll (typed t `fmap` Test.matrix (m,n)) $ \a -> + let a' = M.update a $ [ ((i2,j),e) | (j,e) <- V.assocs (M.row a i1) + ] ++ + [ ((i1,j),e) | (j,e) <- V.assocs (M.row a i2) + ] + in runST $ + a `mutatesToMatrix` a' $ \ma -> + M.swapRows ma i1 i2 + +prop_swapCols t = + forAll arbitrary $ \(Index2 (m,n) (_,j1)) -> + forAll (choose (0,n-1)) $ \j2 -> + forAll (typed t `fmap` Test.matrix (m,n)) $ \a -> + let a' = M.update a $ [ ((i,j2),e) | (i,e) <- V.assocs (M.col a j1) + ] ++ + [ ((i,j1),e) | (i,e) <- V.assocs (M.col a j2) + ] + in runST $ + a `mutatesToMatrix` a' $ \ma -> + M.swapCols ma j1 j2 + + +binaryProp :: (AEq e, Arbitrary e, Show e, Storable e, Testable a) + => e + -> (Matrix e -> Matrix e) + -> (forall s . STMatrix s e -> STMatrix s e -> ST s a) + -> Property +binaryProp t imm_f f = let + prop1 t x = runST $ + x `mutatesToMatrix` (imm_f x) $ \mx -> f mx mx + where _ = typed t x + prop2 t (MatrixPair x y) = runST $ let _ = typed t x in + x `readOnlyMatrix` \mx -> + y `mutatesToMatrix` (imm_f x) $ \my -> f my mx + where _ = typed t x + in ( label "1" prop1 + .&. label "2" prop2 + ) + +ternaryProp :: (AEq e, Arbitrary e, Show e, Storable e, Testable a) + => e + -> (Matrix e -> Matrix e -> Matrix e) + -> (forall s . STMatrix s e -> STMatrix s e -> STMatrix s e -> ST s a) + -> Property +ternaryProp t imm_f f = let + prop1 t x = runST $ + x `mutatesToMatrix` (imm_f x x) $ \mx -> f mx mx mx + where _ = typed t x + prop2a t (MatrixPair x y) = runST $ + x `readOnlyMatrix` \mx -> + y `mutatesToMatrix` (imm_f x y) $ \my -> f my mx my + where _ = typed t x + prop2b t (MatrixPair x y) = runST $ + x `mutatesToMatrix` (imm_f x y) $ \mx -> + y `readOnlyMatrix` \my -> f mx mx my + where _ = typed t x + prop3 t (MatrixTriple x y z) = runST $ + x `readOnlyMatrix` \mx -> + y `readOnlyMatrix` \my -> + z `mutatesToMatrix` (imm_f x y) $ \mz -> f mz mx my + where _ = typed t x + in ( label "1" prop1 + .&. label "2a" prop2a + .&. label "2b" prop2b + .&. label "3" prop3 + ) + + +readOnlyMatrix :: (Storable e, AEq e, Testable prop, Show e) + => Matrix e + -> (STMatrix s e -> ST s prop) + -> ST s Property +readOnlyMatrix x = mutatesToMatrix x x + +mutatesToMatrix :: (Storable e, AEq e, Testable prop, Show e) + => Matrix e + -> Matrix e + -> (STMatrix s e -> ST s prop) + -> ST s Property +mutatesToMatrix x x_new f = do + mx <- M.newCopy x + prop <- f mx + x' <- M.freeze mx + return $ prop .&. (x' === x_new) diff --git a/tests/STVector.hs b/tests/STVector.hs new file mode 100644 --- /dev/null +++ b/tests/STVector.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE NoMonomorphismRestriction, Rank2Types #-} +module STVector ( + tests_STVector, + mutatesToVector, + readOnlyVector, + ) where + +import Control.Monad +import Control.Monad.ST +import Data.AEq +import Data.Complex( magnitude ) +import Debug.Trace +import Foreign( Storable ) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra.Vector( Vector, STVector ) +import qualified Numeric.LinearAlgebra.Vector as V + +import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim(..), Index(..), + Assocs(..), VectorPair(..), VectorTriple(..) ) +import qualified Test.QuickCheck.LinearAlgebra as Test +import Test.QuickCheck.Property(rejected) + +import Typed + + +--- this could be a bad idea .. +instance Testable () where + property _ = property rejected + + +tests_STVector = testGroup "STVector" + [ testPropertyI "new_" prop_new_ + , testPropertyI "new" prop_new + , testPropertyI "newCopy" prop_newCopy + , testPropertyI "copyTo" prop_copyTo + , testPropertyDZ "swap" prop_swap prop_swap + , testPropertyI "read" prop_read + , testPropertyI "write" prop_write + , testPropertyI "modify" prop_modify + , testPropertyI "getElems" prop_getElems + , testPropertyI "getElems'" prop_getElems' + , testPropertyI "getAssocs" prop_getAssocs + , testPropertyI "getAssocs'" prop_getAssocs' + , testPropertyI "setElems" prop_setElems + , testPropertyI "setAssocs" prop_setAssocs + , testPropertyI "mapTo" prop_mapTo + , testPropertyI "zipWithTo" prop_zipWithTo + , testPropertyDZ "getSumAbs" prop_getSumAbs prop_getSumAbs + , testPropertyDZ "getNorm2" prop_getNorm2 prop_getNorm2 + , testPropertyDZ "getDot" prop_getDot prop_getDot + , testPropertyDZ "kroneckerTo" prop_kroneckerTo prop_kroneckerTo + , testPropertyDZ "addTo" prop_addTo prop_addTo + , testPropertyDZ "subTo" prop_subTo prop_subTo + , testPropertyDZ "mulTo" prop_mulTo prop_mulTo + , testPropertyDZ "negateTo" prop_negateTo prop_negateTo + , testPropertyDZ "conjugateTo" prop_conjugateTo prop_conjugateTo + , testPropertyDZ "absTo" prop_absTo prop_absTo + , testPropertyDZ "signumTo" prop_signumTo prop_signumTo + , testPropertyDZ "divTo" prop_divTo prop_divTo + , testPropertyDZ "recipTo" prop_recipTo prop_recipTo + , testPropertyDZ "sqrtTo" prop_sqrtTo prop_sqrtTo + , testPropertyDZ "expTo" prop_expTo prop_expTo + , testPropertyDZ "logTo" prop_logTo prop_logTo + , testPropertyDZ "powTo" prop_powTo prop_powTo + , testPropertyDZ "sinTo" prop_sinTo prop_sinTo + , testPropertyDZ "cosTo" prop_cosTo prop_cosTo + , testPropertyDZ "tanTo" prop_tanTo prop_tanTo + , testPropertyDZ "asinTo" prop_asinTo prop_asinTo + , testPropertyDZ "acosTo" prop_acosTo prop_acosTo + , testPropertyDZ "atanTo" prop_atanTo prop_atanTo + , testPropertyDZ "sinhTo" prop_sinhTo prop_sinhTo + , testPropertyDZ "coshTo" prop_coshTo prop_coshTo + , testPropertyDZ "tanhTo" prop_tanhTo prop_tanhTo + , testPropertyDZ "asinhTo" prop_asinhTo prop_asinhTo + , testPropertyDZ "acoshTo" prop_acoshTo prop_acoshTo + , testPropertyDZ "atanhTo" prop_atanhTo prop_atanhTo + ] + + +{- + getSumAbs: + + Double: [Failed] +*** Failed! Falsifiable (after 34 tests and 1 shrink): +fromList [48.00809219086489,-28.969358622663314,63.04503159639685,5.714612973491514,-5.312024428882535,60.56484370204321,20.339282130713237,-25.609691263383986,11.776052643355653,-72.22738635520177] +LHS +(used seed -5655945031033394469) + + Complex Double: [Failed] +*** Failed! Falsifiable (after 46 tests): +fromList [(-126.63684010249744) :+ (-25.732604105949363),48.30271669448071 :+ (-39.257907001851365),(-742.581416038894) :+ (-40.94772884905545),(-21.033310146590043) :+ 11.040319311574454,(-32.47272728995846) :+ (-75.38889146104881),34.61215019691849 :+ 63.02796474654257,25.495435934718248 :+ 14.86496960897311,285.1569736733574 :+ 20.592531068434027,(-75.03887610996705) :+ 62.568157533798285,13.719037128011735 :+ 49.186886152517744,(-23.33031638959207) :+ (-41.802953657765805),46.325514491999364 :+ (-40.3054052139413),(-97.8445174356864) :+ 62.27686352261467,(-210.08994152230045) :+ 23.4837419831381,(-47.12015960420664) :+ 9.502863461401958] +LHS + + Double: [Failed] +*** Failed! Falsifiable (after 61 tests): +VectorPair (fromList [24.074823693680273,166.2322847046224,-2.8103216076602617,6.544349669641704,157.92295537758915,-52.792112116283036,-56.334929255514766,12.079209274206134,-51.61912866052746,163.39401573569245,-49.34434955256682,-17.020978906318945,116.41247221011058]) (fromList [91.62365332716433,-46.23902424675873,151.71325376854423,34.663441501788725,-2.5921683575991397,-48.720845208466315,51.34009695413845,41.16706632522662,-52.1781413047511,18.0562293933656,-198.82058422020668,-4.213635327473868,40.59717128981193]) +LHS +LHS +(used seed -6941761855370166739) + + Complex Double: [OK, passed 100 tests] + +-} + +prop_new_ t (Dim n) = + (V.dim $ typed t $ V.create $ V.new_ n) === n + +prop_new t (Dim n) e = + (V.create $ V.new n e) === (typed t $ V.constant n e) + +prop_newCopy t x = + (V.create $ V.newCopy x) === x + where + _ = typed t x + +prop_copyTo t (VectorPair x y) = runST $ + x `readOnlyVector` \mx -> + y `mutatesToVector` x $ \my -> + V.copyTo my mx + where + _ = typed t x + +prop_swap t (VectorPair x y) = runST $ + x `mutatesToVector` y $ \mx -> + y `mutatesToVector` x $ \my -> + V.swap mx my + where + _ = typed t x + +prop_read t (Index n i) = + forAll (typed t `fmap` Test.vector n) $ \x -> runST $ + x `readOnlyVector` \mx -> do + e <- V.read mx i + return $ e === V.at x i + +prop_write t (Index n i) e = + forAll (Test.vector n) $ \x -> runST $ + x `mutatesToVector` (x `V.update` [(i,e)]) $ \mx -> do + V.write mx i e + where + _ = e == t + +prop_modify t (Index n i) (Blind f) = + forAll (Test.vector n) $ \x -> runST $ + x `mutatesToVector` + (typed t $ x `V.update` [(i, f $ V.at x i)]) $ \mx -> + V.modify mx i f + +prop_getElems t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToVector` (V.map f x) $ \mx -> do + es <- V.getElems mx + V.mapTo mx f mx + return $ es === V.elems (V.map f x) + where + _ = typed t x + +prop_getElems' t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToVector` (V.map f x) $ \mx -> do + es <- V.getElems' mx + V.mapTo mx f mx + return $ es === V.elems x + where + _ = typed t x + +prop_getAssocs t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToVector` (V.map f x) $ \mx -> do + ies <- V.getAssocs mx + V.mapTo mx f mx + return $ ies === V.assocs (V.map f x) + where + _ = typed t x + +prop_getAssocs' t x = + forAll arbitrary $ \(Blind f) -> runST $ + x `mutatesToVector` (V.map f x) $ \mx -> do + ies <- V.getAssocs' mx + V.mapTo mx f mx + return $ ies === V.assocs x + where + _ = typed t x + +prop_setElems t x = + forAll (QC.vector n) $ \es -> runST $ + x `mutatesToVector` (V.fromList n es) $ \mx -> + V.setElems mx es + where + n = V.dim x + _ = typed t x + +prop_setAssocs t (Assocs n ies) = + forAll (Test.vector n) $ \x -> runST $ + x `mutatesToVector` (typed t $ V.update x ies) $ \mx -> + V.setAssocs mx ies + +prop_mapTo t (Blind f) = binaryProp t + (\x -> V.map f x) + (\dst mx -> V.mapTo dst f mx) + +prop_zipWithTo t (Blind f) = ternaryProp t + (\x y -> V.zipWith f x y) + (\dst mx my -> V.zipWithTo dst f mx my) + +prop_getSumAbs t x = runST $ + x `readOnlyVector` \mx -> do + s <- V.getSumAbs mx + return $ s === V.sumAbs x + where + _ = typed t x + +prop_getNorm2 t x = runST $ + x `readOnlyVector` \mx -> do + n <- V.getNorm2 mx + return $ n === V.norm2 x + where + _ = typed t x + +prop_getDot t (VectorPair x y) = runST $ + x `readOnlyVector` \mx -> + y `readOnlyVector` \my -> do + d <- V.getDot mx my + return $ d === V.dot x y + where + _ = typed t x + +prop_kroneckerTo t = sized $ \s -> resize (s `div` 2) $ + forAll arbitrary $ \x -> + forAll arbitrary $ \y -> + forAll (Test.vector $ V.dim x * V.dim y) $ \z -> runST $ + x `readOnlyVector` \mx -> + y `readOnlyVector` \my -> + z `mutatesToVector` (typed t $ V.kronecker x y) $ \mz -> + V.kroneckerTo mz mx my + +prop_addTo t = ternaryProp t V.add V.addTo +prop_subTo t = ternaryProp t V.sub V.subTo +prop_mulTo t = ternaryProp t V.mul V.mulTo +prop_negateTo t = binaryProp t V.negate V.negateTo +prop_conjugateTo t = binaryProp t V.conjugate V.conjugateTo +prop_absTo t = binaryProp t V.abs V.absTo +prop_signumTo t = binaryProp t V.signum V.signumTo + +prop_divTo t = ternaryProp t V.div V.divTo +prop_recipTo t = binaryProp t V.recip V.recipTo + +prop_sqrtTo t = binaryProp t V.sqrt V.sqrtTo +prop_expTo t = binaryProp t V.exp V.expTo +prop_logTo t = binaryProp t V.log V.logTo +prop_powTo t = ternaryProp t V.pow V.powTo +prop_sinTo t = binaryProp t V.sin V.sinTo +prop_cosTo t = binaryProp t V.cos V.cosTo +prop_tanTo t = binaryProp t V.tan V.tanTo +prop_asinTo t = binaryProp t V.asin V.asinTo +prop_acosTo t = binaryProp t V.acos V.acosTo +prop_atanTo t = binaryProp t V.atan V.atanTo +prop_sinhTo t = binaryProp t V.sinh V.sinhTo +prop_coshTo t = binaryProp t V.cosh V.coshTo +prop_tanhTo t = binaryProp t V.tanh V.tanhTo +prop_asinhTo t = binaryProp t V.asinh V.asinhTo +prop_acoshTo t = binaryProp t V.acosh V.acoshTo +prop_atanhTo t = binaryProp t V.atanh V.atanhTo + + +binaryProp :: (AEq e, Arbitrary e, Show e, Storable e, Testable a) + => e + -> (Vector e -> Vector e) + -> (forall s . STVector s e -> STVector s e -> ST s a) + -> Property +binaryProp t imm_f f = let + prop2 t (VectorPair x y) = runST $ let _ = typed t x in + x `readOnlyVector` \mx -> + y `mutatesToVector` (imm_f x) $ \my -> f my mx + where _ = typed t x + in label "" prop2 + +ternaryProp :: (AEq e, Arbitrary e, Show e, Storable e, Testable a) + => e + -> (Vector e -> Vector e -> Vector e) + -> (forall s . STVector s e -> STVector s e -> STVector s e -> ST s a) + -> Property +ternaryProp t imm_f f = let + prop3 t (VectorTriple x y z) = runST $ + x `readOnlyVector` \mx -> + y `readOnlyVector` \my -> + z `mutatesToVector` (imm_f x y) $ \mz -> f mz mx my + where _ = typed t x + in label "" prop3 + + + +readOnlyVector :: (Storable e, AEq e, Testable prop, Show e) + => Vector e + -> (STVector s e -> ST s prop) + -> ST s Property +readOnlyVector x = mutatesToVector x x + +mutatesToVector :: (Storable e, AEq e, Testable prop, Show e) + => Vector e + -> Vector e + -> (STVector s e -> ST s prop) + -> ST s Property +mutatesToVector x x_new f = do + mx <- V.newCopy x + prop <- f mx + x' <- V.freeze mx + return $ prop .&. (x' === x_new) diff --git a/tests/Statistics.hs b/tests/Statistics.hs new file mode 100644 --- /dev/null +++ b/tests/Statistics.hs @@ -0,0 +1,209 @@ +module Statistics ( + tests_Statistics + ) where + +import Control.Monad( replicateM ) +import Data.AEq +import Data.List( foldl' ) +import Debug.Trace +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra +import qualified Numeric.LinearAlgebra.Packed as P +import qualified Numeric.LinearAlgebra.Matrix as M +import qualified Numeric.LinearAlgebra.Vector as V + +import Test.QuickCheck.LinearAlgebra( VectorList(..), WeightedVectorList(..) ) +import qualified Test.QuickCheck.LinearAlgebra as Test + +import Typed + +testAEq actual expected = + if actual ~== expected + then True + else trace ("expected: " ++ show expected ++ "\nactual: " ++ show actual) + False + + + +tests_Statistics = testGroup "Statistics" + [ testPropertyD "sum" prop_sum + , testPropertyD "weightedSum" prop_weightedSum + , testPropertyD "mean" prop_mean + , testPropertyD "weightedMean" prop_weightedMean + , testPropertyD "weightedMean (equal weights)" prop_weightedMean_eqw + , testPropertyD "Matrix cov" prop_Matrix_cov + , testPropertyD "Matrix covWithMean" prop_Matrix_covWithMean + , testPropertyD "Matrix weightedCov (equal weights)" prop_Matrix_weightedCov_eqw + , testPropertyD "Matrix weightedCov" prop_Matrix_weightedCov + , testPropertyD "Matrix weightedCovWithMean" prop_Matrix_weightedCovWithMean + , testPropertyD "Packed cov" prop_Packed_cov + , testPropertyD "Packed covWithMean" prop_Packed_covWithMean + , testPropertyD "Packed weightedCov (equal weights)" prop_Packed_weightedCov_eqw + , testPropertyD "Packed weightedCov" prop_Packed_weightedCov + , testPropertyD "Packed weightedCovWithMean" prop_Packed_weightedCovWithMean + ] + + +prop_sum t (VectorList p xs) = + V.sum p xs ~== foldl' V.add (V.constant p 0) xs + where + _ = typed t (head xs) + +prop_weightedSum t (WeightedVectorList p wxs) = + V.weightedSum p wxs + ~== V.sum p (map (uncurry V.scale) wxs) + where + n = length wxs + _ = typed t (snd $ head wxs) + +prop_mean t (VectorList p xs) = + V.mean p xs ~== V.scale (1/n) (V.sum p xs) + where + n = fromIntegral $ max (length xs) 1 + _ = typed t (head xs) + +prop_weightedMean_eqw t (VectorList p xs) = let + wxs = zip (repeat 1) xs + in V.weightedMean p wxs ~== V.mean p xs + where + _ = typed t (head xs) + +prop_weightedMean t (WeightedVectorList p wxs) = let + w_sum = (sum . fst . unzip) wxs + in V.weightedMean p wxs + ~== if w_sum == 0 then V.constant p 0 + else V.scale (1/w_sum) (V.weightedSum p wxs) + where + n = length wxs + _ = typed t (snd $ head wxs) + +prop_Matrix_cov t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + xbar = V.mean p xs + ys = [ V.sub x xbar | x <- xs ] + scale = case method of { UnbiasedCov -> 1/(n-1) ; MLCov -> 1/n } + cov' = foldl' (flip $ \y -> M.rank1Update scale y y) + (M.constant (p,p) 0) + ys + cov = M.cov p method xs + + in M.hermMulVector cov z ~== M.mulVector NoTrans cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Matrix_covWithMean t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + xbar = V.mean p xs + cov' = M.covWithMean xbar method xs + cov = M.cov p method xs + in M.hermMulVector cov z ~== M.hermMulVector cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Matrix_weightedCov_eqw t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + wxs = zip (repeat 1) xs + cov = M.weightedCov p method wxs + cov' = M.cov p method xs + in M.hermMulVector cov z ~== M.hermMulVector cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Matrix_weightedCov t (WeightedVectorList p wxs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + (ws,xs) = unzip wxs + + w_sum = sum ws + ws' = [ w / w_sum | w <- ws ] + w2_sum = sum [ w*w | w <- ws' ] + scale = case method of { UnbiasedCov -> 1/(1-w2_sum) ; MLCov -> 1 } + + xbar = V.weightedMean p wxs + wys = [ (w, V.sub x xbar) | (w,x) <- zip ws' xs ] + cov' = if w_sum == 0 + then M.constant (p,p) 0 + else foldl' (flip $ \(w,y) -> M.rank1Update (scale*w) y y) + (M.constant (p,p) 0) + wys + + cov = M.weightedCov p method wxs + + in M.hermMulVector cov z ~== M.mulVector NoTrans cov' z + where + n = fromIntegral $ length wxs + _ = typed t $ snd $ head wxs + +prop_Matrix_weightedCovWithMean t (WeightedVectorList p wxs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + xbar = V.weightedMean p wxs + cov' = M.weightedCov p method wxs + cov = M.weightedCovWithMean xbar method wxs + in M.hermMulVector cov z ~== M.hermMulVector cov' z + where + n = fromIntegral $ length wxs + _ = typed t $ snd $ head wxs + +prop_Packed_cov t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + cov' = M.cov p method xs + cov = P.cov p method xs + in P.hermMulVector cov z ~== M.hermMulVector cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Packed_covWithMean t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + xbar = V.mean p xs + cov = P.covWithMean xbar method xs + cov' = P.cov p method xs + in P.hermMulVector cov z ~== P.hermMulVector cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Packed_weightedCov_eqw t (VectorList p xs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + wxs = zip (repeat 1) xs + cov = P.weightedCov p method wxs + cov' = P.cov p method xs + in P.hermMulVector cov z ~== P.hermMulVector cov' z + where + n = fromIntegral $ length xs + _ = typed t $ head xs + +prop_Packed_weightedCov t (WeightedVectorList p wxs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + cov' = M.weightedCov p method wxs + cov = P.weightedCov p method wxs + in P.hermMulVector cov z ~== M.hermMulVector cov' z + where + n = fromIntegral $ length wxs + _ = typed t $ snd $ head wxs + +prop_Packed_weightedCovWithMean t (WeightedVectorList p wxs) = + forAll (Test.vector p) $ \z -> + forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let + xbar = V.weightedMean p wxs + cov' = P.weightedCov p method wxs + cov = P.weightedCovWithMean xbar method wxs + in P.hermMulVector cov z ~== P.hermMulVector cov' z + where + n = fromIntegral $ length wxs + _ = typed t $ snd $ head wxs diff --git a/tests/Typed.hs b/tests/Typed.hs new file mode 100644 --- /dev/null +++ b/tests/Typed.hs @@ -0,0 +1,63 @@ +module Typed( + typed, + + testPropertyI, + testPropertyD, + testPropertyZ, + testPropertyDZ, + + immutableVector, + immutableMatrix, + ) where + + +import Data.Complex( Complex ) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck + +import Numeric.LinearAlgebra.Vector( Vector ) +import Numeric.LinearAlgebra.Matrix( Matrix ) + + +typed :: e -> a e -> a e +typed _ = id + +immutableVector :: Vector e -> Vector e +immutableVector = id + +immutableMatrix :: Matrix e -> Matrix e +immutableMatrix = id + +testPropertyI :: (Testable a) + => TestName + -> (Int -> a) + -> Test +testPropertyI str prop = + testProperty str $ prop undefined + +testPropertyDZ :: (Testable a, Testable b) + => TestName + -> (Double -> a) + -> (Complex Double -> b) + -> Test +testPropertyDZ str propd propz = + testGroup str + [ testProperty "Double" $ propd undefined + , testProperty "Complex Double" $ propz undefined + ] + +testPropertyD :: (Testable a) + => TestName + -> (Double -> a) + -> Test +testPropertyD str prop = + testProperty str $ prop undefined + +testPropertyZ :: (Testable a) + => TestName + -> (Complex Double -> a) + -> Test +testPropertyZ str prop = + testProperty str $ prop undefined + diff --git a/tests/Vector.hs b/tests/Vector.hs new file mode 100644 --- /dev/null +++ b/tests/Vector.hs @@ -0,0 +1,389 @@ +module Vector ( + tests_Vector + ) where + +import Data.AEq +import Debug.Trace +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Test.QuickCheck hiding ( vector ) +import qualified Test.QuickCheck as QC + +import Numeric.LinearAlgebra.Vector( Vector ) +import qualified Numeric.LinearAlgebra.Vector as V + +import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim(..), Assocs(..), + VectorPair(..) ) +import qualified Test.QuickCheck.LinearAlgebra as Test + +import Typed + + +tests_Vector = testGroup "Vector" + [ testPropertyI "dim/fromList" prop_dim_fromList + , testPropertyI "at/fromList" prop_at_fromList + , testPropertyI "zero" prop_zero + , testPropertyI "constant" prop_constant + , testPropertyI "indices" prop_indices + , testPropertyI "elems" prop_elems + , testPropertyI "assocs" prop_assocs + , testPropertyI "update" prop_update + , testPropertyI "accum" prop_accum + , testPropertyI "map" prop_map + , testPropertyI "zipWith" prop_zipWith + , testPropertyI "concat" prop_concat + , testPropertyI "slice" prop_slice + , testPropertyI "splitAt" prop_splitAt + , testPropertyDZ "sumAbs" prop_sumAbs prop_sumAbs + , testPropertyDZ "norm2" prop_norm2 prop_norm2 + , testPropertyDZ "whichMaxAbs1" prop_whichMaxAbs1 prop_whichMaxAbs1 + , testPropertyDZ "whichMaxAbs2" prop_whichMaxAbs1 prop_whichMaxAbs2 + , testPropertyDZ "dot" prop_dot prop_dot + , testPropertyDZ "kronecker" prop_kronecker prop_kronecker + , testPropertyDZ "add" prop_add prop_add + , testPropertyDZ "addWithScale" prop_addWithScale prop_addWithScale + , testPropertyDZ "sub" prop_sub prop_sub + , testPropertyDZ "scale" prop_scale prop_scale + , testPropertyDZ "mul" prop_mul prop_mul + , testPropertyDZ "negate" prop_negate prop_negate + , testPropertyDZ "conjugate" prop_conjugate prop_conjugate + , testPropertyDZ "abs" prop_abs prop_abs + , testPropertyDZ "signum" prop_signum prop_signum + , testPropertyDZ "div" prop_div prop_div + , testPropertyDZ "recip" prop_recip prop_recip + , testPropertyDZ "sqrt" prop_sqrt prop_sqrt + , testPropertyDZ "exp" prop_exp prop_exp + , testPropertyDZ "log" prop_log prop_log + , testPropertyDZ "pow" prop_pow prop_pow + , testPropertyDZ "sin" prop_sin prop_sin + , testPropertyDZ "cos" prop_cos prop_cos + , testPropertyDZ "tan" prop_tan prop_tan + , testPropertyDZ "asin" prop_asin prop_asin + , testPropertyDZ "acos" prop_acos prop_acos + , testPropertyDZ "atan" prop_atan prop_atan + , testPropertyDZ "sinh" prop_sinh prop_sinh + , testPropertyDZ "cosh" prop_cosh prop_cosh + , testPropertyDZ "tanh" prop_tanh prop_tanh + , testPropertyDZ "asinh" prop_asinh prop_asinh + , testPropertyDZ "acosh" prop_acosh prop_acosh + , testPropertyDZ "atanh" prop_atanh prop_atanh + ] + + +{- +abs and signum fail for complex doubles (NB, their ST Vector analogues dont!) + + abs: + + Double: [OK, passed 100 tests] + + Complex Double: [Failed] +*** Failed! Falsifiable (after 18 tests and 1 shrink): +fromList [(-6.7066276741258) :+ 6.89825617623592,(-11.603500174324518) :+ 62.02307490865834] +(used seed -7536870184029858963) + + signum: + + Double: [OK, passed 100 tests] + + Complex Double: [Failed] +*** Failed! Falsifiable (after 2 tests): +fromList [6.727193397617394 :+ 2.38960475296862] +(used seed -6373326149733724790) + +-} + +------------------------- Vector Construction ------------------------------ + +prop_dim_fromList t (Dim n) = + forAll (QC.vector n) $ \es -> let + x = typed t $ V.fromList n es + in V.dim x == n + +prop_at_fromList t (Dim n) = + forAll (QC.vector n) $ \es -> let + x = typed t $ V.fromList n es + in and [ V.at x i === e | (i,e) <- zip [ 0..n-1 ] es ] + +prop_zero t (Dim n) = let + x = typed t $ V.zero n + in x === V.fromList n (replicate n 0) + +prop_constant t (Dim n) e = + V.constant n e === V.fromList n (replicate n e) + where + _ = typed t [e] + + +-------------------------- Accessing Vectors ------------------------------ + +prop_indices t x = + V.indices x === [ 0..((V.dim x) - 1) ] + where + _ = immutableVector x + _ = typed t x + +prop_elems t x = + V.elems x === [ V.at x i | i <- V.indices x ] + where + _ = typed t x + +prop_assocs t x = + V.assocs x === zip (V.indices x) (V.elems x) + where + _ = typed t x + + +------------------------- Incremental Updates ------------------------------ + +prop_update t (Assocs n ies) = + forAll (typed t `fmap` Test.vector n) $ \x -> let + x' = V.update x ies + is = V.indices x + is1 = (fst . unzip) ies + is0 = [ i | i <- is, i `notElem` is1 ] + in and $ + [ V.at x' i `elem` [ e | (i',e) <- ies, i' == i ] + | i <- is1 + ] ++ + [ V.at x' i === V.at x i + | i <- is0 + ] + +prop_accum t (Blind f) (Assocs n ies) = + forAll (typed t `fmap` Test.vector n) $ \x -> let + x' = V.accum f x ies + in x' === V.fromList n [ foldl f e [ e' | (i',e') <- ies, i' == i] + | (i,e) <- V.assocs x ] + where + _ = typed t $ (snd . unzip) ies + + +-------------------------- Derived Vectors ------------------------------ + +prop_map t (Blind f) x = + V.map f x === V.fromList (V.dim x) (map f $ V.elems x) + where + _ = typed t x + _ = typed t $ V.map f x + +prop_zipWith t (Blind f) (VectorPair x y) = + V.zipWith f x y === (V.fromList (V.dim x) $ + zipWith f (V.elems x) (V.elems y)) + where + _ = typed t x + _ = typed t y + _ = typed t $ V.zipWith f x y + +prop_concat t xs = + V.elems (V.concat xs) === concatMap V.elems xs + where + _ = typed t $ head xs + +------------------------------ Vector Views-- -------------------------------- + +prop_slice t x = + forAll (choose (0,n)) $ \n' -> + forAll (choose (0,n-n')) $ \o -> + V.slice o n' x === V.fromList n' (take n' $ drop o $ es) + where + n = V.dim x + es = V.elems x + _ = typed t x + +prop_splitAt t x = + forAll (choose (0,n)) $ \k -> + V.splitAt k x === (V.fromList k $ take k es, + V.fromList (n-k) $ drop k es) + where + n = V.dim x + es = V.elems x + _ = typed t x + + + +-------------------------- Num Vector Operations -------------------------- + +prop_add t (VectorPair x y) = + x `V.add` y === V.zipWith (+) x y + where + _ = typed t x + +prop_addWithScale t alpha (VectorPair x y) = + V.addWithScale alpha x y ~== V.add (V.scale alpha x) y + where + _ = typed t x + +prop_sub t (VectorPair x y) = + x `V.sub` y === V.zipWith (-) x y + where + _ = typed t x + +prop_scale t k x = + V.scale k x ~== V.map (k*) x + where + _ = typed t x + +prop_mul t (VectorPair x y) = + x `V.mul` y === V.zipWith (*) x y + where + _ = typed t x + +prop_negate t x = + V.negate x === V.map negate x + where + _ = typed t x + +prop_conjugate t x = + V.conjugate x === V.map conjugate x + where + _ = typed t x + +prop_abs t x = + V.abs x === V.map abs x + where + _ = typed t x + +prop_signum t x = + V.signum x === V.map signum x + where + _ = typed t x + + +---------------------- Fractional Vector Operations ------------------------ + +prop_div t (VectorPair x y) = + x `V.div` y ~== V.zipWith (/) x y + where + _ = typed t x + +prop_recip t x = + V.recip x ~== V.map (1/) x + where + _ = typed t x + + +---------------------- Floating Vector Operations ------------------------ + +prop_exp t x = + V.exp x ~== V.map exp x + where + _ = typed t x + +prop_sqrt t x = + V.sqrt x ~== V.map sqrt x + where + _ = typed t x + +prop_log t x = + V.log x ~== V.map log x + where + _ = typed t x + +prop_pow t (VectorPair x y) = + x `V.pow` y ~== V.zipWith (**) x y + where + _ = typed t x + +prop_sin t x = + V.sin x ~== V.map sin x + where + _ = typed t x + +prop_cos t x = + V.cos x ~== V.map cos x + where + _ = typed t x + +prop_tan t x = + V.tan x ~== V.map tan x + where + _ = typed t x + +prop_asin t x = + -- trace (show (V.asin x) ++ "\n" ++ (show $ V.map asin x)) $ + V.asin x ~== V.map asin x + where + _ = typed t x + +prop_acos t x = + V.acos x ~== V.map acos x + where + _ = typed t x + +prop_atan t x = + V.atan x ~== V.map atan x + where + _ = typed t x + +prop_sinh t x = + V.sinh x ~== V.map sinh x + where + _ = typed t x + +prop_cosh t x = + V.cosh x ~== V.map cosh x + where + _ = typed t x + +prop_tanh t x = + V.tanh x ~== V.map tanh x + where + _ = typed t x + +prop_asinh t x = + -- trace (show (V.asinh x) ++ "\n" ++ (show $ V.map asinh x)) $ + V.asinh x ~== V.map asinh x + where + _ = typed t x + +prop_acosh t x = + V.acosh x ~== V.map acosh x + where + _ = typed t x + +prop_atanh t x = + V.atanh x ~== V.map atanh x + where + _ = typed t x + + +-------------------------- Vector Properties --------------------------------- + +prop_sumAbs t x = + V.sumAbs x ~== (sum $ map norm1 $ V.elems x) + where + _ = typed t x + +prop_norm2 t x = + V.norm2 x ~== (sqrt $ sum $ map (^^2) $ map norm $ V.elems x) + where + _ = typed t x + +prop_whichMaxAbs1 t x = + (V.dim x > 0) && all (not . isNaN) (map norm1 $ V.elems x) ==> + V.at x i === e + where + (i,e) = V.whichMaxAbs x + _ = typed t x + +prop_whichMaxAbs2 t x = + (V.dim x > 0) && all (not . isNaN) (map norm1 $ V.elems x) ==> + all (<= norm1 e) $ map norm1 (V.elems x) + where + (_,e) = V.whichMaxAbs x + _ = typed t x + +prop_dot t (VectorPair x y) = + V.dot x y ~== sum (V.elems (x * conj y)) + where + conj = V.conjugate + (*) = V.mul + _ = typed t x + +prop_kronecker t x y = + x `V.kronecker` y ~== + V.fromList (V.dim x * V.dim y) + [ e*f | e <- V.elems x, f <- V.elems y ] + where + _ = typed t x