hmatrix-0.17.0.2/0000755000000000000000000000000012722301655011604 5ustar0000000000000000hmatrix-0.17.0.2/LICENSE0000644000000000000000000000277512722301655012624 0ustar0000000000000000Copyright (c) 2006-2014 Alberto Ruiz and other contributors All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * Neither the name of Alberto Ruiz nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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. hmatrix-0.17.0.2/THANKS.md0000644000000000000000000001716612722301655013131 0ustar0000000000000000I thank Don Stewart, Henning Thielemann, Bulat Ziganshin, Heinrich Apfelmus, and all the people in the Haskell mailing lists for their help. I am particularly grateful to Vivian McPhail for his excellent contributions: improved configure.hs, Binary instances for Vector and Matrix, support for Float and Complex Float elements, module reorganization, monadic mapVectorM, and many other improvements. - Nico Mahlo discovered a bug in the eigendecomposition wrapper. - Frederik Eaton discovered a bug in the design of the wrappers. - Eric Kidd has created a wiki page explaining the installation on MacOS X: http://www.haskell.org/haskellwiki/GSLHaskell_on_MacOS_X - Fawzi Mohamed discovered a portability bug in the lapack wrappers. - Pedro E. López de Teruel fixed the interface to lapack. - Antti Siira discovered a bug in the plotting functions. - Paulo Tanimoto helped to fix the configuration of the required libraries. He also discovered the segfault of minimize.hs in ghci. - Xiao-Yong Jin reported a bug on x86_64 caused by the assumptions in f2c.h, which are wrong for this architecture. - Jason Schroeder reported an error in the documentation. - Bulat Ziganshin gave invaluable help for the ST monad interface to in-place modifications. - Don Stewart fixed the implementation of the internal data structures to achieve excellent, C-like performance in Haskell functions which explicitly work with the elements of vectors and matrices. - Dylan Alex Simon improved the numeric instances to allow optimized implementations of signum and abs on Vectors. - Pedro E. López de Teruel discovered the need of asm("finit") to avoid the wrong NaNs produced by foreign functions. - Reiner Pope added support for luSolve, based on (d|z)getrs. Made Matrix a product type and added changes to improve the code generated by hmatrix-syntax. - Simon Beaumont reported the need of QuickCheck<2 and the invalid asm("finit") on ppc. He also contributed the configuration options for the accelerate framework on OS X. - Daniel Schüssler added compatibility with QuickCheck 2 as well as QuickCheck 1 using the C preprocessor. He also added some implementations for the new "shrink" method of class Arbitrary. - Tracy Wadleigh improved the definitions of (|>) and (><), which now apply an appropriate 'take' to the given lists so that they may be safely used on lists that are too long (or infinite). - Chris Waterson improved the configure.hs program for OS/X. - Erik de Castro Lopo added buildVector and buildMatrix, which take a size parameter(s) and a function that maps vector/matrix indices to the values at that position. - Jean-Francois Tremblay discovered an error in the tutorial. - Gilberto Camara contributed improved blas and lapack dlls for Windows. - Heinrich Apfelmus fixed hmatrix.cabal for OS/X. He also tested the package on PPC discovering a problem in zgesdd. - Felipe Lessa tested the performance of GSL special function bindings and contributed the cabal flag "safe-cheap". - Ozgur Akgun suggested better symbols for the Bound constructors in the Linear Programming package. - Tim Sears reported the zgesdd problem also in intel mac. - Max Suica simplified the installation on Windows and improved the instructions. - John Billings first reported an incompatibility with QuickCheck>=2.1.1 - Alexey Khudyakov cleaned up PRAGMAS and fixed some hlint suggestions. - Torsten Kemps-Benedix reported an installation problem in OS/X. - Stefan Kersten fixed hmatrix.cabal for 64-bit ghc-7 in OS/X - Sacha Sokoloski reported an installation problem on Arch Linux and helped with the configuration. - Carter Schonwald helped with the configuration for Homebrew OS X and found a tolerance problem in test "1E5 rots". He also discovered a bug in the signature of cmap and fixed the cabal file. - Duncan Coutts reported a problem with configure.hs and contributed a solution and a simplified Setup.lhs. - Mark Wright fixed the import of vector >= 0.8. - Bas van Dijk fixed the import of vector >= 0.8, got rid of some deprecation warnings, used more explicit imports, and updated to ghc-7.4. - Tom Nielsen discovered a problem in Config.hs, exposed by link problems in Ubuntu 11.10 beta, and fixed the link options on freebsd. - Daniel Fischer reported some Haddock markup errors. - Danny Chan added support for integration over infinite intervals, and fixed Configure.hs using platform independent functions. - Clark Gaebel removed superfluous thread safety. - Jeffrey Burdges reported a glpk link problem on OS/X - Jian Zhang reported the Windows installation problem due to new ODE interface. - Mihaly Barasz and Ben Gamari fixed mapMatrix* and mapMatrixWithIndex - Takano Akio fixed off-by-one errors in gsl-aux.c producing segfaults. - Alex Lang implemented uniRoot and uniRootJ for one-dimensional root-finding, and fixed asRow and asColumn for empty vectors. - Mike Ledger contributed alternative FFI helpers for matrix interoperation with C - Stephen J. Barr suggested flipping argument order in the double integral example - Greg Horn fixed the bus error on ghci 64-bit. - Kristof Bastiaensen added bindings for one-dimensional minimization. - Matthew Peddie added bindings for gsl_integrate_cquad doubly-adaptive quadrature for difficult integrands. - Ben Gamari exposed matrixFromVector for Development. - greg94301 reported tolerance issues in the tests. - Clemens Lang updated the MacPort installation instructions. - Henning Thielemann reported the pinv inefficient implementation and the need of pkgconfig-depends. - bdoering reported the problem of zero absolute tolerance in the integration functions. - Alexei Uimanov replaced fromList by Vector.fromList. - Adam Vogt updated the code for ghc-7.7 - Mike Meyer (mwm) added freeBSD library configuration information. - tfgit updated the OSX installation instructions via Homebrew - "yokto" and "ttylec" reported the problem with the dot product of complex vectors. - Samium Gromoff reported a build failure caused by a size_t - int mismatch. - Denis Laxalde separated the gsl tests from the base ones. - Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and added Cholesky to Static. - Dylan Thurston reported an error in the glpk documentation and ambiguity in the description of linearSolve. - Adrian Victor Crisciu developed an installation method for platforms which don't provide shared lapack libraries. - Ian Ross reported the max/minIndex bug. - Niklas Hambüchen improved the documentation. - "erdeszt" optimized "conv" using a direct vector reverse. - John Shahbazian added support for openBLAS. - "yongqli" reported the bug in randomVector (rand() is not thread-safe and drand48_r() is not portable). - Kiwamu Ishikura improved randomVector for OSX - C.J. East fixed the examples for simplex. - Ben Gamari contributed fixes for ghc 7.10 - Piotr Mardziel added general sparse constraints to simplex and the interface to glp_exact - Maxim Baz fixed an instance declaration for ghc 7.11 - Thomas M. DuBuisson fixed a C include file. - Matt Peddie wrote the interfaces to the interpolation and simulated annealing modules. - "maxc01" solved uninstallability in FreeBSD and improved urandom - "ntfrgl" added {take,drop}Last{Rows,Columns} and odeSolveVWith with generalized step control function and fixed link errors related to mod/mod_l. - "cruegge" discovered a bug in the conjugate gradient solver for sparse symmetric systems. - Ilan Godik and Douglas McClean helped with Windows support. - Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation issues, and added support for stack-based build. hmatrix-0.17.0.2/Setup.lhs0000644000000000000000000000011712722301655013413 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hmatrix-0.17.0.2/CHANGELOG0000644000000000000000000001455512722301655013030 0ustar00000000000000000.17.0.0 -------- * eigSH, chol, and other functions that work with Hermitian or symmetric matrices now take a special "Herm" argument that can be created by means of "sym" or "mTm". The unchecked versions of those functions have been removed and we use "trustSym" to create the Herm type when the matrix is known to be Hermitian/symmetric. * Improved matrix extraction (??) and rectangular matrix slices without data copy * Basic support of Int32 and Int64 elements * remap, more general cond, sortIndex * Experimental support of type safe modular arithmetic, including linear system solver and LU factorization * Elementary row operations and inplace matrix slice products in the ST monad * Improved development tools. * Old compatibility modules removed, simpler organization of internal modules * unitary, pairwiseD2, tr' * ldlPacked, ldlSolve for indefinite symmetric systems (apparently not faster than the general solver based on the LU) * LU, LDL, and QR types for these compact decompositions. 0.16.1.0 -------- * Added (|||) and (===) for "besides" and "above" * rowOuters 0.16.0.0 -------- * The modules Numeric.GSL.* have been moved to the new package hmatrix-gsl. * The package "hmatrix" now depends only on BLAS and LAPACK and the license has been changed to BSD3. * Added more organized reexport modules: Numeric.LinearAlgebra.HMatrix Numeric.LinearAlgebra.Data Numeric.LinearAlgebra.Devel For normal usage we only need to import Numeric.LinearAlgebra.HMatrix. (The documentation is now hidden for Data.Packed.*, Numeric.Container, and the other Numeric.LinearAlgebra.* modules, but they continue to be exposed for backwards compatibility.) * Added support for empty arrays, extending automatic conformability (very useful for construction of block matrices). * Added experimental support for sparse linear systems. * Added experimental support for static dimension checking and inference using type-level literals. * Added a different operator for the matrix-vector product. (available from the new reexport module). * "join" deprecated (use "vjoin"). * "dot" now conjugates the first input vector. * Added "udot" (unconjugated dot product). * Added to/from ByteString * Added "sortVector", "roundVector" * Added Monoid instance for Matrix using matrix product. * Added several pretty print functions * Improved "build", "konst", "linspace", "LSDiv", loadMatrix', and other small changes. * In hmatrix-glpk: (:=>:) change to (:>=:). Added L_1 linear system solvers. * Improved error messages. * Added many usage examples in the documentation. 0.15.2.0 -------- * general pinvTol and improved pinv 0.15.1.0 -------- * One-dimensional minimization * Doubly-adaptive quadrature for difficult integrands 0.15.0.0 -------- * Data.Packed.Foreign (additional FFI helpers) * NFData instance of Matrix * Unidimensional root finding * In Numeric.LinearAlgebra.Util: pairwise2D, rowOuters, null1, null1sym, size, unitary, mt, (¦), (?), (¿) * diagBlock * meanCov moved to Container 0.14.1.0 -------- * In Numeric.LinearAlgebra.Util: convolution: corr, conv, corr2, conv2, separable, corrMin kronecker: vec, vech, dup, vtrans 0.14.0.0 -------- * integration over infinite intervals * msadams and msbdf methods for ode * Numeric.LinearAlgebra.Util * (<\>) extended to multiple right-hand sides * orth 0.13.0.0 -------- * tests moved to new package hmatrix-tests 0.11.2.0 -------- * geigSH' (symmetric generalized eigensystem) * mapVectorWithIndex 0.11.1.0 -------- * exported Mul * mapMatrixWithIndex{,M,M_} 0.11.0.0 -------- * flag -fvector default = True * invlndet (inverse and log of determinant) * step, cond * find * assoc, accum 0.10.0.0 -------- * Module reorganization * Support for Float and Complex Float elements (excluding LAPACK computations) * Binary instances for Vector and Matrix * optimiseMult * mapVectorM, mapVectorWithIndexM, unzipVectorWith, and related functions. * diagRect admits diagonal vectors of any length without producing an error, and takes an additional argument for the off-diagonal elements. * different signatures in some functions 0.9.3.0 -------- * flag -fvector to optionally use Data.Vector.Storable.Vector without any conversion. * Simpler module structure. * toBlocks, toBlocksEvery * cholSolve, mbCholSH * GSL Nonlinear Least-Squares fitting using Levenberg-Marquardt. * GSL special functions moved to separate package hmatrix-special. * Added offset of Vector, allowing fast, noncopy subVector (slice). Vector is now identical to Roman Leshchinskiy's Data.Vector.Storable.Vector, so we can convert from/to them in O(1). * Removed Data.Packed.Convert, see examples/vector.hs 0.8.3.0 -------- * odeSolve * Matrix arithmetic automatically replicates matrix with single row/column * latexFormat, dispcf 0.8.2.0 -------- * fromRows/fromColumns now automatically expand vectors of dim 1 to match the common dimension. fromBlocks also replicates single row/column matrices. Previously all dimensions had to be exactly the same. * display utilities: dispf, disps, vecdisp * scalar * minimizeV, minimizeVD, using Vector instead of lists. 0.8.1.0 -------- * runBenchmarks 0.8.0.0 -------- * singularValues, fullSVD, thinSVD, compactSVD, leftSV, rightSV and complete interface to [d|z]gesdd. Algorithms based on the SVD of large matrices can now be significantly faster. * eigenvalues, eigenvaluesSH * linearSolveLS, rq 0.7.2.0 -------- * ranksv 0.7.1.0 -------- * buildVector/buildMatrix * removed NFData instances 0.6.0.0 -------- * added randomVector, gaussianSample, uniformSample, meanCov * added rankSVD, nullspaceSVD * rank, nullspacePrec, and economy svd defined in terms of ranksvd. * economy svd now admits zero rank matrices and return a "degenerate rank 1" decomposition with zero singular value. * added NFData instances for Matrix and Vector. * liftVector, liftVector2 replaced by mapVector, zipVector. hmatrix-0.17.0.2/hmatrix.cabal0000644000000000000000000001051112722301655014242 0ustar0000000000000000Name: hmatrix Version: 0.17.0.2 License: BSD3 License-file: LICENSE Author: Alberto Ruiz Maintainer: Alberto Ruiz Stability: provisional Homepage: https://github.com/albertoruiz/hmatrix Synopsis: Numeric Linear Algebra Description: Linear systems, matrix decompositions, and other numerical computations based on BLAS and LAPACK. . Standard interface: "Numeric.LinearAlgebra". . Safer interface with statically checked dimensions: "Numeric.LinearAlgebra.Static". . Code examples: Category: Math tested-with: GHC==8.0 cabal-version: >=1.8 build-type: Simple extra-source-files: THANKS.md CHANGELOG extra-source-files: src/Internal/C/lapack-aux.h flag openblas description: Link with OpenBLAS (https://github.com/xianyi/OpenBLAS) optimized libraries. default: False manual: True library Build-Depends: base >= 4.8 && < 5, binary, array, deepseq, random, split, bytestring, storable-complex, vector >= 0.8 hs-source-dirs: src exposed-modules: Numeric.LinearAlgebra Numeric.LinearAlgebra.Devel Numeric.LinearAlgebra.Data Numeric.LinearAlgebra.HMatrix Numeric.LinearAlgebra.Static other-modules: Internal.Vector Internal.Devel Internal.Vectorized Internal.Matrix Internal.Foreign Internal.ST Internal.IO Internal.Element Internal.Conversion Internal.LAPACK Internal.Numeric Internal.Algorithms Internal.Random Internal.Container Internal.Sparse Internal.Convolution Internal.Chain Numeric.Vector Internal.CG Numeric.Matrix Internal.Util Internal.Modular Internal.Static C-sources: src/Internal/C/lapack-aux.c src/Internal/C/vector-aux.c extensions: ForeignFunctionInterface, CPP ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans -fprof-auto cc-options: -O4 -Wall if arch(x86_64) cc-options: -msse2 if arch(i386) cc-options: -msse2 cpp-options: -DBINARY if os(OSX) if flag(openblas) extra-lib-dirs: /opt/local/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack extra-lib-dirs: /opt/local/lib/ include-dirs: /opt/local/include/ extra-lib-dirs: /usr/local/lib/ include-dirs: /usr/local/include/ if arch(i386) cc-options: -arch i386 frameworks: Accelerate if os(freebsd) if flag(openblas) extra-lib-dirs: /usr/local/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack extra-lib-dirs: /usr/local/lib include-dirs: /usr/local/include extra-libraries: gfortran if os(windows) if flag(openblas) extra-libraries: libopenblas else extra-libraries: blas lapack if os(linux) if flag(openblas) extra-lib-dirs: /usr/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack if arch(x86_64) cc-options: -fPIC source-repository head type: git location: https://github.com/albertoruiz/hmatrix hmatrix-0.17.0.2/src/0000755000000000000000000000000012722301655012373 5ustar0000000000000000hmatrix-0.17.0.2/src/Numeric/0000755000000000000000000000000012722301655013775 5ustar0000000000000000hmatrix-0.17.0.2/src/Numeric/Matrix.hs0000644000000000000000000000605312722301655015601 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Matrix -- Copyright : (c) Alberto Ruiz 2014 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Matrix'. -- -- In arithmetic operations one-component -- vectors and matrices automatically expand to match the dimensions of the other operand. ----------------------------------------------------------------------------- module Numeric.Matrix ( ) where ------------------------------------------------------------------- import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Numeric import qualified Data.Monoid as M import Data.List(partition) import Internal.Chain ------------------------------------------------------------------- instance Container Matrix a => Eq (Matrix a) where (==) = equal instance (Container Matrix a, Num a, Num (Vector a)) => Num (Matrix a) where (+) = liftMatrix2Auto (+) (-) = liftMatrix2Auto (-) negate = liftMatrix negate (*) = liftMatrix2Auto (*) signum = liftMatrix signum abs = liftMatrix abs fromInteger = (1><1) . return . fromInteger --------------------------------------------------- instance (Container Vector a, Fractional a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where fromRational n = (1><1) [fromRational n] (/) = liftMatrix2Auto (/) --------------------------------------------------------- instance (Floating a, Container Vector a, Floating (Vector a), Fractional (Matrix a)) => Floating (Matrix a) where sin = liftMatrix sin cos = liftMatrix cos tan = liftMatrix tan asin = liftMatrix asin acos = liftMatrix acos atan = liftMatrix atan sinh = liftMatrix sinh cosh = liftMatrix cosh tanh = liftMatrix tanh asinh = liftMatrix asinh acosh = liftMatrix acosh atanh = liftMatrix atanh exp = liftMatrix exp log = liftMatrix log (**) = liftMatrix2Auto (**) sqrt = liftMatrix sqrt pi = (1><1) [pi] -------------------------------------------------------------------------------- isScalar m = rows m == 1 && cols m == 1 adaptScalarM f1 f2 f3 x y | isScalar x = f1 (x @@>(0,0) ) y | isScalar y = f3 x (y @@>(0,0) ) | otherwise = f2 x y instance (Container Vector t, Eq t, Num (Vector t), Product t) => M.Monoid (Matrix t) where mempty = 1 mappend = adaptScalarM scale mXm (flip scale) mconcat xs = work (partition isScalar xs) where work (ss,[]) = product ss work (ss,ms) = scl (product ss) (optimiseMult ms) scl x m | isScalar x && x00 == 1 = m | otherwise = scale x00 m where x00 = x @@> (0,0) hmatrix-0.17.0.2/src/Numeric/Vector.hs0000644000000000000000000001255312722301655015601 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vector -- Copyright : (c) Alberto Ruiz 2011 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Vector'. -- ----------------------------------------------------------------------------- module Numeric.Vector () where import Internal.Vectorized import Internal.Vector import Internal.Numeric import Internal.Conversion ------------------------------------------------------------------- adaptScalar f1 f2 f3 x y | dim x == 1 = f1 (x@>0) y | dim y == 1 = f3 x (y@>0) | otherwise = f2 x y ------------------------------------------------------------------ instance Num (Vector I) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapI Sign abs = vectorMapI Abs fromInteger = fromList . return . fromInteger instance Num (Vector Z) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapL Sign abs = vectorMapL Abs fromInteger = fromList . return . fromInteger instance Num (Vector Float) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapF Sign abs = vectorMapF Abs fromInteger = fromList . return . fromInteger instance Num (Vector Double) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapR Sign abs = vectorMapR Abs fromInteger = fromList . return . fromInteger instance Num (Vector (Complex Double)) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapC Sign abs = vectorMapC Abs fromInteger = fromList . return . fromInteger instance Num (Vector (Complex Float)) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapQ Sign abs = vectorMapQ Abs fromInteger = fromList . return . fromInteger --------------------------------------------------- instance (Container Vector a, Num (Vector a), Fractional a) => Fractional (Vector a) where fromRational n = fromList [fromRational n] (/) = adaptScalar f divide g where r `f` v = scaleRecip r v v `g` r = scale (recip r) v ------------------------------------------------------- instance Floating (Vector Float) where sin = vectorMapF Sin cos = vectorMapF Cos tan = vectorMapF Tan asin = vectorMapF ASin acos = vectorMapF ACos atan = vectorMapF ATan sinh = vectorMapF Sinh cosh = vectorMapF Cosh tanh = vectorMapF Tanh asinh = vectorMapF ASinh acosh = vectorMapF ACosh atanh = vectorMapF ATanh exp = vectorMapF Exp log = vectorMapF Log sqrt = vectorMapF Sqrt (**) = adaptScalar (vectorMapValF PowSV) (vectorZipF Pow) (flip (vectorMapValF PowVS)) pi = fromList [pi] ------------------------------------------------------------- instance Floating (Vector Double) where sin = vectorMapR Sin cos = vectorMapR Cos tan = vectorMapR Tan asin = vectorMapR ASin acos = vectorMapR ACos atan = vectorMapR ATan sinh = vectorMapR Sinh cosh = vectorMapR Cosh tanh = vectorMapR Tanh asinh = vectorMapR ASinh acosh = vectorMapR ACosh atanh = vectorMapR ATanh exp = vectorMapR Exp log = vectorMapR Log sqrt = vectorMapR Sqrt (**) = adaptScalar (vectorMapValR PowSV) (vectorZipR Pow) (flip (vectorMapValR PowVS)) pi = fromList [pi] ------------------------------------------------------------- instance Floating (Vector (Complex Double)) where sin = vectorMapC Sin cos = vectorMapC Cos tan = vectorMapC Tan asin = vectorMapC ASin acos = vectorMapC ACos atan = vectorMapC ATan sinh = vectorMapC Sinh cosh = vectorMapC Cosh tanh = vectorMapC Tanh asinh = vectorMapC ASinh acosh = vectorMapC ACosh atanh = vectorMapC ATanh exp = vectorMapC Exp log = vectorMapC Log sqrt = vectorMapC Sqrt (**) = adaptScalar (vectorMapValC PowSV) (vectorZipC Pow) (flip (vectorMapValC PowVS)) pi = fromList [pi] ----------------------------------------------------------- instance Floating (Vector (Complex Float)) where sin = vectorMapQ Sin cos = vectorMapQ Cos tan = vectorMapQ Tan asin = vectorMapQ ASin acos = vectorMapQ ACos atan = vectorMapQ ATan sinh = vectorMapQ Sinh cosh = vectorMapQ Cosh tanh = vectorMapQ Tanh asinh = vectorMapQ ASinh acosh = vectorMapQ ACosh atanh = vectorMapQ ATanh exp = vectorMapQ Exp log = vectorMapQ Log sqrt = vectorMapQ Sqrt (**) = adaptScalar (vectorMapValQ PowSV) (vectorZipQ Pow) (flip (vectorMapValQ PowVS)) pi = fromList [pi] hmatrix-0.17.0.2/src/Numeric/LinearAlgebra.hs0000644000000000000000000001340012722301655017017 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra Copyright : (c) Alberto Ruiz 2006-15 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- module Numeric.LinearAlgebra ( -- * Basic types and data manipulation -- | This package works with 2D ('Matrix') and 1D ('Vector') -- arrays of real ('R') or complex ('C') double precision numbers. -- Single precision and machine integers are also supported for -- basic arithmetic and data manipulation. module Numeric.LinearAlgebra.Data, -- * Numeric classes -- | -- The standard numeric classes are defined elementwise: -- -- >>> vector [1,2,3] * vector [3,0,-2] -- fromList [3.0,0.0,-6.0] -- -- >>> matrix 3 [1..9] * ident 3 -- (3><3) -- [ 1.0, 0.0, 0.0 -- , 0.0, 5.0, 0.0 -- , 0.0, 0.0, 9.0 ] -- * Autoconformable dimensions -- | -- In most operations, single-element vectors and matrices -- (created from numeric literals or using 'scalar'), and matrices -- with just one row or column, automatically -- expand to match the dimensions of the other operand: -- -- >>> 5 + 2*ident 3 :: Matrix Double -- (3><3) -- [ 7.0, 5.0, 5.0 -- , 5.0, 7.0, 5.0 -- , 5.0, 5.0, 7.0 ] -- -- >>> (4><3) [1..] + row [10,20,30] -- (4><3) -- [ 11.0, 22.0, 33.0 -- , 14.0, 25.0, 36.0 -- , 17.0, 28.0, 39.0 -- , 20.0, 31.0, 42.0 ] -- -- * Products -- ** Dot dot, (<.>), -- ** Matrix-vector (#>), (<#), (!#>), -- ** Matrix-matrix (<>), -- | The matrix product is also implemented in the "Data.Monoid" instance, where -- single-element matrices (created from numeric literals or using 'scalar') -- are used for scaling. -- -- >>> import Data.Monoid as M -- >>> let m = matrix 3 [1..6] -- >>> m M.<> 2 M.<> diagl[0.5,1,0] -- (2><3) -- [ 1.0, 4.0, 0.0 -- , 4.0, 10.0, 0.0 ] -- -- 'mconcat' uses 'optimiseMult' to get the optimal association order. -- ** Other outer, kronecker, cross, scale, add, sumElements, prodElements, -- * Linear systems -- ** General (<\>), linearSolveLS, linearSolveSVD, -- ** Determined linearSolve, luSolve, luPacked, luSolve', luPacked', -- ** Symmetric indefinite ldlSolve, ldlPacked, -- ** Positive definite cholSolve, -- ** Sparse cgSolve, cgSolve', -- * Inverse and pseudoinverse inv, pinv, pinvTol, -- * Determinant and rank rcond, rank, det, invlndet, -- * Norms Normed(..), norm_Frob, norm_nuclear, -- * Nullspace and range orth, nullspace, null1, null1sym, -- * Singular value decomposition svd, thinSVD, compactSVD, singularValues, leftSV, rightSV, -- * Eigendecomposition eig, eigSH, eigenvalues, eigenvaluesSH, geigSH, -- * QR qr, rq, qrRaw, qrgr, -- * Cholesky chol, mbChol, -- * LU lu, luFact, -- * Hessenberg hess, -- * Schur schur, -- * Matrix functions expm, sqrtm, matFunc, -- * Correlation and convolution corr, conv, corrMin, corr2, conv2, -- * Random arrays Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample, -- * Misc meanCov, rowOuters, pairwiseD2, unitary, peps, relativeError, magnit, haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv, iC, sym, mTm, trustSym, unSym, -- * Auxiliary classes Element, Container, Product, Numeric, LSDiv, Herm, Complexable, RealElement, RealOf, ComplexOf, SingleOf, DoubleOf, IndexOf, Field, Linear(), Additive(), Transposable, LU(..), LDL(..), QR(..), CGState(..), Testable(..) ) where import Numeric.LinearAlgebra.Data import Numeric.Matrix() import Numeric.Vector() import Internal.Matrix import Internal.Container hiding ((<>)) import Internal.Numeric hiding (mul) import Internal.Algorithms hiding (linearSolve,Normed,orth,luPacked',linearSolve',luSolve',ldlPacked') import qualified Internal.Algorithms as A import Internal.Util import Internal.Random import Internal.Sparse((!#>)) import Internal.CG import Internal.Conversion {- | dense matrix product >>> let a = (3><5) [1..] >>> a (3><5) [ 1.0, 2.0, 3.0, 4.0, 5.0 , 6.0, 7.0, 8.0, 9.0, 10.0 , 11.0, 12.0, 13.0, 14.0, 15.0 ] >>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0] >>> b (5><2) [ 1.0, 3.0 , 0.0, 2.0 , -1.0, 5.0 , 7.0, 7.0 , 6.0, 0.0 ] >>> a <> b (3><2) [ 56.0, 50.0 , 121.0, 135.0 , 186.0, 220.0 ] -} (<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t (<>) = mXm infixr 8 <> {- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. @ a = (2><2) [ 1.0, 2.0 , 3.0, 5.0 ] @ @ b = (2><3) [ 6.0, 1.0, 10.0 , 15.0, 3.0, 26.0 ] @ >>> linearSolve a b Just (2><3) [ -1.4802973661668753e-15, 0.9999999999999997, 1.999999999999997 , 3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ] >>> let Just x = it >>> disp 5 x 2x3 -0.00000 1.00000 2.00000 3.00000 0.00000 4.00000 >>> a <> x (2><3) [ 6.0, 1.0, 10.0 , 15.0, 3.0, 26.0 ] -} linearSolve m b = A.mbLinearSolve m b -- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'. nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m) -- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'. orth m = orthSVD (Left (1*eps)) m (leftSV m) hmatrix-0.17.0.2/src/Numeric/LinearAlgebra/0000755000000000000000000000000012722301655016465 5ustar0000000000000000hmatrix-0.17.0.2/src/Numeric/LinearAlgebra/HMatrix.hs0000644000000000000000000000144012722301655020374 0ustar0000000000000000-------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.HMatrix Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional compatibility with previous version, to be removed -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.HMatrix ( module Numeric.LinearAlgebra, (¦),(——),ℝ,ℂ,(<·>),app,mul, cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH' ) where import Numeric.LinearAlgebra import Internal.Util import Internal.Algorithms(cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH') infixr 8 <·> (<·>) :: Numeric t => Vector t -> Vector t -> t (<·>) = dot app m v = m #> v mul a b = a <> b hmatrix-0.17.0.2/src/Numeric/LinearAlgebra/Data.hs0000644000000000000000000000513212722301655017673 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Data Copyright : (c) Alberto Ruiz 2015 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional This module provides functions for creation and manipulation of vectors and matrices, IO, and other utilities. -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Data( -- * Elements R,C,I,Z,type(./.), -- * Vector {- | 1D arrays are storable vectors directly reexported from the vector package. -} fromList, toList, (|>), vector, range, idxs, -- * Matrix {- | The main data type of hmatrix is a 2D dense array defined on top of a storable vector. The internal representation is suitable for direct interface with standard numeric libraries. -} (><), matrix, tr, tr', -- * Dimensions size, rows, cols, -- * Conversion from\/to lists fromLists, toLists, row, col, -- * Conversions vector\/matrix flatten, reshape, asRow, asColumn, fromRows, toRows, fromColumns, toColumns, -- * Indexing atIndex, Indexable(..), -- * Construction scalar, Konst(..), Build(..), assoc, accum, linspace, -- ones, zeros, -- * Diagonal ident, diag, diagl, diagRect, takeDiag, -- * Vector extraction subVector, takesV, vjoin, -- * Matrix extraction Extractor(..), (??), (?), (¿), fliprl, flipud, subMatrix, takeRows, dropRows, takeColumns, dropColumns, remap, -- * Block matrix fromBlocks, (|||), (===), diagBlock, repmat, toBlocks, toBlocksEvery, -- * Mapping functions conj, cmap, cmod, step, cond, -- * Find elements find, maxIndex, minIndex, maxElement, minElement, sortVector, sortIndex, -- * Sparse AssocMatrix, toDense, mkSparse, mkDiagR, mkDense, -- * IO disp, loadMatrix, loadMatrix', saveMatrix, latexFormat, dispf, disps, dispcf, format, dispDots, dispBlanks, dispShort, -- * Element conversion Convert(..), roundVector, fromInt,toInt,fromZ,toZ, -- * Misc arctan2, separable, fromArray2D, module Data.Complex, Mod, Vector, Matrix, GMatrix, nRows, nCols ) where import Internal.Vector import Internal.Vectorized import Internal.Matrix hiding (size) import Internal.Element import Internal.IO import Internal.Numeric import Internal.Container import Internal.Util hiding ((&)) import Data.Complex import Internal.Sparse import Internal.Modular hmatrix-0.17.0.2/src/Numeric/LinearAlgebra/Static.hs0000644000000000000000000004054112722301655020254 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {- | Module : Numeric.LinearAlgebra.Static Copyright : (c) Alberto Ruiz 2014 License : BSD3 Stability : experimental Experimental interface with statically checked dimensions. See code examples at http://dis.um.es/~alberto/hmatrix/static.html. -} module Numeric.LinearAlgebra.Static( -- * Vector ℝ, R, vec2, vec3, vec4, (&), (#), split, headTail, vector, linspace, range, dim, -- * Matrix L, Sq, build, row, col, (|||),(===), splitRows, splitCols, unrow, uncol, tr, eye, diag, blockAt, matrix, -- * Complex C, M, Her, her, 𝑖, -- * Products (<>),(#>),(<.>), -- * Linear Systems linSolve, (<\>), -- * Factorizations svd, withCompactSVD, svdTall, svdFlat, Eigen(..), withNullspace, qr, chol, -- * Misc mean, Disp(..), Domain(..), withVector, withMatrix, toRows, toColumns, Sized(..), Diag(..), Sym, sym, mTm, unSym, (<·>) ) where import GHC.TypeLits import Numeric.LinearAlgebra hiding ( (<>),(#>),(<.>),Konst(..),diag, disp,(===),(|||), row,col,vector,matrix,linspace,toRows,toColumns, (<\>),fromList,takeDiag,svd,eig,eigSH, eigenvalues,eigenvaluesSH,build, qr,size,dot,chol,range,R,C,sym,mTm,unSym) import qualified Numeric.LinearAlgebra as LA import Data.Proxy(Proxy) import Internal.Static import Control.Arrow((***)) ud1 :: R n -> Vector ℝ ud1 (R (Dim v)) = v infixl 4 & (&) :: forall n . (KnownNat n, 1 <= n) => R n -> ℝ -> R (n+1) u & x = u # (konst x :: R 1) infixl 4 # (#) :: forall n m . (KnownNat n, KnownNat m) => R n -> R m -> R (n+m) (R u) # (R v) = R (vconcat u v) vec2 :: ℝ -> ℝ -> R 2 vec2 a b = R (gvec2 a b) vec3 :: ℝ -> ℝ -> ℝ -> R 3 vec3 a b c = R (gvec3 a b c) vec4 :: ℝ -> ℝ -> ℝ -> ℝ -> R 4 vec4 a b c d = R (gvec4 a b c d) vector :: KnownNat n => [ℝ] -> R n vector = fromList matrix :: (KnownNat m, KnownNat n) => [ℝ] -> L m n matrix = fromList linspace :: forall n . KnownNat n => (ℝ,ℝ) -> R n linspace (a,b) = v where v = mkR (LA.linspace (size v) (a,b)) range :: forall n . KnownNat n => R n range = v where v = mkR (LA.linspace d (1,fromIntegral d)) d = size v dim :: forall n . KnownNat n => R n dim = v where v = mkR (scalar (fromIntegral $ size v)) -------------------------------------------------------------------------------- ud2 :: L m n -> Matrix ℝ ud2 (L (Dim (Dim x))) = x -------------------------------------------------------------------------------- diag :: KnownNat n => R n -> Sq n diag = diagR 0 eye :: KnownNat n => Sq n eye = diag 1 -------------------------------------------------------------------------------- blockAt :: forall m n . (KnownNat m, KnownNat n) => ℝ -> Int -> Int -> Matrix Double -> L m n blockAt x r c a = res where z = scalar x z1 = LA.konst x (r,c) z2 = LA.konst x (max 0 (m'-(ra+r)), max 0 (n'-(ca+c))) ra = min (rows a) . max 0 $ m'-r ca = min (cols a) . max 0 $ n'-c sa = subMatrix (0,0) (ra, ca) a (m',n') = size res res = mkL $ fromBlocks [[z1,z,z],[z,sa,z],[z,z,z2]] -------------------------------------------------------------------------------- row :: R n -> L 1 n row = mkL . asRow . ud1 --col :: R n -> L n 1 col v = tr . row $ v unrow :: L 1 n -> R n unrow = mkR . head . LA.toRows . ud2 --uncol :: L n 1 -> R n uncol v = unrow . tr $ v infixl 2 === (===) :: (KnownNat r1, KnownNat r2, KnownNat c) => L r1 c -> L r2 c -> L (r1+r2) c a === b = mkL (extract a LA.=== extract b) infixl 3 ||| -- (|||) :: (KnownNat r, KnownNat c1, KnownNat c2) => L r c1 -> L r c2 -> L r (c1+c2) a ||| b = tr (tr a === tr b) type Sq n = L n n --type CSq n = CL n n type GL = forall n m . (KnownNat n, KnownNat m) => L m n type GSq = forall n . KnownNat n => Sq n isKonst :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ,(Int,Int)) isKonst s@(unwrap -> x) | singleM x = Just (x `atIndex` (0,0), (size s)) | otherwise = Nothing isKonstC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ,(Int,Int)) isKonstC s@(unwrap -> x) | singleM x = Just (x `atIndex` (0,0), (size s)) | otherwise = Nothing infixr 8 <> (<>) :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n (<>) = mulR infixr 8 #> (#>) :: (KnownNat m, KnownNat n) => L m n -> R n -> R m (#>) = appR infixr 8 <·> (<·>) :: R n -> R n -> ℝ (<·>) = dotR infixr 8 <.> (<.>) :: R n -> R n -> ℝ (<.>) = dotR -------------------------------------------------------------------------------- class Diag m d | m -> d where takeDiag :: m -> d instance forall n . (KnownNat n) => Diag (L n n) (R n) where takeDiag m = mkR (LA.takeDiag (extract m)) instance forall m n . (KnownNat m, KnownNat n, m <= n+1) => Diag (L m n) (R m) where takeDiag m = mkR (LA.takeDiag (extract m)) instance forall m n . (KnownNat m, KnownNat n, n <= m+1) => Diag (L m n) (R n) where takeDiag m = mkR (LA.takeDiag (extract m)) -------------------------------------------------------------------------------- linSolve :: (KnownNat m, KnownNat n) => L m m -> L m n -> Maybe (L m n) linSolve (extract -> a) (extract -> b) = fmap mkL (LA.linearSolve a b) (<\>) :: (KnownNat m, KnownNat n, KnownNat r) => L m n -> L m r -> L n r (extract -> a) <\> (extract -> b) = mkL (a LA.<\> b) svd :: (KnownNat m, KnownNat n) => L m n -> (L m m, R n, L n n) svd (extract -> m) = (mkL u, mkR s', mkL v) where (u,s,v) = LA.svd m s' = vjoin [s, z] z = LA.konst 0 (max 0 (cols m - LA.size s)) svdTall :: (KnownNat m, KnownNat n, n <= m) => L m n -> (L m n, R n, L n n) svdTall (extract -> m) = (mkL u, mkR s, mkL v) where (u,s,v) = LA.thinSVD m svdFlat :: (KnownNat m, KnownNat n, m <= n) => L m n -> (L m m, R m, L n m) svdFlat (extract -> m) = (mkL u, mkR s, mkL v) where (u,s,v) = LA.thinSVD m -------------------------------------------------------------------------------- class Eigen m l v | m -> l, m -> v where eigensystem :: m -> (l,v) eigenvalues :: m -> l newtype Sym n = Sym (Sq n) deriving Show sym :: KnownNat n => Sq n -> Sym n sym m = Sym $ (m + tr m)/2 mTm :: (KnownNat m, KnownNat n) => L m n -> Sym n mTm x = Sym (tr x <> x) unSym :: Sym n -> Sq n unSym (Sym x) = x 𝑖 :: Sized ℂ s c => s 𝑖 = konst iC newtype Her n = Her (M n n) her :: KnownNat n => M n n -> Her n her m = Her $ (m + LA.tr m)/2 instance KnownNat n => Eigen (Sym n) (R n) (L n n) where eigenvalues (Sym (extract -> m)) = mkR . LA.eigenvaluesSH . LA.trustSym $ m eigensystem (Sym (extract -> m)) = (mkR l, mkL v) where (l,v) = LA.eigSH . LA.trustSym $ m instance KnownNat n => Eigen (Sq n) (C n) (M n n) where eigenvalues (extract -> m) = mkC . LA.eigenvalues $ m eigensystem (extract -> m) = (mkC l, mkM v) where (l,v) = LA.eig m chol :: KnownNat n => Sym n -> Sq n chol (extract . unSym -> m) = mkL $ LA.chol $ LA.trustSym m -------------------------------------------------------------------------------- withNullspace :: forall m n z . (KnownNat m, KnownNat n) => L m n -> (forall k . (KnownNat k) => L n k -> z) -> z withNullspace (LA.nullspace . extract -> a) f = case someNatVal $ fromIntegral $ cols a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k) withCompactSVD :: forall m n z . (KnownNat m, KnownNat n) => L m n -> (forall k . (KnownNat k) => (L m k, R k, L n k) -> z) -> z withCompactSVD (LA.compactSVD . extract -> (u,s,v)) f = case someNatVal $ fromIntegral $ LA.size s of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL u :: L m k, mkR s :: R k, mkL v :: L n k) -------------------------------------------------------------------------------- qr :: (KnownNat m, KnownNat n) => L m n -> (L m m, L m n) qr (extract -> x) = (mkL q, mkL r) where (q,r) = LA.qr x -- use qrRaw? -------------------------------------------------------------------------------- split :: forall p n . (KnownNat p, KnownNat n, p<=n) => R n -> (R p, R (n-p)) split (extract -> v) = ( mkR (subVector 0 p' v) , mkR (subVector p' (LA.size v - p') v) ) where p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int headTail :: (KnownNat n, 1<=n) => R n -> (ℝ, R (n-1)) headTail = ((!0) . extract *** id) . split splitRows :: forall p m n . (KnownNat p, KnownNat m, KnownNat n, p<=m) => L m n -> (L p n, L (m-p) n) splitRows (extract -> x) = ( mkL (takeRows p' x) , mkL (dropRows p' x) ) where p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int splitCols :: forall p m n. (KnownNat p, KnownNat m, KnownNat n, KnownNat (n-p), p<=n) => L m n -> (L m p, L m (n-p)) splitCols = (tr *** tr) . splitRows . tr toRows :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R n] toRows (LA.toRows . extract -> vs) = map mkR vs toColumns :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R m] toColumns (LA.toColumns . extract -> vs) = map mkR vs -------------------------------------------------------------------------------- build :: forall m n . (KnownNat n, KnownNat m) => (ℝ -> ℝ -> ℝ) -> L m n build f = r where r = mkL $ LA.build (size r) f -------------------------------------------------------------------------------- withVector :: forall z . Vector ℝ -> (forall n . (KnownNat n) => R n -> z) -> z withVector v f = case someNatVal $ fromIntegral $ LA.size v of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> f (mkR v :: R m) withMatrix :: forall z . Matrix ℝ -> (forall m n . (KnownNat m, KnownNat n) => L m n -> z) -> z withMatrix a f = case someNatVal $ fromIntegral $ rows a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> case someNatVal $ fromIntegral $ cols a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy n)) -> f (mkL a :: L m n) -------------------------------------------------------------------------------- class Domain field vec mat | mat -> vec field, vec -> mat field, field -> mat vec where mul :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => mat m k -> mat k n -> mat m n app :: forall m n . (KnownNat m, KnownNat n) => mat m n -> vec n -> vec m dot :: forall n . (KnownNat n) => vec n -> vec n -> field cross :: vec 3 -> vec 3 -> vec 3 diagR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => field -> vec k -> mat m n instance Domain ℝ R L where mul = mulR app = appR dot = dotR cross = crossR diagR = diagRectR instance Domain ℂ C M where mul = mulC app = appC dot = dotC cross = crossC diagR = diagRectC -------------------------------------------------------------------------------- mulR :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n mulR (isKonst -> Just (a,(_,k))) (isKonst -> Just (b,_)) = konst (a * b * fromIntegral k) mulR (isDiag -> Just (0,a,_)) (isDiag -> Just (0,b,_)) = diagR 0 (mkR v :: R k) where v = a' * b' n = min (LA.size a) (LA.size b) a' = subVector 0 n a b' = subVector 0 n b mulR (isDiag -> Just (0,a,_)) (extract -> b) = mkL (asColumn a * takeRows (LA.size a) b) mulR (extract -> a) (isDiag -> Just (0,b,_)) = mkL (takeColumns (LA.size b) a * asRow b) mulR a b = mkL (extract a LA.<> extract b) appR :: (KnownNat m, KnownNat n) => L m n -> R n -> R m appR (isDiag -> Just (0, w, _)) v = mkR (w * subVector 0 (LA.size w) (extract v)) appR m v = mkR (extract m LA.#> extract v) dotR :: R n -> R n -> ℝ dotR (ud1 -> u) (ud1 -> v) | singleV u || singleV v = sumElements (u * v) | otherwise = udot u v crossR :: R 3 -> R 3 -> R 3 crossR (extract -> x) (extract -> y) = vec3 z1 z2 z3 where z1 = x!1*y!2-x!2*y!1 z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 -------------------------------------------------------------------------------- mulC :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => M m k -> M k n -> M m n mulC (isKonstC -> Just (a,(_,k))) (isKonstC -> Just (b,_)) = konst (a * b * fromIntegral k) mulC (isDiagC -> Just (0,a,_)) (isDiagC -> Just (0,b,_)) = diagR 0 (mkC v :: C k) where v = a' * b' n = min (LA.size a) (LA.size b) a' = subVector 0 n a b' = subVector 0 n b mulC (isDiagC -> Just (0,a,_)) (extract -> b) = mkM (asColumn a * takeRows (LA.size a) b) mulC (extract -> a) (isDiagC -> Just (0,b,_)) = mkM (takeColumns (LA.size b) a * asRow b) mulC a b = mkM (extract a LA.<> extract b) appC :: (KnownNat m, KnownNat n) => M m n -> C n -> C m appC (isDiagC -> Just (0, w, _)) v = mkC (w * subVector 0 (LA.size w) (extract v)) appC m v = mkC (extract m LA.#> extract v) dotC :: KnownNat n => C n -> C n -> ℂ dotC (unwrap -> u) (unwrap -> v) | singleV u || singleV v = sumElements (conj u * v) | otherwise = u LA.<.> v crossC :: C 3 -> C 3 -> C 3 crossC (extract -> x) (extract -> y) = mkC (LA.fromList [z1, z2, z3]) where z1 = x!1*y!2-x!2*y!1 z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 -------------------------------------------------------------------------------- diagRectR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℝ -> R k -> L m n diagRectR x v | m' == 1 = mkL (LA.diagRect x ev m' n') | m'*n' > 0 = r | otherwise = matrix [] where r = mkL (asRow (vjoin [scalar x, ev, zeros])) ev = extract v zeros = LA.konst x (max 0 ((min m' n') - LA.size ev)) (m',n') = size r diagRectC :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℂ -> C k -> M m n diagRectC x v | m' == 1 = mkM (LA.diagRect x ev m' n') | m'*n' > 0 = r | otherwise = fromList [] where r = mkM (asRow (vjoin [scalar x, ev, zeros])) ev = extract v zeros = LA.konst x (max 0 ((min m' n') - LA.size ev)) (m',n') = size r -------------------------------------------------------------------------------- mean :: (KnownNat n, 1<=n) => R n -> ℝ mean v = v <·> (1/dim) test :: (Bool, IO ()) test = (ok,info) where ok = extract (eye :: Sq 5) == ident 5 && (unwrap .unSym) (mTm sm :: Sym 3) == tr ((3><3)[1..]) LA.<> (3><3)[1..] && unwrap (tm :: L 3 5) == LA.matrix 5 [1..15] && thingS == thingD && precS == precD && withVector (LA.vector [1..15]) sumV == sumElements (LA.fromList [1..15]) info = do print $ u print $ v print (eye :: Sq 3) print $ ((u & 5) + 1) <·> v print (tm :: L 2 5) print (tm <> sm :: L 2 3) print thingS print thingD print precS print precD print $ withVector (LA.vector [1..15]) sumV splittest sumV w = w <·> konst 1 u = vec2 3 5 𝕧 x = vector [x] :: R 1 v = 𝕧 2 & 4 & 7 tm :: GL tm = lmat 0 [1..] lmat :: forall m n . (KnownNat m, KnownNat n) => ℝ -> [ℝ] -> L m n lmat z xs = r where r = mkL . reshape n' . LA.fromList . take (m'*n') $ xs ++ repeat z (m',n') = size r sm :: GSq sm = lmat 0 [1..] thingS = (u & 1) <·> tr q #> q #> v where q = tm :: L 10 3 thingD = vjoin [ud1 u, 1] LA.<.> tr m LA.#> m LA.#> ud1 v where m = LA.matrix 3 [1..30] precS = (1::Double) + (2::Double) * ((1 :: R 3) * (u & 6)) <·> konst 2 #> v precD = 1 + 2 * vjoin[ud1 u, 6] LA.<.> LA.konst 2 (LA.size (ud1 u) +1, LA.size (ud1 v)) LA.#> ud1 v splittest = do let v = range :: R 7 a = snd (split v) :: R 4 print $ a print $ snd . headTail . snd . headTail $ v print $ first (vec3 1 2 3) print $ second (vec3 1 2 3) print $ third (vec3 1 2 3) print $ (snd $ splitRows eye :: L 4 6) where first v = fst . headTail $ v second v = first . snd . headTail $ v third v = first . snd . headTail . snd . headTail $ v instance (KnownNat n', KnownNat m') => Testable (L n' m') where checkT _ = test hmatrix-0.17.0.2/src/Numeric/LinearAlgebra/Devel.hs0000644000000000000000000000451412722301655020064 0ustar0000000000000000-------------------------------------------------------------------------------- {- | Module : Numeric.HMatrix.Devel Copyright : (c) Alberto Ruiz 2014 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional The library can be easily extended using the tools in this module. -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Devel( -- * FFI helpers -- | Sample usage, to upload a perspective matrix to a shader. -- -- @ glUniformMatrix4fv 0 1 (fromIntegral gl_TRUE) \`appMatrix\` perspective 0.01 100 (pi\/2) (4\/3) -- @ module Internal.Foreign, -- * FFI tools -- | See @examples/devel@ in the repository. createVector, createMatrix, TransArray(..), MatrixOrder(..), orderOf, cmat, fmat, matrixFromVector, unsafeFromForeignPtr, unsafeToForeignPtr, check, (//), (#|), at', atM', fi, ti, -- * ST -- | In-place manipulation inside the ST monad. -- See @examples/inplace.hs@ in the repository. -- ** Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- ** Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix, mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..), -- ** Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector, unsafeThawVector, unsafeFreezeVector, newUndefinedMatrix, unsafeReadMatrix, unsafeWriteMatrix, unsafeThawMatrix, unsafeFreezeMatrix, -- * Special maps and zips mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith, mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_, foldLoop, foldVector, foldVectorG, foldVectorWithIndex, mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_, liftMatrix, liftMatrix2, liftMatrix2Auto, -- * Sparse representation CSR(..), fromCSR, mkCSR, GMatrix(..), -- * Misc toByteString, fromByteString, showInternal ) where import Internal.Foreign import Internal.Devel import Internal.ST import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Sparse hmatrix-0.17.0.2/src/Internal/0000755000000000000000000000000012722301655014147 5ustar0000000000000000hmatrix-0.17.0.2/src/Internal/Chain.hs0000644000000000000000000001264412722301655015534 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.Chain -- Copyright : (c) Vivian McPhail 2010 -- License : BSD3 -- -- Maintainer : Vivian McPhail gmail.com> -- Stability : provisional -- Portability : portable -- -- optimisation of association order for chains of matrix multiplication -- ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} module Internal.Chain ( optimiseMult, ) where import Data.Maybe import Internal.Matrix import Internal.Numeric import qualified Data.Array.IArray as A ----------------------------------------------------------------------------- {- | Provide optimal association order for a chain of matrix multiplications and apply the multiplications. The algorithm is the well-known O(n\^3) dynamic programming algorithm that builds a pyramid of optimal associations. > m1, m2, m3, m4 :: Matrix Double > m1 = (10><15) [1..] > m2 = (15><20) [1..] > m3 = (20><5) [1..] > m4 = (5><10) [1..] > >>> optimiseMult [m1,m2,m3,m4] will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@ The naive left-to-right multiplication would take @4500@ scalar multiplications whereas the optimised version performs @2750@ scalar multiplications. The complexity in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions, 5 lookups, 2 updates) + a constant (= three table allocations) -} optimiseMult :: Product t => [Matrix t] -> Matrix t optimiseMult = chain ----------------------------------------------------------------------------- type Matrices a = A.Array Int (Matrix a) type Sizes = A.Array Int (Int,Int) type Cost = A.Array Int (A.Array Int (Maybe Int)) type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int)))) update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a) update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])] newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int)) newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n] where subArray i = A.listArray (1,i) (repeat Nothing) newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int)))) newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n] where subArray i = A.listArray (1,i) (repeat Nothing) matricesToSizes :: [Matrix a] -> Sizes matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms chain :: Product a => [Matrix a] -> Matrix a chain [] = error "chain: zero matrices to multiply" chain [m] = m chain [ml,mr] = ml `multiply` mr chain ms = let ln = length ms ma = A.listArray (1,ln) ms mz = matricesToSizes ms i = chain_cost mz in chain_paren (ln,ln) i ma chain_cost :: Sizes -> Indexes chain_cost mz = let (_,u) = A.bounds mz cost = newWorkSpaceCost u ixes = newWorkSpaceIndexes u (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u) in i chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes) chain_cost' sci@(mz,cost,ixes) (r,c) | c == 1 = let cost' = update cost (r,c) (Just 0) ixes' = update ixes (r,c) (Just ((r,c),(r,c))) in (mz,cost',ixes') | otherwise = minimum_cost sci (r,c) minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes) minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu) smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes) smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) = let op_cost = fromJust ((cost A.! lr) A.! lc) + fromJust ((cost A.! rr) A.! rc) + fst (mz A.! (lr-lc+1)) * snd (mz A.! lc) * snd (mz A.! rr) cost' = (cost A.! r) A.! c in case cost' of Nothing -> let cost'' = update cost (r,c) (Just op_cost) ixes'' = update ixes (r,c) (Just ix) in (mz,cost'',ixes'') Just ct -> if op_cost < ct then let cost'' = update cost (r,c) (Just op_cost) ixes'' = update ixes (r,c) (Just ix) in (mz,cost'',ixes'') else (mz,cost,ixes) fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)] in map (partner (r,c)) fs' partner (r,c) (a,b) = ((r-b, c-b), (a,b)) order 0 = [] order n = order (n-1) ++ zip (repeat n) [1..n] chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c in if lr == rr && lc == rc then (ma A.! lr) else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) -------------------------------------------------------------------------- {- TESTS -- optimal association is ((m1*(m2*m3))*m4) m1, m2, m3, m4 :: Matrix Double m1 = (10><15) [1..] m2 = (15><20) [1..] m3 = (20><5) [1..] m4 = (5><10) [1..] -} hmatrix-0.17.0.2/src/Internal/Algorithms.hs0000644000000000000000000007772212722301655016633 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- {- | Module : Internal.Algorithms Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional High level generic interface to common matrix computations. Specific functions for particular base types can also be explicitly imported from "Numeric.LinearAlgebra.LAPACK". -} ----------------------------------------------------------------------------- module Internal.Algorithms where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Conversion import Internal.LAPACK as LAPACK import Internal.Numeric import Data.List(foldl1') import qualified Data.Array as A import Internal.ST import Internal.Vectorized(range) import Control.DeepSeq {- | Generic linear algebra functions for double precision real and complex matrices. (Single precision data can be converted using 'single' and 'double'). -} class (Numeric t, Convert t, Normed Matrix t, Normed Vector t, Floating t, Linear t Vector, Linear t Matrix, Additive (Vector t), Additive (Matrix t), RealOf t ~ Double) => Field t where svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t) thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t) sv' :: Matrix t -> Vector Double luPacked' :: Matrix t -> (Matrix t, [Int]) luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t) linearSolve' :: Matrix t -> Matrix t -> Matrix t cholSolve' :: Matrix t -> Matrix t -> Matrix t ldlPacked' :: Matrix t -> (Matrix t, [Int]) ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t linearSolveLS' :: Matrix t -> Matrix t -> Matrix t eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eigSH'' :: Matrix t -> (Vector Double, Matrix t) eigOnly :: Matrix t -> Vector (Complex Double) eigOnlySH :: Matrix t -> Vector Double cholSH' :: Matrix t -> Matrix t mbCholSH' :: Matrix t -> Maybe (Matrix t) qr' :: Matrix t -> (Matrix t, Vector t) qrgr' :: Int -> (Matrix t, Vector t) -> Matrix t hess' :: Matrix t -> (Matrix t, Matrix t) schur' :: Matrix t -> (Matrix t, Matrix t) instance Field Double where svd' = svdRd thinSVD' = thinSVDRd sv' = svR luPacked' = luR luSolve' (l_u,perm) = lusR l_u perm linearSolve' = linearSolveR -- (luSolve . luPacked) ?? mbLinearSolve' = mbLinearSolveR cholSolve' = cholSolveR linearSolveLS' = linearSolveLSR linearSolveSVD' = linearSolveSVDR Nothing eig' = eigR eigSH'' = eigS eigOnly = eigOnlyR eigOnlySH = eigOnlyS cholSH' = cholS mbCholSH' = mbCholS qr' = qrR qrgr' = qrgrR hess' = unpackHess hessR schur' = schurR ldlPacked' = ldlR ldlSolve'= uncurry ldlsR instance Field (Complex Double) where #ifdef NOZGESDD svd' = svdC thinSVD' = thinSVDC #else svd' = svdCd thinSVD' = thinSVDCd #endif sv' = svC luPacked' = luC luSolve' (l_u,perm) = lusC l_u perm linearSolve' = linearSolveC mbLinearSolve' = mbLinearSolveC cholSolve' = cholSolveC linearSolveLS' = linearSolveLSC linearSolveSVD' = linearSolveSVDC Nothing eig' = eigC eigOnly = eigOnlyC eigSH'' = eigH eigOnlySH = eigOnlyH cholSH' = cholH mbCholSH' = mbCholH qr' = qrC qrgr' = qrgrC hess' = unpackHess hessC schur' = schurC ldlPacked' = ldlC ldlSolve' = uncurry ldlsC -------------------------------------------------------------- square m = rows m == cols m vertical m = rows m >= cols m exactHermitian m = m `equal` ctrans m -------------------------------------------------------------- {- | Full singular value decomposition. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = svd a >>> disp 3 u 5x5 -0.101 0.768 0.614 0.028 -0.149 -0.249 0.488 -0.503 0.172 0.646 -0.396 0.208 -0.405 -0.660 -0.449 -0.543 -0.072 -0.140 0.693 -0.447 -0.690 -0.352 0.433 -0.233 0.398 >>> s fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15] >>> disp 3 v 3x3 -0.519 -0.751 0.408 -0.576 -0.046 -0.816 -0.632 0.659 0.408 >>> let d = diagRect 0 s 5 3 >>> disp 3 d 5x3 35.183 0.000 0.000 0.000 1.477 0.000 0.000 0.000 0.000 0.000 0.000 0.000 >>> disp 3 $ u <> d <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) svd = {-# SCC "svd" #-} g . svd' where g (u,s,v) = (u,s,tr v) {- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@. If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> tr v@. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = thinSVD a >>> disp 3 u 5x3 -0.101 0.768 0.614 -0.249 0.488 -0.503 -0.396 0.208 -0.405 -0.543 -0.072 -0.140 -0.690 -0.352 0.433 >>> s fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15] >>> disp 3 v 3x3 -0.519 -0.751 0.408 -0.576 -0.046 -0.816 -0.632 0.659 0.408 >>> disp 3 $ u <> diag s <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) thinSVD = {-# SCC "thinSVD" #-} g . thinSVD' where g (u,s,v) = (u,s,tr v) -- | Singular values only. singularValues :: Field t => Matrix t -> Vector Double singularValues = {-# SCC "singularValues" #-} sv' -- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values. -- -- If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> tr v@. fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t) fullSVD m = (u,d,v) where (u,s,v) = svd m d = diagRect 0 s r c r = rows m c = cols m {- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = compactSVD a >>> disp 3 u 5x2 -0.101 0.768 -0.249 0.488 -0.396 0.208 -0.543 -0.072 -0.690 -0.352 >>> s fromList [35.18264833189422,1.4769076999800903] >>> disp 3 u 5x2 -0.101 0.768 -0.249 0.488 -0.396 0.208 -0.543 -0.072 -0.690 -0.352 >>> disp 3 $ u <> diag s <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) compactSVD m = (u', subVector 0 d s, v') where (u,s,v) = thinSVD m d = rankSVD (1*eps) m s `max` 1 u' = takeColumns d u v' = takeColumns d v -- | Singular values and all right singular vectors (as columns). rightSV :: Field t => Matrix t -> (Vector Double, Matrix t) rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v) | otherwise = let (_,s,v) = svd m in (s,v) -- | Singular values and all left singular vectors (as columns). leftSV :: Field t => Matrix t -> (Matrix t, Vector Double) leftSV m | vertical m = let (u,s,_) = svd m in (u,s) | otherwise = let (u,s,_) = thinSVD m in (u,s) -------------------------------------------------------------- -- | LU decomposition of a matrix in a compact format. data LU t = LU (Matrix t) [Int] deriving Show instance (NFData t, Numeric t) => NFData (LU t) where rnf (LU m _) = rnf m -- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'. luPacked :: Field t => Matrix t -> LU t luPacked x = {-# SCC "luPacked" #-} LU m p where (m,p) = luPacked' x -- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'. luSolve :: Field t => LU t -> Matrix t -> Matrix t luSolve (LU m p) = {-# SCC "luSolve" #-} luSolve' (m,p) -- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. -- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system. linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t linearSolve = {-# SCC "linearSolve" #-} linearSolve' -- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. mbLinearSolve :: Field t => Matrix t -> Matrix t -> Maybe (Matrix t) mbLinearSolve = {-# SCC "linearSolve" #-} mbLinearSolve' -- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'. cholSolve :: Field t => Matrix t -- ^ Cholesky decomposition of the coefficient matrix -> Matrix t -- ^ right hand sides -> Matrix t -- ^ solution cholSolve = {-# SCC "cholSolve" #-} cholSolve' -- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value. linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD' -- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'. linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS' -------------------------------------------------------------------------------- -- | LDL decomposition of a complex Hermitian or real symmetric matrix in a compact format. data LDL t = LDL (Matrix t) [Int] deriving Show instance (NFData t, Numeric t) => NFData (LDL t) where rnf (LDL m _) = rnf m -- | Similar to 'ldlPacked', without checking that the input matrix is hermitian or symmetric. It works with the lower triangular part. ldlPackedSH :: Field t => Matrix t -> LDL t ldlPackedSH x = {-# SCC "ldlPacked" #-} LDL m p where (m,p) = ldlPacked' x -- | Obtains the LDL decomposition of a matrix in a compact data structure suitable for 'ldlSolve'. ldlPacked :: Field t => Herm t -> LDL t ldlPacked (Herm m) = ldlPackedSH m -- | Solution of a linear system (for several right hand sides) from a precomputed LDL factorization obtained by 'ldlPacked'. -- -- Note: this can be slower than the general solver based on the LU decomposition. ldlSolve :: Field t => LDL t -> Matrix t -> Matrix t ldlSolve (LDL m p) = {-# SCC "ldlSolve" #-} ldlSolve' (m,p) -------------------------------------------------------------- {- | Eigenvalues (not ordered) and eigenvectors (as columns) of a general square matrix. If @(s,v) = eig m@ then @m \<> v == v \<> diag s@ @ a = (3><3) [ 3, 0, -2 , 4, 5, -1 , 3, 1, 0 ] :: Matrix Double @ >>> let (l, v) = eig a >>> putStr . dispcf 3 . asRow $ l 1x3 1.925+1.523i 1.925-1.523i 4.151 >>> putStr . dispcf 3 $ v 3x3 -0.455+0.365i -0.455-0.365i 0.181 0.603 0.603 -0.978 0.033+0.543i 0.033-0.543i -0.104 >>> putStr . dispcf 3 $ complex a <> v 3x3 -1.432+0.010i -1.432-0.010i 0.753 1.160+0.918i 1.160-0.918i -4.059 -0.763+1.096i -0.763-1.096i -0.433 >>> putStr . dispcf 3 $ v <> diag l 3x3 -1.432+0.010i -1.432-0.010i 0.753 1.160+0.918i 1.160-0.918i -4.059 -0.763+1.096i -0.763-1.096i -0.433 -} eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eig = {-# SCC "eig" #-} eig' -- | Eigenvalues (not ordered) of a general square matrix. eigenvalues :: Field t => Matrix t -> Vector (Complex Double) eigenvalues = {-# SCC "eigenvalues" #-} eigOnly -- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t) eigSH' = {-# SCC "eigSH'" #-} eigSH'' -- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. eigenvaluesSH' :: Field t => Matrix t -> Vector Double eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH {- | Eigenvalues and eigenvectors (as columns) of a complex hermitian or real symmetric matrix, in descending order. If @(s,v) = eigSH m@ then @m == v \<> diag s \<> tr v@ @ a = (3><3) [ 1.0, 2.0, 3.0 , 2.0, 4.0, 5.0 , 3.0, 5.0, 6.0 ] @ >>> let (l, v) = eigSH a >>> l fromList [11.344814282762075,0.17091518882717918,-0.5157294715892575] >>> disp 3 $ v <> diag l <> tr v 3x3 1.000 2.000 3.000 2.000 4.000 5.000 3.000 5.000 6.000 -} eigSH :: Field t => Herm t -> (Vector Double, Matrix t) eigSH (Herm m) = eigSH' m -- | Eigenvalues (in descending order) of a complex hermitian or real symmetric matrix. eigenvaluesSH :: Field t => Herm t -> Vector Double eigenvaluesSH (Herm m) = eigenvaluesSH' m -------------------------------------------------------------- -- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.) data QR t = QR (Matrix t) (Vector t) instance (NFData t, Numeric t) => NFData (QR t) where rnf (QR m _) = rnf m -- | QR factorization. -- -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. qr :: Field t => Matrix t -> (Matrix t, Matrix t) qr = {-# SCC "qr" #-} unpackQR . qr' -- | Compute the QR decomposition of a matrix in compact form. qrRaw :: Field t => Matrix t -> QR t qrRaw m = QR x v where (x,v) = qr' m -- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'. -- qrgr :: Field t => Int -> QR t -> Matrix t qrgr n (QR a t) | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" | otherwise = qrgr' n (a,t) -- | RQ factorization. -- -- If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular. rq :: Field t => Matrix t -> (Matrix t, Matrix t) rq m = {-# SCC "rq" #-} (r,q) where (q',r') = qr $ trans $ rev1 m r = rev2 (trans r') q = rev2 (trans q') rev1 = flipud . fliprl rev2 = fliprl . flipud -- | Hessenberg factorization. -- -- If @(p,h) = hess m@ then @m == p \<> h \<> tr p@, where p is unitary -- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal). hess :: Field t => Matrix t -> (Matrix t, Matrix t) hess = hess' -- | Schur factorization. -- -- If @(u,s) = schur m@ then @m == u \<> s \<> tr u@, where u is unitary -- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is -- upper triangular in 2x2 blocks. -- -- \"Anything that the Jordan decomposition can do, the Schur decomposition -- can do better!\" (Van Loan) schur :: Field t => Matrix t -> (Matrix t, Matrix t) schur = schur' -- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'. mbCholSH :: Field t => Matrix t -> Maybe (Matrix t) mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH' -- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. cholSH :: Field t => Matrix t -> Matrix t cholSH = cholSH' -- | Cholesky factorization of a positive definite hermitian or symmetric matrix. -- -- If @c = chol m@ then @c@ is upper triangular and @m == tr c \<> c@. chol :: Field t => Herm t -> Matrix t chol (Herm m) = {-# SCC "chol" #-} cholSH' m -- | Similar to 'chol', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'. mbChol :: Field t => Herm t -> Maybe (Matrix t) mbChol (Herm m) = {-# SCC "mbChol" #-} mbCholSH' m -- | Joint computation of inverse and logarithm of determinant of a square matrix. invlndet :: Field t => Matrix t -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det)) invlndet m | square m = (im,(ladm,sdm)) | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix" where lp@(LU lup perm) = luPacked m s = signlp (rows m) perm dg = toList $ takeDiag $ lup ladm = sum $ map (log.abs) dg sdm = s* product (map signum dg) im = luSolve lp (ident (rows m)) -- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'. det :: Field t => Matrix t -> t det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup) | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix" where LU lup perm = luPacked m s = signlp (rows m) perm -- | Explicit LU factorization of a general matrix. -- -- If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular, -- u is upper triangular, p is a permutation matrix and s is the signature of the permutation. lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t) lu = luFact . luPacked -- | Inverse of a square matrix. See also 'invlndet'. inv :: Field t => Matrix t -> Matrix t inv m | square m = m `linearSolve` ident (rows m) | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix" -- | Pseudoinverse of a general matrix with default tolerance ('pinvTol' 1, similar to GNU-Octave). pinv :: Field t => Matrix t -> Matrix t pinv = pinvTol 1 {- | @pinvTol r@ computes the pseudoinverse of a matrix with tolerance @tol=r*g*eps*(max rows cols)@, where g is the greatest singular value. @ m = (3><3) [ 1, 0, 0 , 0, 1, 0 , 0, 0, 1e-10] :: Matrix Double @ >>> pinv m 1. 0. 0. 0. 1. 0. 0. 0. 10000000000. >>> pinvTol 1E8 m 1. 0. 0. 0. 1. 0. 0. 0. 1. -} pinvTol :: Field t => Double -> Matrix t -> Matrix t pinvTol t m = v' `mXm` diag s' `mXm` ctrans u' where (u,s,v) = thinSVD m sl@(g:_) = toList s s' = real . fromList . map rec $ sl rec x = if x <= g*tol then x else 1/x tol = (fromIntegral (max r c) * g * t * eps) r = rows m c = cols m d = dim s u' = takeColumns d u v' = takeColumns d v -- | Numeric rank of a matrix from the SVD decomposition. rankSVD :: Element t => Double -- ^ numeric zero (e.g. 1*'eps') -> Matrix t -- ^ input matrix m -> Vector Double -- ^ 'sv' of m -> Int -- ^ rank of m rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s) -- | Numeric rank of a matrix from its singular values. ranksv :: Double -- ^ numeric zero (e.g. 1*'eps') -> Int -- ^ maximum dimension of the matrix -> [Double] -- ^ singular values -> Int -- ^ rank of m ranksv teps maxdim s = k where g = maximum s tol = fromIntegral maxdim * g * teps s' = filter (>tol) s k = if g > teps then length s' else 0 -- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave). eps :: Double eps = 2.22044604925031e-16 -- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1 peps :: RealFloat x => x peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x) ----------------------------------------------------------------------- -- | The nullspace of a matrix from its precomputed SVD decomposition. nullspaceSVD :: Field t => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'), -- or Right \"theoretical\" matrix rank. -> Matrix t -- ^ input matrix m -> (Vector Double, Matrix t) -- ^ 'rightSV' of m -> Matrix t -- ^ nullspace nullspaceSVD hint a (s,v) = vs where tol = case hint of Left t -> t _ -> eps k = case hint of Right t -> t _ -> rankSVD tol a s vs = dropColumns k v -- | The nullspace of a matrix. See also 'nullspaceSVD'. nullspacePrec :: Field t => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps') -> Matrix t -- ^ input matrix -> [Vector t] -- ^ list of unitary vectors spanning the nullspace nullspacePrec t m = toColumns $ nullspaceSVD (Left (t*eps)) m (rightSV m) -- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision. nullVector :: Field t => Matrix t -> Vector t nullVector = last . nullspacePrec 1 -- | The range space a matrix from its precomputed SVD decomposition. orthSVD :: Field t => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'), -- or Right \"theoretical\" matrix rank. -> Matrix t -- ^ input matrix m -> (Matrix t, Vector Double) -- ^ 'leftSV' of m -> Matrix t -- ^ orth orthSVD hint a (v,s) = vs where tol = case hint of Left t -> t _ -> eps k = case hint of Right t -> t _ -> rankSVD tol a s vs = takeColumns k v orth :: Field t => Matrix t -> [Vector t] -- ^ Return an orthonormal basis of the range space of a matrix orth m = take r $ toColumns u where (u,s,_) = compactSVD m r = ranksv eps (max (rows m) (cols m)) (toList s) ------------------------------------------------------------------------ -- many thanks, quickcheck! haussholder :: (Field a) => a -> Vector a -> Matrix a haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w)) where w = asColumn v zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs) where xs = toList v zt 0 v = v zt k v = vjoin [subVector 0 (dim v - k) v, konst' 0 k] unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t) unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r) where cs = toColumns pq m = rows pq n = cols pq mn = min m n r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs vs = zipWith zh [1..mn] cs hs = zipWith haussholder (toList tau) vs q = foldl1' mXm hs unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t) unpackHess hf m | rows m == 1 = ((1><1)[1],m) | otherwise = (uH . hf) m uH (pq, tau) = (p,h) where cs = toColumns pq m = rows pq n = cols pq mn = min m n h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs vs = zipWith zh [2..mn] cs hs = zipWith haussholder (toList tau) vs p = foldl1' mXm hs -------------------------------------------------------------------------- -- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values. rcond :: Field t => Matrix t -> Double rcond m = last s / head s where s = toList (singularValues m) -- | Number of linearly independent rows or columns. See also 'ranksv' rank :: Field t => Matrix t -> Int rank m = rankSVD eps m (singularValues m) {- expm' m = case diagonalize (complex m) of Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices" where exp = vectorMapC Exp -} diagonalize m = if rank v == n then Just (l,v) else Nothing where n = rows m (l,v) = if exactHermitian m then let (l',v') = eigSH (trustSym m) in (real l', v') else eig m -- | Generic matrix functions for diagonalizable matrices. For instance: -- -- @logm = matFunc log@ -- matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) matFunc f m = case diagonalize m of Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v Nothing -> error "Sorry, matFunc requires a diagonalizable matrix" -------------------------------------------------------------- golubeps :: Integer -> Integer -> Double golubeps p q = a * fromIntegral b / fromIntegral c where a = 2^^(3-p-q) b = fact p * fact q c = fact (p+q) * fact (p+q+1) fact n = product [1..n] epslist :: [(Int,Double)] epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]] geps delta = head [ k | (k,g) <- epslist, g Matrix t -> Matrix t expm = expGolub expGolub :: Field t => Matrix t -> Matrix t expGolub m = iterate msq f !! j where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m a = m */ fromIntegral ((2::Int)^j) q = geps eps -- 7 steps eye = ident (rows m) work (k,c,x,n,d) = (k',c',x',n',d') where k' = k+1 c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k) x' = a <> x n' = n |+| (c' .* x') d' = d |+| (((-1)^k * c') .* x') (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q f = linearSolve df nf msq x = x <> x (<>) = multiply v */ x = scale (recip x) v (.*) = scale (|+|) = add -------------------------------------------------------------- {- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia. It only works with invertible matrices that have a real solution. @m = (2><2) [4,9 ,0,4] :: Matrix Double@ >>> sqrtm m (2><2) [ 2.0, 2.25 , 0.0, 2.0 ] For diagonalizable matrices you can try 'matFunc' @sqrt@: >>> matFunc sqrt ((2><2) [1,0,0,-1]) (2><2) [ 1.0 :+ 0.0, 0.0 :+ 0.0 , 0.0 :+ 0.0, 0.0 :+ 1.0 ] -} sqrtm :: Field t => Matrix t -> Matrix t sqrtm = sqrtmInv sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x)) where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a | otherwise = fixedPoint (b:rest) fixedPoint _ = error "fixedpoint with impossible inputs" f (y,z) = (0.5 .* (y |+| inv z), 0.5 .* (inv y |+| z)) (.*) = scale (|+|) = add (|-|) = sub ------------------------------------------------------------------ signlp r vals = foldl f 1 (zip [0..r-1] vals) where f s (a,b) | a /= b = -s | otherwise = s fixPerm r vals = (fromColumns $ A.elems res, sign) where v = [0..r-1] t = toColumns (ident r) (res,sign) = foldl swap (A.listArray (0,r-1) t, 1) (zip v vals) swap (arr,s) (a,b) | a /= b = (arr A.// [(a, arr A.! b),(b,arr A.! a)],-s) | otherwise = (arr,s) fixPerm' :: [Int] -> Vector I fixPerm' s = res $ mutable f s0 where s0 = reshape 1 (range (length s)) res = flatten . fst swap m i j = rowOper (SWAP i j AllCols) m f :: (Num t, Element t) => (Int, Int) -> STMatrix s t -> ST s () -- needed because of TypeFamilies f _ p = sequence_ $ zipWith (swap p) [0..] s triang r c h v = (r>=h then v else 1 - v -- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'. luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t) luFact (LU l_u perm) | r <= c = (l ,u ,p, s) | otherwise = (l',u',p, s) where r = rows l_u c = cols l_u tu = triang r c 0 1 tl = triang r c 0 0 l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst' 1 r) r r u = l_u |*| tu (p,s) = fixPerm r perm l' = (l_u |*| tl) |+| diagRect 0 (konst' 1 c) r c u' = takeRows c (l_u |*| tu) (|+|) = add (|*|) = mul --------------------------------------------------------------------------- data NormType = Infinity | PNorm1 | PNorm2 | Frobenius class (RealFloat (RealOf t)) => Normed c t where pnorm :: NormType -> c t -> RealOf t instance Normed Vector Double where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = norm2 instance Normed Vector (Complex Double) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector Float where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector (Complex Float) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Matrix Double where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Double) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix Float where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Float) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten -- | Approximate number of common digits in the maximum element. relativeError' :: (Normed c t, Container c t) => c t -> c t -> Int relativeError' x y = dig (norm (x `sub` y) / norm x) where norm = pnorm Infinity dig r = round $ -logBase 10 (realToFrac r :: Double) relativeError :: Num a => (a -> Double) -> a -> a -> Double relativeError norm a b = r where na = norm a nb = norm b nab = norm (a-b) mx = max na nb mn = min na nb r = if mn < peps then mx else nab/mx ---------------------------------------------------------------------- -- | Generalized symmetric positive definite eigensystem Av = lBv, -- for A and B symmetric, B positive definite. geigSH :: Field t => Herm t -- ^ A -> Herm t -- ^ B -> (Vector Double, Matrix t) geigSH (Herm a) (Herm b) = geigSH' a b geigSH' :: Field t => Matrix t -- ^ A -> Matrix t -- ^ B -> (Vector Double, Matrix t) geigSH' a b = (l,v') where u = cholSH b iu = inv u c = ctrans iu <> a <> iu (l,v) = eigSH' c v' = iu <> v (<>) = mXm -------------------------------------------------------------------------------- -- | A matrix that, by construction, it is known to be complex Hermitian or real symmetric. -- -- It can be created using 'sym', 'mTm', or 'trustSym', and the matrix can be extracted using 'unSym'. newtype Herm t = Herm (Matrix t) deriving Show instance (NFData t, Numeric t) => NFData (Herm t) where rnf (Herm m) = rnf m -- | Extract the general matrix from a 'Herm' structure, forgetting its symmetric or Hermitian property. unSym :: Herm t -> Matrix t unSym (Herm x) = x -- | Compute the complex Hermitian or real symmetric part of a square matrix (@(x + tr x)/2@). sym :: Field t => Matrix t -> Herm t sym x = Herm (scale 0.5 (tr x `add` x)) -- | Compute the contraction @tr x <> x@ of a general matrix. mTm :: Numeric t => Matrix t -> Herm t mTm x = Herm (tr x `mXm` x) instance Field t => Linear t Herm where scale x (Herm m) = Herm (scale x m) instance Field t => Additive (Herm t) where add (Herm a) (Herm b) = Herm (a `add` b) -- | At your own risk, declare that a matrix is complex Hermitian or real symmetric -- for usage in 'chol', 'eigSH', etc. Only a triangular part of the matrix will be used. trustSym :: Matrix t -> Herm t trustSym x = (Herm x) hmatrix-0.17.0.2/src/Internal/Container.hs0000644000000000000000000001641212722301655016431 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.Container -- Copyright : (c) Alberto Ruiz 2010-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Basic numeric operations on 'Vector' and 'Matrix', including conversion routines. -- -- The 'Container' class is used to define optimized generic functions which work -- on 'Vector' and 'Matrix' with real or complex elements. -- -- Some of these functions are also available in the instances of the standard -- numeric Haskell classes provided by "Numeric.LinearAlgebra". -- ----------------------------------------------------------------------------- module Internal.Container where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Numeric import Internal.Algorithms(Field,linearSolveSVD) ------------------------------------------------------------------ {- | Creates a real vector containing a range of values: >>> linspace 5 (-3,7::Double) fromList [-3.0,-0.5,2.0,4.5,7.0]@ >>> linspace 5 (8,2+i) :: Vector (Complex Double) fromList [8.0 :+ 0.0,6.5 :+ 0.25,5.0 :+ 0.5,3.5 :+ 0.75,2.0 :+ 1.0] Logarithmic spacing can be defined as follows: @logspace n (a,b) = 10 ** linspace n (a,b)@ -} linspace :: (Fractional e, Container Vector e) => Int -> (e, e) -> Vector e linspace 0 _ = fromList[] linspace 1 (a,b) = fromList[(a+b)/2] linspace n (a,b) = addConstant a $ scale s $ fromList $ map fromIntegral [0 .. n-1] where s = (b-a)/fromIntegral (n-1) -------------------------------------------------------------------------------- infixr 8 <.> {- | An infix synonym for 'dot' >>> vector [1,2,3,4] <.> vector [-2,0,1,1] 5.0 >>> let 𝑖 = 0:+1 :: C >>> fromList [1+𝑖,1] <.> fromList [1,1+𝑖] 2.0 :+ 0.0 -} (<.>) :: Numeric t => Vector t -> Vector t -> t (<.>) = dot {- | dense matrix-vector product >>> let m = (2><3) [1..] >>> m (2><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 ] >>> let v = vector [10,20,30] >>> m #> v fromList [140.0,320.0] -} infixr 8 #> (#>) :: Numeric t => Matrix t -> Vector t -> Vector t (#>) = mXv -- | dense matrix-vector product app :: Numeric t => Matrix t -> Vector t -> Vector t app = (#>) infixl 8 <# -- | dense vector-matrix product (<#) :: Numeric t => Vector t -> Matrix t -> Vector t (<#) = vXm -------------------------------------------------------------------------------- class Mul a b c | a b -> c where infixl 7 <> -- | Matrix-matrix, matrix-vector, and vector-matrix products. (<>) :: Product t => a t -> b t -> c t instance Mul Matrix Matrix Matrix where (<>) = mXm instance Mul Matrix Vector Vector where (<>) m v = flatten $ m <> asColumn v instance Mul Vector Matrix Vector where (<>) v m = flatten $ asRow v <> m -------------------------------------------------------------------------------- {- | Least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD) @ a = (3><2) [ 1.0, 2.0 , 2.0, 4.0 , 2.0, -1.0 ] @ @ v = vector [13.0,27.0,1.0] @ >>> let x = a <\> v >>> x fromList [3.0799999999999996,5.159999999999999] >>> a #> x fromList [13.399999999999999,26.799999999999997,1.0] It also admits multiple right-hand sides stored as columns in a matrix. -} infixl 7 <\> (<\>) :: (LSDiv c, Field t) => Matrix t -> c t -> c t (<\>) = linSolve class LSDiv c where linSolve :: Field t => Matrix t -> c t -> c t instance LSDiv Vector where linSolve m v = flatten (linearSolveSVD m (reshape 1 v)) instance LSDiv Matrix where linSolve = linearSolveSVD -------------------------------------------------------------------------------- class Build d f c e | d -> c, c -> d, f -> e, f -> d, f -> c, c e -> f, d e -> f where -- | -- >>> build 5 (**2) :: Vector Double -- fromList [0.0,1.0,4.0,9.0,16.0] -- -- Hilbert matrix of order N: -- -- >>> let hilb n = build (n,n) (\i j -> 1/(i+j+1)) :: Matrix Double -- >>> putStr . dispf 2 $ hilb 3 -- 3x3 -- 1.00 0.50 0.33 -- 0.50 0.33 0.25 -- 0.33 0.25 0.20 -- build :: d -> f -> c e instance Container Vector e => Build Int (e -> e) Vector e where build = build' instance Container Matrix e => Build (Int,Int) (e -> e -> e) Matrix e where build = build' -------------------------------------------------------------------------------- -- @dot u v = 'udot' ('conj' u) v@ dot :: (Numeric t) => Vector t -> Vector t -> t dot u v = udot (conj u) v -------------------------------------------------------------------------------- optimiseMult :: Monoid (Matrix t) => [Matrix t] -> Matrix t optimiseMult = mconcat -------------------------------------------------------------------------------- {- | Compute mean vector and covariance matrix of the rows of a matrix. >>> meanCov $ gaussianSample 666 1000 (fromList[4,5]) (diagl[2,3]) (fromList [4.010341078059521,5.0197204699640405], (2><2) [ 1.9862461923890056, -1.0127225830525157e-2 , -1.0127225830525157e-2, 3.0373954915729318 ]) -} meanCov :: Matrix Double -> (Vector Double, Matrix Double) meanCov x = (med,cov) where r = rows x k = 1 / fromIntegral r med = konst k r `vXm` x meds = konst 1 r `outer` med xc = x `sub` meds cov = scale (recip (fromIntegral (r-1))) (trans xc `mXm` xc) -------------------------------------------------------------------------------- sortVector :: (Ord t, Element t) => Vector t -> Vector t sortVector = sortV {- | >>> m <- randn 4 10 >>> disp 2 m 4x10 -0.31 0.41 0.43 -0.19 -0.17 -0.23 -0.17 -1.04 -0.07 -1.24 0.26 0.19 0.14 0.83 -1.54 -0.09 0.37 -0.63 0.71 -0.50 -0.11 -0.10 -1.29 -1.40 -1.04 -0.89 -0.68 0.35 -1.46 1.86 1.04 -0.29 0.19 -0.75 -2.20 -0.01 1.06 0.11 -2.09 -1.58 >>> disp 2 $ m ?? (All, Pos $ sortIndex (m!1)) 4x10 -0.17 -1.04 -1.24 -0.23 0.43 0.41 -0.31 -0.17 -0.07 -0.19 -1.54 -0.63 -0.50 -0.09 0.14 0.19 0.26 0.37 0.71 0.83 -1.04 0.35 1.86 -0.89 -1.29 -0.10 -0.11 -0.68 -1.46 -1.40 -2.20 0.11 -1.58 -0.01 0.19 -0.29 1.04 1.06 -2.09 -0.75 -} sortIndex :: (Ord t, Element t) => Vector t -> Vector I sortIndex = sortI ccompare :: (Ord t, Container c t) => c t -> c t -> c I ccompare = ccompare' cselect :: (Container c t) => c I -> c t -> c t -> c t -> c t cselect = cselect' {- | Extract elements from positions given in matrices of rows and columns. >>> r (3><3) [ 1, 1, 1 , 1, 2, 2 , 1, 2, 3 ] >>> c (3><3) [ 0, 1, 5 , 2, 2, 1 , 4, 4, 1 ] >>> m (4><6) [ 0, 1, 2, 3, 4, 5 , 6, 7, 8, 9, 10, 11 , 12, 13, 14, 15, 16, 17 , 18, 19, 20, 21, 22, 23 ] >>> remap r c m (3><3) [ 6, 7, 11 , 8, 14, 13 , 10, 16, 19 ] The indexes are autoconformable. >>> c' (3><1) [ 1 , 2 , 4 ] >>> remap r c' m (3><3) [ 7, 7, 7 , 8, 14, 14 , 10, 16, 22 ] -} remap :: Element t => Matrix I -> Matrix I -> Matrix t -> Matrix t remap i j m | minElement i >= 0 && maxElement i < fromIntegral (rows m) && minElement j >= 0 && maxElement j < fromIntegral (cols m) = remapM i' j' m | otherwise = error $ "out of range index in remap" where [i',j'] = conformMs [i,j] hmatrix-0.17.0.2/src/Internal/IO.hs0000644000000000000000000001217012722301655015013 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Internal.IO -- Copyright : (c) Alberto Ruiz 2010 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Display, formatting and IO functions for numeric 'Vector' and 'Matrix' -- ----------------------------------------------------------------------------- module Internal.IO ( dispf, disps, dispcf, vecdisp, latexFormat, format, loadMatrix, loadMatrix', saveMatrix ) where import Internal.Devel import Internal.Vector import Internal.Matrix import Internal.Vectorized import Text.Printf(printf) import Data.List(intersperse,transpose) import Data.Complex -- | Formatting tool table :: String -> [[String]] -> String table sep as = unlines . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse sep {- | Creates a string from a matrix given a separator and a function to show each entry. Using this function the user can easily define any desired display function: @import Text.Printf(printf)@ @disp = putStr . format \" \" (printf \"%.2f\")@ -} format :: (Element t) => String -> (t -> String) -> Matrix t -> String format sep f m = table sep . map (map f) . toLists $ m {- | Show a matrix with \"autoscaling\" and a given number of decimal places. >>> putStr . disps 2 $ 120 * (3><4) [1..] 3x4 E3 0.12 0.24 0.36 0.48 0.60 0.72 0.84 0.96 1.08 1.20 1.32 1.44 -} disps :: Int -> Matrix Double -> String disps d x = sdims x ++ " " ++ formatScaled d x {- | Show a matrix with a given number of decimal places. >>> dispf 2 (1/3 + ident 3) "3x3\n1.33 0.33 0.33\n0.33 1.33 0.33\n0.33 0.33 1.33\n" >>> putStr . dispf 2 $ (3><4)[1,1.5..] 3x4 1.00 1.50 2.00 2.50 3.00 3.50 4.00 4.50 5.00 5.50 6.00 6.50 >>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1) 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00 -} dispf :: Int -> Matrix Double -> String dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x sdims x = show (rows x) ++ "x" ++ show (cols x) formatFixed d x = format " " (printf ("%."++show d++"f")) $ x isInt = all lookslikeInt . toList . flatten formatScaled dec t = "E"++show o++"\n" ++ ss where ss = format " " (printf fmt. g) t g x | o >= 0 = x/10^(o::Int) | otherwise = x*10^(-o) o | rows t == 0 || cols t == 0 = 0 | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t fmt = '%':show (dec+3) ++ '.':show dec ++"f" {- | Show a vector using a function for showing matrices. >>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1) 10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00 -} vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String vecdisp f v = ((show (dim v) ++ " |> ") ++) . (++"\n") . unwords . lines . tail . dropWhile (not . (`elem` " \n")) . f . trans . reshape 1 $ v {- | Tool to display matrices with latex syntax. >>> latexFormat "bmatrix" (dispf 2 $ ident 2) "\\begin{bmatrix}\n1 & 0\n\\\\\n0 & 1\n\\end{bmatrix}" -} latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc. -> String -- ^ Formatted matrix, with elements separated by spaces and newlines -> String latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}" where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines -- | Pretty print a complex number with at most n decimal digits. showComplex :: Int -> Complex Double -> String showComplex d (a:+b) | isZero a && isZero b = "0" | isZero b = sa | isZero a && isOne b = s2++"i" | isZero a = sb++"i" | isOne b = sa++s3++"i" | otherwise = sa++s1++sb++"i" where sa = shcr d a sb = shcr d b s1 = if b<0 then "" else "+" s2 = if b<0 then "-" else "" s3 = if b<0 then "-" else "+" shcr d a | lookslikeInt a = printf "%.0f" a | otherwise = printf ("%."++show d++"f") a lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx where shx = show x isZero x = show x `elem` ["0.0","-0.0"] isOne x = show x `elem` ["1.0","-1.0"] -- | Pretty print a complex matrix with at most n decimal digits. dispcf :: Int -> Matrix (Complex Double) -> String dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m -------------------------------------------------------------------- apparentCols :: FilePath -> IO Int apparentCols s = f . dropWhile null . map words . lines <$> readFile s where f [] = 0 f (x:_) = length x -- | load a matrix from an ASCII file formatted as a 2D table. loadMatrix :: FilePath -> IO (Matrix Double) loadMatrix f = do v <- vectorScan f c <- apparentCols f if (dim v `mod` c /= 0) then error $ printf "loadMatrix: %d elements and %d columns in file %s" (dim v) c f else return (reshape c v) loadMatrix' name = mbCatch (loadMatrix name) hmatrix-0.17.0.2/src/Internal/Convolution.hs0000644000000000000000000001015612722301655017025 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- {- | Module : Internal.Convolution Copyright : (c) Alberto Ruiz 2012 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- {-# OPTIONS_HADDOCK hide #-} module Internal.Convolution( corr, conv, corrMin, corr2, conv2, separable ) where import qualified Data.Vector.Storable as SV import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Element import Internal.Conversion import Internal.Container vectSS :: Element t => Int -> Vector t -> Matrix t vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ] corr :: (Container Vector t, Product t) => Vector t -- ^ kernel -> Vector t -- ^ source -> Vector t {- ^ correlation >>> corr (fromList[1,2,3]) (fromList [1..10]) fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0] -} corr ker v | dim ker == 0 = konst 0 (dim v) | dim ker <= dim v = vectSS (dim ker) v <> ker | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")" conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t {- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product) >>> conv (fromList[1,1]) (fromList [-1,1]) fromList [-1.0,0.0,1.0] -} conv ker v | dim ker == 0 = konst 0 (dim v) | otherwise = corr ker' v' where ker' = SV.reverse ker v' = vjoin [z,v,z] z = konst 0 (dim ker -1) corrMin :: (Container Vector t, RealElement t, Product t) => Vector t -> Vector t -> Vector t -- ^ similar to 'corr', using 'min' instead of (*) corrMin ker v | dim ker == 0 = error "corrMin: empty kernel" | otherwise = minEvery ss (asRow ker) <> ones where minEvery a b = cond a b a a b ss = vectSS (dim ker) v ones = konst 1 (dim ker) matSS :: Element t => Int -> Matrix t -> [Matrix t] matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ] where v = flatten m c = cols m r = rows m n = dr*c {- | 2D correlation (without padding) >>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double) 8x8 3 2 1 0 0 0 0 0 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 0 0 0 0 0 1 2 3 -} corr2 :: Product a => Matrix a -> Matrix a -> Matrix a corr2 ker mat = dims . concatMap (map (udot ker' . flatten) . matSS c . trans) . matSS r $ mat where r = rows ker c = cols ker ker' = flatten (trans ker) rr = rows mat - r + 1 rc = cols mat - c + 1 dims | rr > 0 && rc > 0 = (rr >< rc) | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")" sz m = show (rows m)++"x"++show (cols m) -- TODO check empty kernel {- | 2D convolution >>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double) 12x12 1 1 1 0 0 0 0 0 0 0 0 0 1 2 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 2 1 0 0 0 0 0 0 0 0 0 1 1 1 -} conv2 :: (Num (Matrix a), Product a, Container Vector a) => Matrix a -- ^ kernel -> Matrix a -> Matrix a conv2 k m | empty = konst 0 (rows m + r -1, cols m + c -1) | otherwise = corr2 (fliprl . flipud $ k) padded where padded = fromBlocks [[z,0,0] ,[0,m,0] ,[0,0,z]] r = rows k c = cols k z = konst 0 (r-1,c-1) empty = r == 0 || c == 0 separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t -- ^ matrix computation implemented as separated vector operations by rows and columns. separable f = fromColumns . map f . toColumns . fromRows . map f . toRows hmatrix-0.17.0.2/src/Internal/Matrix.hs0000644000000000000000000004752612722301655015765 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstrainedClassMethods #-} -- | -- Module : Internal.Matrix -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Internal matrix representation -- module Internal.Matrix where import Internal.Vector import Internal.Devel import Internal.Vectorized hiding ((#)) import Foreign.Marshal.Alloc ( free ) import Foreign.Marshal.Array(newArray) import Foreign.Ptr ( Ptr ) import Foreign.Storable ( Storable ) import Data.Complex ( Complex ) import Foreign.C.Types ( CInt(..) ) import Foreign.C.String ( CString, newCString ) import System.IO.Unsafe ( unsafePerformIO ) import Control.DeepSeq ( NFData(..) ) import Text.Printf ----------------------------------------------------------------- data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq) -- | Matrix representation suitable for BLAS\/LAPACK computations. data Matrix t = Matrix { irows :: {-# UNPACK #-} !Int , icols :: {-# UNPACK #-} !Int , xRow :: {-# UNPACK #-} !Int , xCol :: {-# UNPACK #-} !Int , xdat :: {-# UNPACK #-} !(Vector t) } rows :: Matrix t -> Int rows = irows {-# INLINE rows #-} cols :: Matrix t -> Int cols = icols {-# INLINE cols #-} size m = (irows m, icols m) {-# INLINE size #-} rowOrder m = xCol m == 1 || cols m == 1 {-# INLINE rowOrder #-} colOrder m = xRow m == 1 || rows m == 1 {-# INLINE colOrder #-} is1d (size->(r,c)) = r==1 || c==1 {-# INLINE is1d #-} -- data is not contiguous isSlice m@(size->(r,c)) = r*c < dim (xdat m) {-# INLINE isSlice #-} orderOf :: Matrix t -> MatrixOrder orderOf m = if rowOrder m then RowMajor else ColumnMajor showInternal :: Storable t => Matrix t -> IO () showInternal m = printf "%dx%d %s %s %d:%d (%d)\n" r c slc ord xr xc dv where r = rows m c = cols m xr = xRow m xc = xCol m slc = if isSlice m then "slice" else "full" ord = if is1d m then "1d" else if rowOrder m then "rows" else "cols" dv = dim (xdat m) -------------------------------------------------------------------------------- -- | Matrix transpose. trans :: Matrix t -> Matrix t trans m@Matrix { irows = r, icols = c, xRow = xr, xCol = xc } = m { irows = c, icols = r, xRow = xc, xCol = xr } cmat :: (Element t) => Matrix t -> Matrix t cmat m | rowOrder m = m | otherwise = extractAll RowMajor m fmat :: (Element t) => Matrix t -> Matrix t fmat m | colOrder m = m | otherwise = extractAll ColumnMajor m -- C-Haskell matrix adapters {-# INLINE amatr #-} amatr :: Storable a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b amatr f x = inlinePerformIO (unsafeWith (xdat x) (return . f r c)) where r = fi (rows x) c = fi (cols x) {-# INLINE amat #-} amat :: Storable a => (CInt -> CInt -> CInt -> CInt -> Ptr a -> b) -> Matrix a -> b amat f x = inlinePerformIO (unsafeWith (xdat x) (return . f r c sr sc)) where r = fi (rows x) c = fi (cols x) sr = fi (xRow x) sc = fi (xCol x) instance Storable t => TransArray (Matrix t) where type TransRaw (Matrix t) b = CInt -> CInt -> Ptr t -> b type Trans (Matrix t) b = CInt -> CInt -> CInt -> CInt -> Ptr t -> b apply = amat {-# INLINE apply #-} applyRaw = amatr {-# INLINE applyRaw #-} infixl 1 # a # b = apply a b {-# INLINE (#) #-} -------------------------------------------------------------------------------- copy ord m = extractR ord m 0 (idxs[0,rows m-1]) 0 (idxs[0,cols m-1]) extractAll ord m = unsafePerformIO (copy ord m) {- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose. >>> flatten (ident 3) fromList [1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0] -} flatten :: Element t => Matrix t -> Vector t flatten m | isSlice m || not (rowOrder m) = xdat (extractAll RowMajor m) | otherwise = xdat m -- | the inverse of 'Data.Packed.Matrix.fromLists' toLists :: (Element t) => Matrix t -> [[t]] toLists = map toList . toRows -- | common value with \"adaptable\" 1 compatdim :: [Int] -> Maybe Int compatdim [] = Nothing compatdim [a] = Just a compatdim (a:b:xs) | a==b = compatdim (b:xs) | a==1 = compatdim (b:xs) | b==1 = compatdim (a:xs) | otherwise = Nothing -- | Create a matrix from a list of vectors. -- All vectors must have the same dimension, -- or dimension 1, which is are automatically expanded. fromRows :: Element t => [Vector t] -> Matrix t fromRows [] = emptyM 0 0 fromRows vs = case compatdim (map dim vs) of Nothing -> error $ "fromRows expects vectors with equal sizes (or singletons), given: " ++ show (map dim vs) Just 0 -> emptyM r 0 Just c -> matrixFromVector RowMajor r c . vjoin . map (adapt c) $ vs where r = length vs adapt c v | c == 0 = fromList[] | dim v == c = v | otherwise = constantD (v@>0) c -- | extracts the rows of a matrix as a list of vectors toRows :: Element t => Matrix t -> [Vector t] toRows m | rowOrder m = map sub rowRange | otherwise = map ext rowRange where rowRange = [0..rows m-1] sub k = subVector (k*xRow m) (cols m) (xdat m) ext k = xdat $ unsafePerformIO $ extractR RowMajor m 1 (idxs[k]) 0 (idxs[0,cols m-1]) -- | Creates a matrix from a list of vectors, as columns fromColumns :: Element t => [Vector t] -> Matrix t fromColumns m = trans . fromRows $ m -- | Creates a list of vectors from the columns of a matrix toColumns :: Element t => Matrix t -> [Vector t] toColumns m = toRows . trans $ m -- | Reads a matrix position. (@@>) :: Storable t => Matrix t -> (Int,Int) -> t infixl 9 @@> m@Matrix {irows = r, icols = c} @@> (i,j) | i<0 || i>=r || j<0 || j>=c = error "matrix indexing out of range" | otherwise = atM' m i j {-# INLINE (@@>) #-} -- Unsafe matrix access without range checking atM' m i j = xdat m `at'` (i * (xRow m) + j * (xCol m)) {-# INLINE atM' #-} ------------------------------------------------------------------ matrixFromVector _ 1 _ v@(dim->d) = Matrix { irows = 1, icols = d, xdat = v, xRow = d, xCol = 1 } matrixFromVector _ _ 1 v@(dim->d) = Matrix { irows = d, icols = 1, xdat = v, xRow = 1, xCol = d } matrixFromVector o r c v | r * c == dim v = m | otherwise = error $ "can't reshape vector dim = "++ show (dim v)++" to matrix " ++ shSize m where m | o == RowMajor = Matrix { irows = r, icols = c, xdat = v, xRow = c, xCol = 1 } | otherwise = Matrix { irows = r, icols = c, xdat = v, xRow = 1, xCol = r } -- allocates memory for a new matrix createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a) createMatrix ord r c = do p <- createVector (r*c) return (matrixFromVector ord r c p) {- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = tr' . reshape r@ where r is the desired number of rows.) >>> reshape 4 (fromList [1..12]) (3><4) [ 1.0, 2.0, 3.0, 4.0 , 5.0, 6.0, 7.0, 8.0 , 9.0, 10.0, 11.0, 12.0 ] -} reshape :: Storable t => Int -> Vector t -> Matrix t reshape 0 v = matrixFromVector RowMajor 0 0 v reshape c v = matrixFromVector RowMajor (dim v `div` c) c v -- | application of a vector function on the flattened matrix elements liftMatrix :: (Element a, Element b) => (Vector a -> Vector b) -> Matrix a -> Matrix b liftMatrix f m@Matrix { irows = r, icols = c, xdat = d} | isSlice m = matrixFromVector RowMajor r c (f (flatten m)) | otherwise = matrixFromVector (orderOf m) r c (f d) -- | application of a vector function on the flattened matrices elements liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t liftMatrix2 f m1@(size->(r,c)) m2 | (r,c)/=size m2 = error "nonconformant matrices in liftMatrix2" | rowOrder m1 = matrixFromVector RowMajor r c (f (flatten m1) (flatten m2)) | otherwise = matrixFromVector ColumnMajor r c (f (flatten (trans m1)) (flatten (trans m2))) ------------------------------------------------------------------ -- | Supported matrix elements. class (Storable a) => Element a where constantD :: a -> Int -> Vector a extractR :: MatrixOrder -> Matrix a -> CInt -> Vector CInt -> CInt -> Vector CInt -> IO (Matrix a) setRect :: Int -> Int -> Matrix a -> Matrix a -> IO () sortI :: Ord a => Vector a -> Vector CInt sortV :: Ord a => Vector a -> Vector a compareV :: Ord a => Vector a -> Vector a -> Vector CInt selectV :: Vector CInt -> Vector a -> Vector a -> Vector a -> Vector a remapM :: Matrix CInt -> Matrix CInt -> Matrix a -> Matrix a rowOp :: Int -> a -> Int -> Int -> Int -> Int -> Matrix a -> IO () gemm :: Vector a -> Matrix a -> Matrix a -> Matrix a -> IO () instance Element Float where constantD = constantAux cconstantF extractR = extractAux c_extractF setRect = setRectAux c_setRectF sortI = sortIdxF sortV = sortValF compareV = compareF selectV = selectF remapM = remapF rowOp = rowOpAux c_rowOpF gemm = gemmg c_gemmF instance Element Double where constantD = constantAux cconstantR extractR = extractAux c_extractD setRect = setRectAux c_setRectD sortI = sortIdxD sortV = sortValD compareV = compareD selectV = selectD remapM = remapD rowOp = rowOpAux c_rowOpD gemm = gemmg c_gemmD instance Element (Complex Float) where constantD = constantAux cconstantQ extractR = extractAux c_extractQ setRect = setRectAux c_setRectQ sortI = undefined sortV = undefined compareV = undefined selectV = selectQ remapM = remapQ rowOp = rowOpAux c_rowOpQ gemm = gemmg c_gemmQ instance Element (Complex Double) where constantD = constantAux cconstantC extractR = extractAux c_extractC setRect = setRectAux c_setRectC sortI = undefined sortV = undefined compareV = undefined selectV = selectC remapM = remapC rowOp = rowOpAux c_rowOpC gemm = gemmg c_gemmC instance Element (CInt) where constantD = constantAux cconstantI extractR = extractAux c_extractI setRect = setRectAux c_setRectI sortI = sortIdxI sortV = sortValI compareV = compareI selectV = selectI remapM = remapI rowOp = rowOpAux c_rowOpI gemm = gemmg c_gemmI instance Element Z where constantD = constantAux cconstantL extractR = extractAux c_extractL setRect = setRectAux c_setRectL sortI = sortIdxL sortV = sortValL compareV = compareL selectV = selectL remapM = remapL rowOp = rowOpAux c_rowOpL gemm = gemmg c_gemmL ------------------------------------------------------------------- -- | reference to a rectangular slice of a matrix (no data copy) subMatrix :: Element a => (Int,Int) -- ^ (r0,c0) starting position -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix -> Matrix a -- ^ input matrix -> Matrix a -- ^ result subMatrix (r0,c0) (rt,ct) m | rt <= 0 || ct <= 0 = matrixFromVector RowMajor (max 0 rt) (max 0 ct) (fromList []) | 0 <= r0 && 0 <= rt && r0+rt <= rows m && 0 <= c0 && 0 <= ct && c0+ct <= cols m = res | otherwise = error $ "wrong subMatrix "++show ((r0,c0),(rt,ct))++" of "++shSize m where p = r0 * xRow m + c0 * xCol m tot | rowOrder m = ct + (rt-1) * xRow m | otherwise = rt + (ct-1) * xCol m res = m { irows = rt, icols = ct, xdat = subVector p tot (xdat m) } -------------------------------------------------------------------------- maxZ xs = if minimum xs == 0 then 0 else maximum xs conformMs ms = map (conformMTo (r,c)) ms where r = maxZ (map rows ms) c = maxZ (map cols ms) conformVs vs = map (conformVTo n) vs where n = maxZ (map dim vs) conformMTo (r,c) m | size m == (r,c) = m | size m == (1,1) = matrixFromVector RowMajor r c (constantD (m@@>(0,0)) (r*c)) | size m == (r,1) = repCols c m | size m == (1,c) = repRows r m | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to " ++ shDim (r,c) conformVTo n v | dim v == n = v | dim v == 1 = constantD (v@>0) n | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n repRows n x = fromRows (replicate n (flatten x)) repCols n x = fromColumns (replicate n (flatten x)) shSize = shDim . size shDim (r,c) = "(" ++ show r ++"x"++ show c ++")" emptyM r c = matrixFromVector RowMajor r c (fromList[]) ---------------------------------------------------------------------- instance (Storable t, NFData t) => NFData (Matrix t) where rnf m | d > 0 = rnf (v @> 0) | otherwise = () where d = dim v v = xdat m --------------------------------------------------------------- extractAux f ord m moder vr modec vc = do let nr = if moder == 0 then fromIntegral $ vr@>1 - vr@>0 + 1 else dim vr nc = if modec == 0 then fromIntegral $ vc@>1 - vc@>0 + 1 else dim vc r <- createMatrix ord nr nc f moder modec # vr # vc # m # r #|"extract" return r type Extr x = CInt -> CInt -> CIdxs (CIdxs (OM x (OM x (IO CInt)))) foreign import ccall unsafe "extractD" c_extractD :: Extr Double foreign import ccall unsafe "extractF" c_extractF :: Extr Float foreign import ccall unsafe "extractC" c_extractC :: Extr (Complex Double) foreign import ccall unsafe "extractQ" c_extractQ :: Extr (Complex Float) foreign import ccall unsafe "extractI" c_extractI :: Extr CInt foreign import ccall unsafe "extractL" c_extractL :: Extr Z --------------------------------------------------------------- setRectAux f i j m r = f (fi i) (fi j) # m # r #|"setRect" type SetRect x = I -> I -> x ::> x::> Ok foreign import ccall unsafe "setRectD" c_setRectD :: SetRect Double foreign import ccall unsafe "setRectF" c_setRectF :: SetRect Float foreign import ccall unsafe "setRectC" c_setRectC :: SetRect (Complex Double) foreign import ccall unsafe "setRectQ" c_setRectQ :: SetRect (Complex Float) foreign import ccall unsafe "setRectI" c_setRectI :: SetRect I foreign import ccall unsafe "setRectL" c_setRectL :: SetRect Z -------------------------------------------------------------------------------- sortG f v = unsafePerformIO $ do r <- createVector (dim v) f # v # r #|"sortG" return r sortIdxD = sortG c_sort_indexD sortIdxF = sortG c_sort_indexF sortIdxI = sortG c_sort_indexI sortIdxL = sortG c_sort_indexL sortValD = sortG c_sort_valD sortValF = sortG c_sort_valF sortValI = sortG c_sort_valI sortValL = sortG c_sort_valL foreign import ccall unsafe "sort_indexD" c_sort_indexD :: CV Double (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexF" c_sort_indexF :: CV Float (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexI" c_sort_indexI :: CV CInt (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexL" c_sort_indexL :: Z :> I :> Ok foreign import ccall unsafe "sort_valuesD" c_sort_valD :: CV Double (CV Double (IO CInt)) foreign import ccall unsafe "sort_valuesF" c_sort_valF :: CV Float (CV Float (IO CInt)) foreign import ccall unsafe "sort_valuesI" c_sort_valI :: CV CInt (CV CInt (IO CInt)) foreign import ccall unsafe "sort_valuesL" c_sort_valL :: Z :> Z :> Ok -------------------------------------------------------------------------------- compareG f u v = unsafePerformIO $ do r <- createVector (dim v) f # u # v # r #|"compareG" return r compareD = compareG c_compareD compareF = compareG c_compareF compareI = compareG c_compareI compareL = compareG c_compareL foreign import ccall unsafe "compareD" c_compareD :: CV Double (CV Double (CV CInt (IO CInt))) foreign import ccall unsafe "compareF" c_compareF :: CV Float (CV Float (CV CInt (IO CInt))) foreign import ccall unsafe "compareI" c_compareI :: CV CInt (CV CInt (CV CInt (IO CInt))) foreign import ccall unsafe "compareL" c_compareL :: Z :> Z :> I :> Ok -------------------------------------------------------------------------------- selectG f c u v w = unsafePerformIO $ do r <- createVector (dim v) f # c # u # v # w # r #|"selectG" return r selectD = selectG c_selectD selectF = selectG c_selectF selectI = selectG c_selectI selectL = selectG c_selectL selectC = selectG c_selectC selectQ = selectG c_selectQ type Sel x = CV CInt (CV x (CV x (CV x (CV x (IO CInt))))) foreign import ccall unsafe "chooseD" c_selectD :: Sel Double foreign import ccall unsafe "chooseF" c_selectF :: Sel Float foreign import ccall unsafe "chooseI" c_selectI :: Sel CInt foreign import ccall unsafe "chooseC" c_selectC :: Sel (Complex Double) foreign import ccall unsafe "chooseQ" c_selectQ :: Sel (Complex Float) foreign import ccall unsafe "chooseL" c_selectL :: Sel Z --------------------------------------------------------------------------- remapG f i j m = unsafePerformIO $ do r <- createMatrix RowMajor (rows i) (cols i) f # i # j # m # r #|"remapG" return r remapD = remapG c_remapD remapF = remapG c_remapF remapI = remapG c_remapI remapL = remapG c_remapL remapC = remapG c_remapC remapQ = remapG c_remapQ type Rem x = OM CInt (OM CInt (OM x (OM x (IO CInt)))) foreign import ccall unsafe "remapD" c_remapD :: Rem Double foreign import ccall unsafe "remapF" c_remapF :: Rem Float foreign import ccall unsafe "remapI" c_remapI :: Rem CInt foreign import ccall unsafe "remapC" c_remapC :: Rem (Complex Double) foreign import ccall unsafe "remapQ" c_remapQ :: Rem (Complex Float) foreign import ccall unsafe "remapL" c_remapL :: Rem Z -------------------------------------------------------------------------------- rowOpAux f c x i1 i2 j1 j2 m = do px <- newArray [x] f (fi c) px (fi i1) (fi i2) (fi j1) (fi j2) # m #|"rowOp" free px type RowOp x = CInt -> Ptr x -> CInt -> CInt -> CInt -> CInt -> x ::> Ok foreign import ccall unsafe "rowop_double" c_rowOpD :: RowOp R foreign import ccall unsafe "rowop_float" c_rowOpF :: RowOp Float foreign import ccall unsafe "rowop_TCD" c_rowOpC :: RowOp C foreign import ccall unsafe "rowop_TCF" c_rowOpQ :: RowOp (Complex Float) foreign import ccall unsafe "rowop_int32_t" c_rowOpI :: RowOp I foreign import ccall unsafe "rowop_int64_t" c_rowOpL :: RowOp Z foreign import ccall unsafe "rowop_mod_int32_t" c_rowOpMI :: I -> RowOp I foreign import ccall unsafe "rowop_mod_int64_t" c_rowOpML :: Z -> RowOp Z -------------------------------------------------------------------------------- gemmg f v m1 m2 m3 = f # v # m1 # m2 # m3 #|"gemmg" type Tgemm x = x :> x ::> x ::> x ::> Ok foreign import ccall unsafe "gemm_double" c_gemmD :: Tgemm R foreign import ccall unsafe "gemm_float" c_gemmF :: Tgemm Float foreign import ccall unsafe "gemm_TCD" c_gemmC :: Tgemm C foreign import ccall unsafe "gemm_TCF" c_gemmQ :: Tgemm (Complex Float) foreign import ccall unsafe "gemm_int32_t" c_gemmI :: Tgemm I foreign import ccall unsafe "gemm_int64_t" c_gemmL :: Tgemm Z foreign import ccall unsafe "gemm_mod_int32_t" c_gemmMI :: I -> Tgemm I foreign import ccall unsafe "gemm_mod_int64_t" c_gemmML :: Z -> Tgemm Z -------------------------------------------------------------------------------- foreign import ccall unsafe "saveMatrix" c_saveMatrix :: CString -> CString -> Double ::> Ok {- | save a matrix as a 2D ASCII table -} saveMatrix :: FilePath -> String -- ^ \"printf\" format (e.g. \"%.2f\", \"%g\", etc.) -> Matrix Double -> IO () saveMatrix name format m = do cname <- newCString name cformat <- newCString format c_saveMatrix cname cformat # m #|"saveMatrix" free cname free cformat return () -------------------------------------------------------------------------------- hmatrix-0.17.0.2/src/Internal/Numeric.hs0000644000000000000000000006532412722301655016117 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Numeric -- Copyright : (c) Alberto Ruiz 2010-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- ----------------------------------------------------------------------------- module Internal.Numeric where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.ST as ST import Internal.Conversion import Internal.Vectorized import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL) import Data.List.Split(chunksOf) -------------------------------------------------------------------------------- type family IndexOf (c :: * -> *) type instance IndexOf Vector = Int type instance IndexOf Matrix = (Int,Int) type family ArgOf (c :: * -> *) a type instance ArgOf Vector a = a -> a type instance ArgOf Matrix a = a -> a -> a -------------------------------------------------------------------------------- -- | Basic element-by-element functions for numeric containers class Element e => Container c e where conj' :: c e -> c e size' :: c e -> IndexOf c scalar' :: e -> c e scale' :: e -> c e -> c e addConstant :: e -> c e -> c e add' :: c e -> c e -> c e sub :: c e -> c e -> c e -- | element by element multiplication mul :: c e -> c e -> c e equal :: c e -> c e -> Bool cmap' :: (Element b) => (e -> b) -> c e -> c b konst' :: e -> IndexOf c -> c e build' :: IndexOf c -> (ArgOf c e) -> c e atIndex' :: c e -> IndexOf c -> e minIndex' :: c e -> IndexOf c maxIndex' :: c e -> IndexOf c minElement' :: c e -> e maxElement' :: c e -> e sumElements' :: c e -> e prodElements' :: c e -> e step' :: Ord e => c e -> c e ccompare' :: Ord e => c e -> c e -> c I cselect' :: c I -> c e -> c e -> c e -> c e find' :: (e -> Bool) -> c e -> [IndexOf c] assoc' :: IndexOf c -- ^ size -> e -- ^ default value -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result accum' :: c e -- ^ initial structure -> (e -> e -> e) -- ^ update function -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result -- | scale the element by element reciprocal of the object: -- -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@ scaleRecip :: Fractional e => e -> c e -> c e -- | element by element division divide :: Fractional e => c e -> c e -> c e -- -- element by element inverse tangent arctan2' :: Fractional e => c e -> c e -> c e cmod' :: Integral e => e -> c e -> c e fromInt' :: c I -> c e toInt' :: c e -> c I fromZ' :: c Z -> c e toZ' :: c e -> c Z -------------------------------------------------------------------------- instance Container Vector I where conj' = id size' = dim scale' = vectorMapValI Scale addConstant = vectorMapValI AddConstant add' = vectorZipI Add sub = vectorZipI Sub mul = vectorZipI Mul equal u v = dim u == dim v && maxElement' (vectorMapI Abs (sub u v)) == 0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarI MinIdx) maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarI MaxIdx) minElement' = emptyErrorV "minElement" (toScalarI Min) maxElement' = emptyErrorV "maxElement" (toScalarI Max) sumElements' = sumI 1 prodElements' = prodI 1 step' = stepI find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = undefined -- cannot match divide = undefined arctan2' = undefined cmod' m x | m /= 0 = vectorMapValI ModVS m x | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x) fromInt' = id toInt' = id fromZ' = long2intV toZ' = int2longV instance Container Vector Z where conj' = id size' = dim scale' = vectorMapValL Scale addConstant = vectorMapValL AddConstant add' = vectorZipL Add sub = vectorZipL Sub mul = vectorZipL Mul equal u v = dim u == dim v && maxElement' (vectorMapL Abs (sub u v)) == 0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarL MinIdx) maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarL MaxIdx) minElement' = emptyErrorV "minElement" (toScalarL Min) maxElement' = emptyErrorV "maxElement" (toScalarL Max) sumElements' = sumL 1 prodElements' = prodL 1 step' = stepL find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = undefined -- cannot match divide = undefined arctan2' = undefined cmod' m x | m /= 0 = vectorMapValL ModVS m x | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x) fromInt' = int2longV toInt' = long2intV fromZ' = id toZ' = id instance Container Vector Float where conj' = id size' = dim scale' = vectorMapValF Scale addConstant = vectorMapValF AddConstant add' = vectorZipF Add sub = vectorZipF Sub mul = vectorZipF Mul equal u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (round . toScalarF MinIdx) maxIndex' = emptyErrorV "maxIndex" (round . toScalarF MaxIdx) minElement' = emptyErrorV "minElement" (toScalarF Min) maxElement' = emptyErrorV "maxElement" (toScalarF Max) sumElements' = sumF prodElements' = prodF step' = stepF find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = vectorMapValF Recip divide = vectorZipF Div arctan2' = vectorZipF ATan2 cmod' = undefined fromInt' = int2floatV toInt' = float2IntV fromZ' = (single :: Vector R-> Vector Float) . fromZ' toZ' = toZ' . double instance Container Vector Double where conj' = id size' = dim scale' = vectorMapValR Scale addConstant = vectorMapValR AddConstant add' = vectorZipR Add sub = vectorZipR Sub mul = vectorZipR Mul equal u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (round . toScalarR MinIdx) maxIndex' = emptyErrorV "maxIndex" (round . toScalarR MaxIdx) minElement' = emptyErrorV "minElement" (toScalarR Min) maxElement' = emptyErrorV "maxElement" (toScalarR Max) sumElements' = sumR prodElements' = prodR step' = stepD find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = vectorMapValR Recip divide = vectorZipR Div arctan2' = vectorZipR ATan2 cmod' = undefined fromInt' = int2DoubleV toInt' = double2IntV fromZ' = long2DoubleV toZ' = double2longV instance Container Vector (Complex Double) where conj' = conjugateC size' = dim scale' = vectorMapValC Scale addConstant = vectorMapValC AddConstant add' = vectorZipC Add sub = vectorZipC Sub mul = vectorZipC Mul equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj')) maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj')) minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex') maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex') sumElements' = sumC prodElements' = prodC step' = undefined -- cannot match find' = findV assoc' = assocV accum' = accumV ccompare' = undefined -- cannot match cselect' = selectCV selectV scaleRecip = vectorMapValC Recip divide = vectorZipC Div arctan2' = vectorZipC ATan2 cmod' = undefined fromInt' = complex . int2DoubleV toInt' = toInt' . fst . fromComplex fromZ' = complex . long2DoubleV toZ' = toZ' . fst . fromComplex instance Container Vector (Complex Float) where conj' = conjugateQ size' = dim scale' = vectorMapValQ Scale addConstant = vectorMapValQ AddConstant add' = vectorZipQ Add sub = vectorZipQ Sub mul = vectorZipQ Mul equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 scalar' x = fromList [x] konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj')) maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj')) minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex') maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex') sumElements' = sumQ prodElements' = prodQ step' = undefined -- cannot match find' = findV assoc' = assocV accum' = accumV ccompare' = undefined -- cannot match cselect' = selectCV selectV scaleRecip = vectorMapValQ Recip divide = vectorZipQ Div arctan2' = vectorZipQ ATan2 cmod' = undefined fromInt' = complex . int2floatV toInt' = toInt' . fst . fromComplex fromZ' = complex . single . long2DoubleV toZ' = toZ' . double . fst . fromComplex --------------------------------------------------------------- instance (Num a, Element a, Container Vector a) => Container Matrix a where conj' = liftMatrix conj' size' = size scale' x = liftMatrix (scale' x) addConstant x = liftMatrix (addConstant x) add' = liftMatrix2 add' sub = liftMatrix2 sub mul = liftMatrix2 mul equal a b = cols a == cols b && flatten a `equal` flatten b scalar' x = (1><1) [x] konst' v (r,c) = matrixFromVector RowMajor r c (konst' v (r*c)) build' = buildM cmap' f = liftMatrix (mapVector f) atIndex' = (@@>) minIndex' = emptyErrorM "minIndex of Matrix" $ \m -> divMod (minIndex' $ flatten m) (cols m) maxIndex' = emptyErrorM "maxIndex of Matrix" $ \m -> divMod (maxIndex' $ flatten m) (cols m) minElement' = emptyErrorM "minElement of Matrix" (atIndex' <*> minIndex') maxElement' = emptyErrorM "maxElement of Matrix" (atIndex' <*> maxIndex') sumElements' = sumElements' . flatten prodElements' = prodElements' . flatten step' = liftMatrix step' find' = findM assoc' = assocM accum' = accumM ccompare' = compareM cselect' = selectM scaleRecip x = liftMatrix (scaleRecip x) divide = liftMatrix2 divide arctan2' = liftMatrix2 arctan2' cmod' m x | m /= 0 = liftMatrix (cmod' m) x | otherwise = error $ "cmod 0 on matrix "++shSize x fromInt' = liftMatrix fromInt' toInt' = liftMatrix toInt' fromZ' = liftMatrix fromZ' toZ' = liftMatrix toZ' emptyErrorV msg f v = if dim v > 0 then f v else error $ msg ++ " of empty Vector" emptyErrorM msg f m = if rows m > 0 && cols m > 0 then f m else error $ msg++" "++shSize m -------------------------------------------------------------------------------- -- | create a structure with a single element -- -- >>> let v = fromList [1..3::Double] -- >>> v / scalar (norm2 v) -- fromList [0.2672612419124244,0.5345224838248488,0.8017837257372732] -- scalar :: Container c e => e -> c e scalar = scalar' -- | complex conjugate conj :: Container c e => c e -> c e conj = conj' arctan2 :: (Fractional e, Container c e) => c e -> c e -> c e arctan2 = arctan2' -- | 'mod' for integer arrays -- -- >>> cmod 3 (range 5) -- fromList [0,1,2,0,1] cmod :: (Integral e, Container c e) => e -> c e -> c e cmod = cmod' -- | -- >>>fromInt ((2><2) [0..3]) :: Matrix (Complex Double) -- (2><2) -- [ 0.0 :+ 0.0, 1.0 :+ 0.0 -- , 2.0 :+ 0.0, 3.0 :+ 0.0 ] -- fromInt :: (Container c e) => c I -> c e fromInt = fromInt' toInt :: (Container c e) => c e -> c I toInt = toInt' fromZ :: (Container c e) => c Z -> c e fromZ = fromZ' toZ :: (Container c e) => c e -> c Z toZ = toZ' -- | like 'fmap' (cannot implement instance Functor because of Element class constraint) cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b cmap = cmap' -- | generic indexing function -- -- >>> vector [1,2,3] `atIndex` 1 -- 2.0 -- -- >>> matrix 3 [0..8] `atIndex` (2,0) -- 6.0 -- atIndex :: Container c e => c e -> IndexOf c -> e atIndex = atIndex' -- | index of minimum element minIndex :: Container c e => c e -> IndexOf c minIndex = minIndex' -- | index of maximum element maxIndex :: Container c e => c e -> IndexOf c maxIndex = maxIndex' -- | value of minimum element minElement :: Container c e => c e -> e minElement = minElement' -- | value of maximum element maxElement :: Container c e => c e -> e maxElement = maxElement' -- | the sum of elements sumElements :: Container c e => c e -> e sumElements = sumElements' -- | the product of elements prodElements :: Container c e => c e -> e prodElements = prodElements' -- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@ -- -- >>> step $ linspace 5 (-1,1::Double) -- 5 |> [0.0,0.0,0.0,1.0,1.0] -- step :: (Ord e, Container c e) => c e -> c e step = step' -- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@. -- -- Arguments with any dimension = 1 are automatically expanded: -- -- >>> cond ((1><4)[1..]) ((3><1)[1..]) 0 100 ((3><4)[1..]) :: Matrix Double -- (3><4) -- [ 100.0, 2.0, 3.0, 4.0 -- , 0.0, 100.0, 7.0, 8.0 -- , 0.0, 0.0, 100.0, 12.0 ] -- -- >>> let chop x = cond (abs x) 1E-6 0 0 x -- cond :: (Ord e, Container c e, Container c x) => c e -- ^ a -> c e -- ^ b -> c x -- ^ l -> c x -- ^ e -> c x -- ^ g -> c x -- ^ result cond a b l e g = cselect' (ccompare' a b) l e g -- | Find index of elements which satisfy a predicate -- -- >>> find (>0) (ident 3 :: Matrix Double) -- [(0,0),(1,1),(2,2)] -- find :: Container c e => (e -> Bool) -> c e -> [IndexOf c] find = find' -- | Create a structure from an association list -- -- >>> assoc 5 0 [(3,7),(1,4)] :: Vector Double -- fromList [0.0,4.0,0.0,7.0,0.0] -- -- >>> assoc (2,3) 0 [((0,2),7),((1,0),2*i-3)] :: Matrix (Complex Double) -- (2><3) -- [ 0.0 :+ 0.0, 0.0 :+ 0.0, 7.0 :+ 0.0 -- , (-3.0) :+ 2.0, 0.0 :+ 0.0, 0.0 :+ 0.0 ] -- assoc :: Container c e => IndexOf c -- ^ size -> e -- ^ default value -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result assoc = assoc' -- | Modify a structure using an update function -- -- >>> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double -- (5><5) -- [ 1.0, 0.0, 0.0, 3.0, 0.0 -- , 0.0, 6.0, 0.0, 0.0, 0.0 -- , 0.0, 0.0, 1.0, 0.0, 0.0 -- , 0.0, 0.0, 0.0, 1.0, 0.0 -- , 0.0, 0.0, 0.0, 0.0, 1.0 ] -- -- computation of histogram: -- -- >>> accum (konst 0 7) (+) (map (flip (,) 1) [4,5,4,1,5,2,5]) :: Vector Double -- fromList [0.0,1.0,1.0,0.0,2.0,3.0,0.0] -- accum :: Container c e => c e -- ^ initial structure -> (e -> e -> e) -- ^ update function -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result accum = accum' -------------------------------------------------------------------------------- class Konst e d c | d -> c, c -> d where -- | -- >>> konst 7 3 :: Vector Float -- fromList [7.0,7.0,7.0] -- -- >>> konst i (3::Int,4::Int) -- (3><4) -- [ 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 ] -- konst :: e -> d -> c e instance Container Vector e => Konst e Int Vector where konst = konst' instance (Num e, Container Vector e) => Konst e (Int,Int) Matrix where konst = konst' -------------------------------------------------------------------------------- class ( Container Vector t , Container Matrix t , Konst t Int Vector , Konst t (Int,Int) Matrix , CTrans t , Product t , Additive (Vector t) , Additive (Matrix t) , Linear t Vector , Linear t Matrix ) => Numeric t instance Numeric Double instance Numeric (Complex Double) instance Numeric Float instance Numeric (Complex Float) instance Numeric I instance Numeric Z -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | Matrix product and related functions class (Num e, Element e) => Product e where -- | matrix product multiply :: Matrix e -> Matrix e -> Matrix e -- | sum of absolute value of elements (differs in complex case from @norm1@) absSum :: Vector e -> RealOf e -- | sum of absolute value of elements norm1 :: Vector e -> RealOf e -- | euclidean norm norm2 :: Floating e => Vector e -> RealOf e -- | element of maximum magnitude normInf :: Vector e -> RealOf e instance Product Float where norm2 = emptyVal (toScalarF Norm2) absSum = emptyVal (toScalarF AbsSum) norm1 = emptyVal (toScalarF AbsSum) normInf = emptyVal (maxElement . vectorMapF Abs) multiply = emptyMul multiplyF instance Product Double where norm2 = emptyVal (toScalarR Norm2) absSum = emptyVal (toScalarR AbsSum) norm1 = emptyVal (toScalarR AbsSum) normInf = emptyVal (maxElement . vectorMapR Abs) multiply = emptyMul multiplyR instance Product (Complex Float) where norm2 = emptyVal (toScalarQ Norm2) absSum = emptyVal (toScalarQ AbsSum) norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapQ Abs) normInf = emptyVal (maxElement . fst . fromComplex . vectorMapQ Abs) multiply = emptyMul multiplyQ instance Product (Complex Double) where norm2 = emptyVal (toScalarC Norm2) absSum = emptyVal (toScalarC AbsSum) norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapC Abs) normInf = emptyVal (maxElement . fst . fromComplex . vectorMapC Abs) multiply = emptyMul multiplyC instance Product I where norm2 = undefined absSum = emptyVal (sumElements . vectorMapI Abs) norm1 = absSum normInf = emptyVal (maxElement . vectorMapI Abs) multiply = emptyMul (multiplyI 1) instance Product Z where norm2 = undefined absSum = emptyVal (sumElements . vectorMapL Abs) norm1 = absSum normInf = emptyVal (maxElement . vectorMapL Abs) multiply = emptyMul (multiplyL 1) emptyMul m a b | x1 == 0 && x2 == 0 || r == 0 || c == 0 = konst' 0 (r,c) | otherwise = m a b where r = rows a x1 = cols a x2 = rows b c = cols b emptyVal f v = if dim v > 0 then f v else 0 -- FIXME remove unused C wrappers -- | unconjugated dot product udot :: Product e => Vector e -> Vector e -> e udot u v | dim u == dim v = val (asRow u `multiply` asColumn v) | otherwise = error $ "different dimensions "++show (dim u)++" and "++show (dim v)++" in dot product" where val m | dim u > 0 = m@@>(0,0) | otherwise = 0 ---------------------------------------------------------- -- synonym for matrix product mXm :: Product t => Matrix t -> Matrix t -> Matrix t mXm = multiply -- matrix - vector product mXv :: Product t => Matrix t -> Vector t -> Vector t mXv m v = flatten $ m `mXm` (asColumn v) -- vector - matrix product vXm :: Product t => Vector t -> Matrix t -> Vector t vXm v m = flatten $ (asRow v) `mXm` m {- | Outer product of two vectors. >>> fromList [1,2,3] `outer` fromList [5,2,3] (3><3) [ 5.0, 2.0, 3.0 , 10.0, 4.0, 6.0 , 15.0, 6.0, 9.0 ] -} outer :: (Product t) => Vector t -> Vector t -> Matrix t outer u v = asColumn u `multiply` asRow v {- | Kronecker product of two matrices. @m1=(2><3) [ 1.0, 2.0, 0.0 , 0.0, -1.0, 3.0 ] m2=(4><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 ]@ >>> kronecker m1 m2 (8><9) [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0 , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0 , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0 , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0 , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0 , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0 , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0 , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ] -} kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t kronecker a b = fromBlocks . chunksOf (cols a) . map (reshape (cols b)) . toRows $ flatten a `outer` flatten b ------------------------------------------------------------------- class Convert t where real :: Complexable c => c (RealOf t) -> c t complex :: Complexable c => c t -> c (ComplexOf t) single :: Complexable c => c t -> c (SingleOf t) double :: Complexable c => c t -> c (DoubleOf t) toComplex :: (Complexable c, RealElement t) => (c t, c t) -> c (Complex t) fromComplex :: (Complexable c, RealElement t) => c (Complex t) -> (c t, c t) instance Convert Double where real = id complex = comp' single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert Float where real = id complex = comp' single = id double = double' toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Double) where real = comp' complex = id single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Float) where real = comp' complex = id single = id double = double' toComplex = toComplex' fromComplex = fromComplex' ------------------------------------------------------------------- type family RealOf x type instance RealOf Double = Double type instance RealOf (Complex Double) = Double type instance RealOf Float = Float type instance RealOf (Complex Float) = Float type instance RealOf I = I type instance RealOf Z = Z type family ComplexOf x type instance ComplexOf Double = Complex Double type instance ComplexOf (Complex Double) = Complex Double type instance ComplexOf Float = Complex Float type instance ComplexOf (Complex Float) = Complex Float type family SingleOf x type instance SingleOf Double = Float type instance SingleOf Float = Float type instance SingleOf (Complex a) = Complex (SingleOf a) type family DoubleOf x type instance DoubleOf Double = Double type instance DoubleOf Float = Double type instance DoubleOf (Complex a) = Complex (DoubleOf a) type family ElementOf c type instance ElementOf (Vector a) = a type instance ElementOf (Matrix a) = a ------------------------------------------------------------ buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ] where rs = map fromIntegral [0 .. (rc-1)] cs = map fromIntegral [0 .. (cc-1)] buildV n f = fromList [f k | k <- ks] where ks = map fromIntegral [0 .. (n-1)] -------------------------------------------------------- -- | Creates a square matrix with a given diagonal. diag :: (Num a, Element a) => Vector a -> Matrix a diag v = diagRect 0 v n n where n = dim v -- | creates the identity matrix of given dimension ident :: (Num a, Element a) => Int -> Matrix a ident n = diag (constantD 1 n) -------------------------------------------------------- findV p x = foldVectorWithIndex g [] x where g k z l = if p z then k:l else l findM p x = map ((`divMod` cols x)) $ findV p (flatten x) assocV n z xs = ST.runSTVector $ do v <- ST.newVector z n mapM_ (\(k,x) -> ST.writeVector v k x) xs return v assocM (r,c) z xs = ST.runSTMatrix $ do m <- ST.newMatrix z r c mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs return m accumV v0 f xs = ST.runSTVector $ do v <- ST.thawVector v0 mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs return v accumM m0 f xs = ST.runSTMatrix $ do m <- ST.thawMatrix m0 mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs return m ---------------------------------------------------------------------- compareM a b = matrixFromVector RowMajor (rows a'') (cols a'') $ ccompare' a' b' where args@(a'':_) = conformMs [a,b] [a', b'] = map flatten args compareCV f a b = f a' b' where [a', b'] = conformVs [a,b] selectM c l e t = matrixFromVector RowMajor (rows a'') (cols a'') $ cselect' (toInt c') l' e' t' where args@(a'':_) = conformMs [fromInt c,l,e,t] [c', l', e', t'] = map flatten args selectCV f c l e t = f (toInt c') l' e' t' where [c', l', e', t'] = conformVs [fromInt c,l,e,t] -------------------------------------------------------------------------------- class CTrans t where ctrans :: Matrix t -> Matrix t ctrans = trans instance CTrans Float instance CTrans R instance CTrans I instance CTrans Z instance CTrans C where ctrans = conj . trans instance CTrans (Complex Float) where ctrans = conj . trans class Transposable m mt | m -> mt, mt -> m where -- | conjugate transpose tr :: m -> mt -- | transpose tr' :: m -> mt instance (CTrans t, Container Vector t) => Transposable (Matrix t) (Matrix t) where tr = ctrans tr' = trans class Additive c where add :: c -> c -> c class Linear t c where scale :: t -> c t -> c t instance Container Vector t => Linear t Vector where scale = scale' instance Container Matrix t => Linear t Matrix where scale = scale' instance Container Vector t => Additive (Vector t) where add = add' instance Container Matrix t => Additive (Matrix t) where add = add' class Testable t where checkT :: t -> (Bool, IO()) ioCheckT :: t -> IO (Bool, IO()) ioCheckT = return . checkT -------------------------------------------------------------------------------- hmatrix-0.17.0.2/src/Internal/Vector.hs0000644000000000000000000003565212722301655015760 0ustar0000000000000000{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module : Internal.Vector -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- module Internal.Vector( I,Z,R,C, fi,ti, Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith, createVector, avec, inlinePerformIO, toList, dim, (@>), at', (|>), vjoin, subVector, takesV, idxs, buildVector, asReal, asComplex, toByteString,fromByteString, zipVector, unzipVector, zipVectorWith, unzipVectorWith, foldVector, foldVectorG, foldVectorWithIndex, foldLoop, mapVector, mapVectorM, mapVectorM_, mapVectorWithIndex, mapVectorWithIndexM, mapVectorWithIndexM_ ) where import Foreign.Marshal.Array import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable import Foreign.C.Types(CInt) import Data.Int(Int64) import Data.Complex import System.IO.Unsafe(unsafePerformIO) import GHC.ForeignPtr(mallocPlainForeignPtrBytes) import GHC.Base(realWorld#, IO(IO), when) import qualified Data.Vector.Storable as Vector import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) #ifdef BINARY import Data.Binary import Control.Monad(replicateM) import qualified Data.ByteString.Internal as BS import Data.Vector.Storable.Internal(updPtr) #endif type I = CInt type Z = Int64 type R = Double type C = Complex Double -- | specialized fromIntegral fi :: Int -> CInt fi = fromIntegral -- | specialized fromIntegral ti :: CInt -> Int ti = fromIntegral -- | Number of elements dim :: (Storable t) => Vector t -> Int dim = Vector.length -- C-Haskell vector adapter {-# INLINE avec #-} avec :: Storable a => (CInt -> Ptr a -> b) -> Vector a -> b avec f v = inlinePerformIO (unsafeWith v (return . f (fromIntegral (Vector.length v)))) infixl 1 `avec` -- allocates memory for a new vector createVector :: Storable a => Int -> IO (Vector a) createVector n = do when (n < 0) $ error ("trying to createVector of negative dim: "++show n) fp <- doMalloc undefined return $ unsafeFromForeignPtr fp 0 n where -- -- Use the much cheaper Haskell heap allocated storage -- for foreign pointer space we control -- doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc dummy = do mallocPlainForeignPtrBytes (n * sizeOf dummy) {- | creates a Vector from a list: @> fromList [2,3,5,7] 4 |> [2.0,3.0,5.0,7.0]@ -} safeRead v = inlinePerformIO . unsafeWith v {-# INLINE safeRead #-} inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} {- extracts the Vector elements to a list >>> toList (linspace 5 (1,10)) [1.0,3.25,5.5,7.75,10.0] -} toList :: Storable a => Vector a -> [a] toList v = safeRead v $ peekArray (dim v) {- | Create a vector from a list of elements and explicit dimension. The input list is truncated if it is too long, so it may safely be used, for instance, with infinite lists. >>> 5 |> [1..] fromList [1.0,2.0,3.0,4.0,5.0] -} (|>) :: (Storable a) => Int -> [a] -> Vector a infixl 9 |> n |> l | length l' == n = fromList l' | otherwise = error "list too short for |>" where l' = take n l -- | Create a vector of indexes, useful for matrix extraction using '(??)' idxs :: [Int] -> Vector I idxs js = fromList (map fromIntegral js) :: Vector I {- | takes a number of consecutive elements from a Vector >>> subVector 2 3 (fromList [1..10]) fromList [3.0,4.0,5.0] -} subVector :: Storable t => Int -- ^ index of the starting element -> Int -- ^ number of elements to extract -> Vector t -- ^ source -> Vector t -- ^ result subVector = Vector.slice {- | Reads a vector position: >>> fromList [0..9] @> 7 7.0 -} (@>) :: Storable t => Vector t -> Int -> t infixl 9 @> v @> n | n >= 0 && n < dim v = at' v n | otherwise = error "vector index out of range" {-# INLINE (@>) #-} -- | access to Vector elements without range checking at' :: Storable a => Vector a -> Int -> a at' v n = safeRead v $ flip peekElemOff n {-# INLINE at' #-} {- | concatenate a list of vectors >>> vjoin [fromList [1..5::Double], konst 1 3] fromList [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0] -} vjoin :: Storable t => [Vector t] -> Vector t vjoin [] = fromList [] vjoin [v] = v vjoin as = unsafePerformIO $ do let tot = sum (map dim as) r <- createVector tot unsafeWith r $ \ptr -> joiner as tot ptr return r where joiner [] _ _ = return () joiner (v:cs) _ p = do let n = dim v unsafeWith v $ \pb -> copyArray p pb n joiner cs 0 (advancePtr p n) {- | Extract consecutive subvectors of the given sizes. >>> takesV [3,4] (linspace 10 (1,10::Double)) [fromList [1.0,2.0,3.0],fromList [4.0,5.0,6.0,7.0]] -} takesV :: Storable t => [Int] -> Vector t -> [Vector t] takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w) | otherwise = go ms w where go [] _ = [] go (n:ns) v = subVector 0 n v : go ns (subVector n (dim v - n) v) --------------------------------------------------------------- -- | transforms a complex vector into a real vector with alternating real and imaginary parts asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n) where (fp,i,n) = unsafeToForeignPtr v -- | transforms a real vector into a complex vector with alternating real and imaginary parts asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a) asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2) where (fp,i,n) = unsafeToForeignPtr v -------------------------------------------------------------------------------- -- | map on Vectors mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b mapVector f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f x) go (k-1) go (dim v -1) return w {-# INLINE mapVector #-} -- | zipWith for Vectors zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c zipVectorWith f u v = unsafePerformIO $ do let n = min (dim u) (dim v) w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do x <- peekElemOff pu k y <- peekElemOff pv k pokeElemOff pw k (f x y) go (k-1) go (n -1) return w {-# INLINE zipVectorWith #-} -- | unzipWith for Vectors unzipVectorWith :: (Storable (a,b), Storable c, Storable d) => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d) unzipVectorWith f u = unsafePerformIO $ do let n = dim u v <- createVector n w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do z <- peekElemOff pu k let (x,y) = f z pokeElemOff pv k x pokeElemOff pw k y go (k-1) go (n-1) return (v,w) {-# INLINE unzipVectorWith #-} foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b foldVector f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f y s) go (dim v -1) x {-# INLINE foldVector #-} -- the zero-indexed index is passed to the folding function foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b foldVectorWithIndex f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f k y s) go (dim v -1) x {-# INLINE foldVectorWithIndex #-} foldLoop f s0 d = go (d - 1) s0 where go 0 s = f (0::Int) s go !j !s = go (j - 1) (f j s) foldVectorG f s0 v = foldLoop g s0 (dim v) where g !k !s = f k (safeRead v . flip peekElemOff) s {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) {-# INLINE foldVectorG #-} ------------------------------------------------------------------- -- | monadic map over Vectors -- the monad @m@ must be strict mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b) mapVectorM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorM #-} -- | monadic map over Vectors mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m () mapVectorM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f x mapVectorM' (k+1) t {-# INLINE mapVectorM_ #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function -- the monad @m@ must be strict mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b) mapVectorWithIndexM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorWithIndexM #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m () mapVectorWithIndexM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f k x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f k x mapVectorM' (k+1) t {-# INLINE mapVectorWithIndexM_ #-} mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b --mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b]) mapVectorWithIndex f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f k x) go (k-1) go (dim v -1) return w {-# INLINE mapVectorWithIndex #-} -------------------------------------------------------------------------------- #ifdef BINARY -- a 64K cache, with a Double taking 13 bytes in Bytestring, -- implies a chunk size of 5041 chunk :: Int chunk = 5000 chunks :: Int -> [Int] chunks d = let c = d `div` chunk m = d `mod` chunk in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) putVector v = mapM_ put $! toList v getVector d = do xs <- replicateM d get return $! fromList xs -------------------------------------------------------------------------------- toByteString :: Storable t => Vector t -> BS.ByteString toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v) where (fp,o,_n) = unsafeToForeignPtr v sz = sizeOf (v@>0) fromByteString :: Storable t => BS.ByteString -> Vector t fromByteString (BS.PS fp o n) = r where r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n' n' = n `div` sz sz = sizeOf (r@>0) -------------------------------------------------------------------------------- instance (Binary a, Storable a) => Binary (Vector a) where put v = do let d = dim v put d mapM_ putVector $! takesV (chunks d) v -- put = put . v2bs get = do d <- get vs <- mapM getVector $ chunks d return $! vjoin vs -- get = fmap bs2v get #endif ------------------------------------------------------------------- {- | creates a Vector of the specified length using the supplied function to to map the index to the value at that index. @> buildVector 4 fromIntegral 4 |> [0.0,1.0,2.0,3.0]@ -} buildVector :: Storable a => Int -> (Int -> a) -> Vector a buildVector len f = fromList $ map f [0 .. (len - 1)] -- | zip for Vectors zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b) zipVector = zipVectorWith (,) -- | unzip for Vectors unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b) unzipVector = unzipVectorWith id ------------------------------------------------------------------- hmatrix-0.17.0.2/src/Internal/CG.hs0000644000000000000000000001173412722301655015002 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} module Internal.CG( cgSolve, cgSolve', CGState(..), R, V ) where import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Element import Internal.IO import Internal.Container import Internal.Sparse import Numeric.Vector() import Internal.Algorithms(linearSolveLS, linearSolve, relativeError, pnorm, NormType(..)) import Control.Arrow((***)) {- import Util.Misc(debug, debugMat) (//) :: Show a => a -> String -> a infix 0 // -- , /// a // b = debug b id a (///) :: V -> String -> V infix 0 /// v /// b = debugMat b 2 asRow v -} type V = Vector R data CGState = CGState { cgp :: Vector R -- ^ conjugate gradient , cgr :: Vector R -- ^ residual , cgr2 :: R -- ^ squared norm of residual , cgx :: Vector R -- ^ current solution , cgdx :: R -- ^ normalized size of correction } cg :: Bool -> (V -> V) -> (V -> V) -> CGState -> CGState cg sym at a (CGState p r r2 x _) = CGState p' r' r'2 x' rdx where ap1 = a p ap | sym = ap1 | otherwise = at ap1 pap | sym = p <.> ap1 | otherwise = norm2 ap1 ** 2 alpha = r2 / pap dx = scale alpha p x' = x + dx r' = r - scale alpha ap r'2 = r' <.> r' beta = r'2 / r2 p' = r' + scale beta p rdx = norm2 dx / max 1 (norm2 x) conjugrad :: Bool -> GMatrix -> V -> V -> R -> R -> [CGState] conjugrad sym a b = solveG sym (tr a !#>) (a !#>) (cg sym) b solveG :: Bool -> (V -> V) -> (V -> V) -> ((V -> V) -> (V -> V) -> CGState -> CGState) -> V -> V -> R -> R -> [CGState] solveG sym mat ma meth rawb x0' ϵb ϵx = takeUntil ok . iterate (meth mat ma) $ CGState p0 r0 r20 x0 1 where a = if sym then ma else mat . ma b = if sym then rawb else mat rawb x0 = if x0' == 0 then konst 0 (dim b) else x0' r0 = b - a x0 r20 = r0 <.> r0 p0 = r0 nb2 = b <.> b ok CGState {..} = cgr2 Bool) -> [a] -> [a] takeUntil q xs = a++ take 1 b where (a,b) = break q xs -- | Solve a sparse linear system using the conjugate gradient method with default parameters. cgSolve :: Bool -- ^ is symmetric -> GMatrix -- ^ coefficient matrix -> Vector R -- ^ right-hand side -> Vector R -- ^ solution cgSolve sym a b = cgx $ last $ cgSolve' sym 1E-4 1E-3 n a b 0 where n = max 10 (round $ sqrt (fromIntegral (dim b) :: Double)) -- | Solve a sparse linear system using the conjugate gradient method with default parameters. cgSolve' :: Bool -- ^ symmetric -> R -- ^ relative tolerance for the residual (e.g. 1E-4) -> R -- ^ relative tolerance for δx (e.g. 1E-3) -> Int -- ^ maximum number of iterations -> GMatrix -- ^ coefficient matrix -> Vector R -- ^ initial solution -> Vector R -- ^ right-hand side -> [CGState] -- ^ solution cgSolve' sym er es n a b x = take n $ conjugrad sym a b x er es -------------------------------------------------------------------------------- instance Testable GMatrix where checkT _ = (ok,info) where sma = convo2 20 3 x1 = vect [1..20] x2 = vect [1..40] sm = mkSparse sma dm = toDense sma s1 = sm !#> x1 d1 = dm #> x1 s2 = tr sm !#> x2 d2 = tr dm #> x2 sdia = mkDiagR 40 20 (vect [1..10]) s3 = sdia !#> x1 s4 = tr sdia !#> x2 ddia = diagRect 0 (vect [1..10]) 40 20 d3 = ddia #> x1 d4 = tr ddia #> x2 v = testb 40 s5 = cgSolve False sm v d5 = denseSolve dm v symassoc = [((0,0),1.0),((1,1),2.0),((0,1),0.5),((1,0),0.5)] b = vect [3,4] d6 = flatten $ linearSolve (toDense symassoc) (asColumn b) s6 = cgSolve True (mkSparse symassoc) b info = do print sm disp (toDense sma) print s1; print d1 print s2; print d2 print s3; print d3 print s4; print d4 print s5; print d5 print $ relativeError (pnorm Infinity) s5 d5 print s6; print d6 print $ relativeError (pnorm Infinity) s6 d6 ok = s1==d1 && s2==d2 && s3==d3 && s4==d4 && relativeError (pnorm Infinity) s5 d5 < 1E-10 && relativeError (pnorm Infinity) s6 d6 < 1E-10 disp = putStr . dispf 2 vect = fromList :: [Double] -> Vector Double convomat :: Int -> Int -> AssocMatrix convomat n k = [ ((i,j `mod` n),1) | i<-[0..n-1], j <- [i..i+k-1]] convo2 :: Int -> Int -> AssocMatrix convo2 n k = m1 ++ m2 where m1 = convomat n k m2 = map (((+n) *** id) *** id) m1 testb n = vect $ take n $ cycle ([0..10]++[9,8..1]) denseSolve a = flatten . linearSolveLS a . asColumn -- mkDiag v = mkDiagR (dim v) (dim v) v hmatrix-0.17.0.2/src/Internal/Element.hs0000644000000000000000000004366012722301655016105 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Matrix -- Copyright : (c) Alberto Ruiz 2007-10 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- A Matrix representation suitable for numerical computations using LAPACK and GSL. -- -- This module provides basic functions for manipulation of structure. ----------------------------------------------------------------------------- module Internal.Element where import Internal.Vector import Internal.Matrix import Internal.Vectorized import qualified Internal.ST as ST import Data.Array import Text.Printf import Data.List(transpose,intersperse) import Data.List.Split(chunksOf) import Foreign.Storable(Storable) import System.IO.Unsafe(unsafePerformIO) import Control.Monad(liftM) ------------------------------------------------------------------- #ifdef BINARY import Data.Binary instance (Binary (Vector a), Element a) => Binary (Matrix a) where put m = do put (cols m) put (flatten m) get = do c <- get v <- get return (reshape c v) #endif ------------------------------------------------------------------- instance (Show a, Element a) => (Show (Matrix a)) where show m | rows m == 0 || cols m == 0 = sizes m ++" []" show m = (sizes m++) . dsp . map (map show) . toLists $ m sizes m = "("++show (rows m)++"><"++show (cols m)++")\n" dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse ", " ------------------------------------------------------------------ instance (Element a, Read a) => Read (Matrix a) where readsPrec _ s = [((rs>' $ dims breakAt c l = (a++[c],tail b) where (a,b) = break (==c) l -------------------------------------------------------------------------------- -- | Specification of indexes for the operator '??'. data Extractor = All | Range Int Int Int | Pos (Vector I) | PosCyc (Vector I) | Take Int | TakeLast Int | Drop Int | DropLast Int deriving Show ppext All = ":" ppext (Range a 1 c) = printf "%d:%d" a c ppext (Range a b c) = printf "%d:%d:%d" a b c ppext (Pos v) = show (toList v) ppext (PosCyc v) = "Cyclic"++show (toList v) ppext (Take n) = printf "Take %d" n ppext (Drop n) = printf "Drop %d" n ppext (TakeLast n) = printf "TakeLast %d" n ppext (DropLast n) = printf "DropLast %d" n {- | General matrix slicing. >>> m (4><5) [ 0, 1, 2, 3, 4 , 5, 6, 7, 8, 9 , 10, 11, 12, 13, 14 , 15, 16, 17, 18, 19 ] >>> m ?? (Take 3, DropLast 2) (3><3) [ 0, 1, 2 , 5, 6, 7 , 10, 11, 12 ] >>> m ?? (Pos (idxs[2,1]), All) (2><5) [ 10, 11, 12, 13, 14 , 5, 6, 7, 8, 9 ] >>> m ?? (PosCyc (idxs[-7,80]), Range 4 (-2) 0) (2><3) [ 9, 7, 5 , 4, 2, 0 ] -} infixl 9 ?? (??) :: Element t => Matrix t -> (Extractor,Extractor) -> Matrix t minEl = toScalarI Min maxEl = toScalarI Max cmodi = vectorMapValI ModVS extractError m (e1,e2)= error $ printf "can't extract (%s,%s) from matrix %dx%d" (ppext e1::String) (ppext e2::String) (rows m) (cols m) m ?? (Range a s b,e) | s /= 1 = m ?? (Pos (idxs [a,a+s .. b]), e) m ?? (e,Range a s b) | s /= 1 = m ?? (e, Pos (idxs [a,a+s .. b])) m ?? e@(Range a _ b,_) | a < 0 || b >= rows m = extractError m e m ?? e@(_,Range a _ b) | a < 0 || b >= cols m = extractError m e m ?? e@(Pos vs,_) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (rows m)) = extractError m e m ?? e@(_,Pos vs) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (cols m)) = extractError m e m ?? (All,All) = m m ?? (Range a _ b,e) | a > b = m ?? (Take 0,e) m ?? (e,Range a _ b) | a > b = m ?? (e,Take 0) m ?? (Take n,e) | n <= 0 = (0>= rows m = m ?? (All,e) m ?? (e,Take n) | n <= 0 = (rows m><0) [] ?? (e,All) | n >= cols m = m ?? (e,All) m ?? (Drop n,e) | n <= 0 = m ?? (All,e) | n >= rows m = (0>= cols m = (rows m><0) [] ?? (e,All) m ?? (TakeLast n, e) = m ?? (Drop (rows m - n), e) m ?? (e, TakeLast n) = m ?? (e, Drop (cols m - n)) m ?? (DropLast n, e) = m ?? (Take (rows m - n), e) m ?? (e, DropLast n) = m ?? (e, Take (cols m - n)) m ?? (er,ec) = unsafePerformIO $ extractR (orderOf m) m moder rs modec cs where (moder,rs) = mkExt (rows m) er (modec,cs) = mkExt (cols m) ec ran a b = (0, idxs [a,b]) pos ks = (1, ks) mkExt _ (Pos ks) = pos ks mkExt n (PosCyc ks) | n == 0 = mkExt n (Take 0) | otherwise = pos (cmodi (fi n) ks) mkExt _ (Range mn _ mx) = ran mn mx mkExt _ (Take k) = ran 0 (k-1) mkExt n (Drop k) = ran k (n-1) mkExt n _ = ran 0 (n-1) -- All -------------------------------------------------------------------------------- -- | obtains the common value of a property of a list common :: (Eq a) => (b->a) -> [b] -> Maybe a common f = commonval . map f where commonval :: (Eq a) => [a] -> Maybe a commonval [] = Nothing commonval [a] = Just a commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing -- | creates a matrix from a vertical list of matrices joinVert :: Element t => [Matrix t] -> Matrix t joinVert [] = emptyM 0 0 joinVert ms = case common cols ms of Nothing -> error "(impossible) joinVert on matrices with different number of columns" Just c -> matrixFromVector RowMajor (sum (map rows ms)) c $ vjoin (map flatten ms) -- | creates a matrix from a horizontal list of matrices joinHoriz :: Element t => [Matrix t] -> Matrix t joinHoriz ms = trans. joinVert . map trans $ ms {- | Create a matrix from blocks given as a list of lists of matrices. Single row-column components are automatically expanded to match the corresponding common row and column: @ disp = putStr . dispf 2 @ >>> disp $ fromBlocks [[ident 5, 7, row[10,20]], [3, diagl[1,2,3], 0]] 8x10 1 0 0 0 0 7 7 7 10 20 0 1 0 0 0 7 7 7 10 20 0 0 1 0 0 7 7 7 10 20 0 0 0 1 0 7 7 7 10 20 0 0 0 0 1 7 7 7 10 20 3 3 3 3 3 1 0 0 0 0 3 3 3 3 3 0 2 0 0 0 3 3 3 3 3 0 0 3 0 0 -} fromBlocks :: Element t => [[Matrix t]] -> Matrix t fromBlocks = fromBlocksRaw . adaptBlocks fromBlocksRaw mms = joinVert . map joinHoriz $ mms adaptBlocks ms = ms' where bc = case common length ms of Just c -> c Nothing -> error "fromBlocks requires rectangular [[Matrix]]" rs = map (compatdim . map rows) ms cs = map (compatdim . map cols) (transpose ms) szs = sequence [rs,cs] ms' = chunksOf bc $ zipWith g szs (concat ms) g [Just nr,Just nc] m | nr == r && nc == c = m | r == 1 && c == 1 = matrixFromVector RowMajor nr nc (constantD x (nr*nc)) | r == 1 = fromRows (replicate nr (flatten m)) | otherwise = fromColumns (replicate nc (flatten m)) where r = rows m c = cols m x = m@@>(0,0) g _ _ = error "inconsistent dimensions in fromBlocks" -------------------------------------------------------------------------------- {- | create a block diagonal matrix >>> disp 2 $ diagBlock [konst 1 (2,2), konst 2 (3,5), col [5,7]] 7x8 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 0 0 0 0 0 0 0 0 5 0 0 0 0 0 0 0 7 >>> diagBlock [(0><4)[], konst 2 (2,3)] :: Matrix Double (2><7) [ 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 , 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 ] -} diagBlock :: (Element t, Num t) => [Matrix t] -> Matrix t diagBlock ms = fromBlocks $ zipWith f ms [0..] where f m k = take n $ replicate k z ++ m : repeat z n = length ms z = (1><1) [0] -------------------------------------------------------------------------------- -- | Reverse rows flipud :: Element t => Matrix t -> Matrix t flipud m = extractRows [r-1,r-2 .. 0] $ m where r = rows m -- | Reverse columns fliprl :: Element t => Matrix t -> Matrix t fliprl m = extractColumns [c-1,c-2 .. 0] $ m where c = cols m ------------------------------------------------------------ {- | creates a rectangular diagonal matrix: >>> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double (4><5) [ 10.0, 7.0, 7.0, 7.0, 7.0 , 7.0, 20.0, 7.0, 7.0, 7.0 , 7.0, 7.0, 30.0, 7.0, 7.0 , 7.0, 7.0, 7.0, 7.0, 7.0 ] -} diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t diagRect z v r c = ST.runSTMatrix $ do m <- ST.newMatrix z r c let d = min r c `min` (dim v) mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1] return m -- | extracts the diagonal from a rectangular matrix takeDiag :: (Element t) => Matrix t -> Vector t takeDiag m = fromList [flatten m @> (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]] ------------------------------------------------------------ {- | Create a matrix from a list of elements >>> (2><3) [2, 4, 7+2*iC, -3, 11, 0] (2><3) [ 2.0 :+ 0.0, 4.0 :+ 0.0, 7.0 :+ 2.0 , (-3.0) :+ (-0.0), 11.0 :+ 0.0, 0.0 :+ 0.0 ] The input list is explicitly truncated, so that it can safely be used with lists that are too long (like infinite lists). >>> (2><3)[1..] (2><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 ] This is the format produced by the instances of Show (Matrix a), which can also be used for input. -} (><) :: (Storable a) => Int -> Int -> [a] -> Matrix a r >< c = f where f l | dim v == r*c = matrixFromVector RowMajor r c v | otherwise = error $ "inconsistent list size = " ++show (dim v) ++" in ("++show r++"><"++show c++")" where v = fromList $ take (r*c) l ---------------------------------------------------------------- takeRows :: Element t => Int -> Matrix t -> Matrix t takeRows n mt = subMatrix (0,0) (n, cols mt) mt -- | Creates a matrix with the last n rows of another matrix takeLastRows :: Element t => Int -> Matrix t -> Matrix t takeLastRows n mt = subMatrix (rows mt - n, 0) (n, cols mt) mt dropRows :: Element t => Int -> Matrix t -> Matrix t dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt -- | Creates a copy of a matrix without the last n rows dropLastRows :: Element t => Int -> Matrix t -> Matrix t dropLastRows n mt = subMatrix (0,0) (rows mt - n, cols mt) mt takeColumns :: Element t => Int -> Matrix t -> Matrix t takeColumns n mt = subMatrix (0,0) (rows mt, n) mt -- |Creates a matrix with the last n columns of another matrix takeLastColumns :: Element t => Int -> Matrix t -> Matrix t takeLastColumns n mt = subMatrix (0, cols mt - n) (rows mt, n) mt dropColumns :: Element t => Int -> Matrix t -> Matrix t dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt -- | Creates a copy of a matrix without the last n columns dropLastColumns :: Element t => Int -> Matrix t -> Matrix t dropLastColumns n mt = subMatrix (0,0) (rows mt, cols mt - n) mt ---------------------------------------------------------------- {- | Creates a 'Matrix' from a list of lists (considered as rows). >>> fromLists [[1,2],[3,4],[5,6]] (3><2) [ 1.0, 2.0 , 3.0, 4.0 , 5.0, 6.0 ] -} fromLists :: Element t => [[t]] -> Matrix t fromLists = fromRows . map fromList -- | creates a 1-row matrix from a vector -- -- >>> asRow (fromList [1..5]) -- (1><5) -- [ 1.0, 2.0, 3.0, 4.0, 5.0 ] -- asRow :: Storable a => Vector a -> Matrix a asRow = trans . asColumn -- | creates a 1-column matrix from a vector -- -- >>> asColumn (fromList [1..5]) -- (5><1) -- [ 1.0 -- , 2.0 -- , 3.0 -- , 4.0 -- , 5.0 ] -- asColumn :: Storable a => Vector a -> Matrix a asColumn v = reshape 1 v {- | creates a Matrix of the specified size using the supplied function to to map the row\/column position to the value at that row\/column position. @> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c) (3><4) [ 0.0, 0.0, 0.0, 0.0, 0.0 , 0.0, 1.0, 2.0, 3.0, 4.0 , 0.0, 2.0, 4.0, 6.0, 8.0]@ Hilbert matrix of order N: @hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@ -} buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a buildMatrix rc cc f = fromLists $ map (map f) $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)] ----------------------------------------------------- fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e fromArray2D m = (r> [Int] -> Matrix t -> Matrix t extractRows l m = m ?? (Pos (idxs l), All) -- | rearranges the rows of a matrix according to the order given in a list of integers. extractColumns :: Element t => [Int] -> Matrix t -> Matrix t extractColumns l m = m ?? (All, Pos (idxs l)) {- | creates matrix by repetition of a matrix a given number of rows and columns >>> repmat (ident 2) 2 3 (4><6) [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0 , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0 , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ] -} repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t repmat m r c | r == 0 || c == 0 = emptyM (r*rows m) (c*cols m) | otherwise = fromBlocks $ replicate r $ replicate c $ m -- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix. liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t liftMatrix2Auto f m1 m2 | compat' m1 m2 = lM f m1 m2 | ok = lM f m1' m2' | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2 where (r1,c1) = size m1 (r2,c2) = size m2 r = max r1 r2 c = max c1 c2 r0 = min r1 r2 c0 = min c1 c2 ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2 m1' = conformMTo (r,c) m1 m2' = conformMTo (r,c) m2 -- FIXME do not flatten if equal order lM f m1 m2 = matrixFromVector RowMajor (max' (rows m1) (rows m2)) (max' (cols m1) (cols m2)) (f (flatten m1) (flatten m2)) where max' 1 b = b max' a 1 = a max' a b = max a b compat' :: Matrix a -> Matrix b -> Bool compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2 where s1 = size m1 s2 = size m2 ------------------------------------------------------------ toBlockRows [r] m | r == rows m = [m] toBlockRows rs m | cols m > 0 = map (reshape (cols m)) (takesV szs (flatten m)) | otherwise = map g rs where szs = map (* cols m) rs g k = (k><0)[] toBlockCols [c] m | c == cols m = [m] toBlockCols cs m = map trans . toBlockRows cs . trans $ m -- | Partition a matrix into blocks with the given numbers of rows and columns. -- The remaining rows and columns are discarded. toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]] toBlocks rs cs m | ok = map (toBlockCols cs) . toBlockRows rs $ m | otherwise = error $ "toBlocks: bad partition: "++show rs++" "++show cs ++ " "++shSize m where ok = sum rs <= rows m && sum cs <= cols m && all (>=0) rs && all (>=0) cs -- | Fully partition a matrix into blocks of the same size. If the dimensions are not -- a multiple of the given size the last blocks will be smaller. toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]] toBlocksEvery r c m | r < 1 || c < 1 = error $ "toBlocksEvery expects block sizes > 0, given "++show r++" and "++ show c | otherwise = toBlocks rs cs m where (qr,rr) = rows m `divMod` r (qc,rc) = cols m `divMod` c rs = replicate qr r ++ if rr > 0 then [rr] else [] cs = replicate qc c ++ if rc > 0 then [rc] else [] ------------------------------------------------------------------- -- Given a column number and a function taking matrix indexes, returns -- a function which takes vector indexes (that can be used on the -- flattened matrix). mk :: Int -> ((Int, Int) -> t) -> (Int -> t) mk c g = \k -> g (divMod k c) {- | >>> mapMatrixWithIndexM_ (\(i,j) v -> printf "m[%d,%d] = %.f\n" i j v :: IO()) ((2><3)[1 :: Double ..]) m[0,0] = 1 m[0,1] = 2 m[0,2] = 3 m[1,0] = 4 m[1,1] = 5 m[1,2] = 6 -} mapMatrixWithIndexM_ :: (Element a, Num a, Monad m) => ((Int, Int) -> a -> m ()) -> Matrix a -> m () mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m where c = cols m {- | >>> mapMatrixWithIndexM (\(i,j) v -> Just $ 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double) Just (3><3) [ 100.0, 1.0, 2.0 , 10.0, 111.0, 12.0 , 20.0, 21.0, 122.0 ] -} mapMatrixWithIndexM :: (Element a, Storable b, Monad m) => ((Int, Int) -> a -> m b) -> Matrix a -> m (Matrix b) mapMatrixWithIndexM g m = liftM (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m where c = cols m {- | >>> mapMatrixWithIndex (\(i,j) v -> 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double) (3><3) [ 100.0, 1.0, 2.0 , 10.0, 111.0, 12.0 , 20.0, 21.0, 122.0 ] -} mapMatrixWithIndex :: (Element a, Storable b) => ((Int, Int) -> a -> b) -> Matrix a -> Matrix b mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m where c = cols m mapMatrix :: (Element a, Element b) => (a -> b) -> Matrix a -> Matrix b mapMatrix f = liftMatrix (mapVector f) hmatrix-0.17.0.2/src/Internal/Sparse.hs0000644000000000000000000001241312722301655015741 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} module Internal.Sparse( GMatrix(..), CSR(..), mkCSR, fromCSR, mkSparse, mkDiagR, mkDense, AssocMatrix, toDense, gmXv, (!#>) )where import Internal.Vector import Internal.Matrix import Internal.Numeric import qualified Data.Vector.Storable as V import Data.Function(on) import Control.Arrow((***)) import Control.Monad(when) import Data.List(groupBy, sort) import Foreign.C.Types(CInt(..)) import Internal.Devel import System.IO.Unsafe(unsafePerformIO) import Foreign(Ptr) import Text.Printf(printf) infixl 0 ~!~ c ~!~ msg = when c (error msg) type AssocMatrix = [((Int,Int),Double)] data CSR = CSR { csrVals :: Vector Double , csrCols :: Vector CInt , csrRows :: Vector CInt , csrNRows :: Int , csrNCols :: Int } deriving Show data CSC = CSC { cscVals :: Vector Double , cscRows :: Vector CInt , cscCols :: Vector CInt , cscNRows :: Int , cscNCols :: Int } deriving Show mkCSR :: AssocMatrix -> CSR mkCSR sm' = CSR{..} where sm = sort sm' rws = map ((fromList *** fromList) . unzip . map ((succ.fi.snd) *** id) ) . groupBy ((==) `on` (fst.fst)) $ sm rszs = map (fi . dim . fst) rws csrRows = fromList (scanl (+) 1 rszs) csrVals = vjoin (map snd rws) csrCols = vjoin (map fst rws) csrNRows = dim csrRows - 1 csrNCols = fromIntegral (V.maximum csrCols) {- | General matrix with specialized internal representations for dense, sparse, diagonal, banded, and constant elements. >>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)] >>> m SparseR {gmCSR = CSR {csrVals = fromList [1.0,2.0], csrCols = fromList [1000,2000], csrRows = fromList [1,2,3], csrNRows = 2, csrNCols = 2000}, nRows = 2, nCols = 2000} >>> let m = mkDense (mat 2 [1..4]) >>> m Dense {gmDense = (2><2) [ 1.0, 2.0 , 3.0, 4.0 ], nRows = 2, nCols = 2} -} data GMatrix = SparseR { gmCSR :: CSR , nRows :: Int , nCols :: Int } | SparseC { gmCSC :: CSC , nRows :: Int , nCols :: Int } | Diag { diagVals :: Vector Double , nRows :: Int , nCols :: Int } | Dense { gmDense :: Matrix Double , nRows :: Int , nCols :: Int } -- | Banded deriving Show mkDense :: Matrix Double -> GMatrix mkDense m = Dense{..} where gmDense = m nRows = rows m nCols = cols m mkSparse :: AssocMatrix -> GMatrix mkSparse = fromCSR . mkCSR fromCSR :: CSR -> GMatrix fromCSR csr = SparseR {..} where gmCSR @ CSR {..} = csr nRows = csrNRows nCols = csrNCols mkDiagR r c v | dim v <= min r c = Diag{..} | otherwise = error $ printf "mkDiagR: incorrect sizes (%d,%d) [%d]" r c (dim v) where nRows = r nCols = c diagVals = v type IV t = CInt -> Ptr CInt -> t type V t = CInt -> Ptr Double -> t type SMxV = V (IV (IV (V (V (IO CInt))))) gmXv :: GMatrix -> Vector Double -> Vector Double gmXv SparseR { gmCSR = CSR{..}, .. } v = unsafePerformIO $ do dim v /= nCols ~!~ printf "gmXv (CSR): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) r <- createVector nRows c_smXv # csrVals # csrCols # csrRows # v # r #|"CSRXv" return r gmXv SparseC { gmCSC = CSC{..}, .. } v = unsafePerformIO $ do dim v /= nCols ~!~ printf "gmXv (CSC): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) r <- createVector nRows c_smTXv # cscVals # cscRows # cscCols # v # r #|"CSCXv" return r gmXv Diag{..} v | dim v == nCols = vjoin [ subVector 0 (dim diagVals) v `mul` diagVals , konst 0 (nRows - dim diagVals) ] | otherwise = error $ printf "gmXv (Diag): incorrect sizes: (%d,%d) [%d] x %d" nRows nCols (dim diagVals) (dim v) gmXv Dense{..} v | dim v == nCols = mXv gmDense v | otherwise = error $ printf "gmXv (Dense): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) {- | general matrix - vector product >>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)] >>> m !#> vector [1..2000] fromList [1000.0,4000.0] -} infixr 8 !#> (!#>) :: GMatrix -> Vector Double -> Vector Double (!#>) = gmXv -------------------------------------------------------------------------------- foreign import ccall unsafe "smXv" c_smXv :: SMxV foreign import ccall unsafe "smTXv" c_smTXv :: SMxV -------------------------------------------------------------------------------- toDense :: AssocMatrix -> Matrix Double toDense asm = assoc (r+1,c+1) 0 asm where (r,c) = (maximum *** maximum) . unzip . map fst $ asm instance Transposable CSR CSC where tr (CSR vs cs rs n m) = CSC vs cs rs m n tr' = tr instance Transposable CSC CSR where tr (CSC vs rs cs n m) = CSR vs rs cs m n tr' = tr instance Transposable GMatrix GMatrix where tr (SparseR s n m) = SparseC (tr s) m n tr (SparseC s n m) = SparseR (tr s) m n tr (Diag v n m) = Diag v m n tr (Dense a n m) = Dense (tr a) m n tr' = tr hmatrix-0.17.0.2/src/Internal/Conversion.hs0000644000000000000000000000542612722301655016637 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Conversion -- Copyright : (c) Alberto Ruiz 2010 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Conversion routines -- ----------------------------------------------------------------------------- module Internal.Conversion ( Complexable(..), RealElement, module Data.Complex ) where import Internal.Vector import Internal.Matrix import Internal.Vectorized import Data.Complex import Control.Arrow((***)) ------------------------------------------------------------------- -- | Supported single-double precision type pairs class (Element s, Element d) => Precision s d | s -> d, d -> s where double2FloatG :: Vector d -> Vector s float2DoubleG :: Vector s -> Vector d instance Precision Float Double where double2FloatG = double2FloatV float2DoubleG = float2DoubleV instance Precision (Complex Float) (Complex Double) where double2FloatG = asComplex . double2FloatV . asReal float2DoubleG = asComplex . float2DoubleV . asReal instance Precision I Z where double2FloatG = long2intV float2DoubleG = int2longV -- | Supported real types class (Element t, Element (Complex t), RealFloat t) => RealElement t instance RealElement Double instance RealElement Float -- | Structures that may contain complex numbers class Complexable c where toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e) fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e) comp' :: (RealElement e) => c e -> c (Complex e) single' :: Precision a b => c b -> c a double' :: Precision a b => c a -> c b instance Complexable Vector where toComplex' = toComplexV fromComplex' = fromComplexV comp' v = toComplex' (v,constantD 0 (dim v)) single' = double2FloatG double' = float2DoubleG -- | creates a complex vector from vectors with real and imaginary parts toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a) toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i] -- | the inverse of 'toComplex' fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a) fromComplexV z = (r,i) where [r,i] = toColumns $ reshape 2 $ asReal z instance Complexable Matrix where toComplex' = uncurry $ liftMatrix2 $ curry toComplex' fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z where c = cols z comp' = liftMatrix comp' single' = liftMatrix single' double' = liftMatrix double' hmatrix-0.17.0.2/src/Internal/Modular.hs0000644000000000000000000003563412722301655016121 0ustar0000000000000000{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {- | Module : Internal.Modular Copyright : (c) Alberto Ruiz 2015 License : BSD3 Stability : experimental Proof of concept of statically checked modular arithmetic. -} module Internal.Modular( Mod, type (./.) ) where import Internal.Vector import Internal.Matrix hiding (size) import Internal.Numeric import Internal.Element import Internal.Container import Internal.Vectorized (prodI,sumI,prodL,sumL) import Internal.LAPACK (multiplyI, multiplyL) import Internal.Algorithms(luFact,LU(..)) import Internal.Util(Normed(..),Indexable(..), gaussElim, gaussElim_1, gaussElim_2, luST, luSolve', luPacked', magnit, invershur) import Internal.ST(mutable) import GHC.TypeLits import Data.Proxy(Proxy) import Foreign.ForeignPtr(castForeignPtr) import Foreign.Storable import Data.Ratio import Data.Complex import Control.DeepSeq ( NFData(..) ) -- | Wrapper with a phantom integer for statically checked modular arithmetic. newtype Mod (n :: Nat) t = Mod {unMod:: t} deriving (Storable) instance (NFData t) => NFData (Mod n t) where rnf (Mod x) = rnf x infixr 5 ./. type (./.) x n = Mod n x instance (Integral t, Enum t, KnownNat m) => Enum (Mod m t) where toEnum = l0 (\m x -> fromIntegral $ x `mod` (fromIntegral m)) fromEnum = fromIntegral . unMod instance (Eq t, KnownNat m) => Eq (Mod m t) where a == b = (unMod a) == (unMod b) instance (Ord t, KnownNat m) => Ord (Mod m t) where compare a b = compare (unMod a) (unMod b) instance (Integral t, KnownNat m, Integral (Mod m t)) => Real (Mod m t) where toRational x = toInteger x % 1 instance (Integral t, KnownNat m, Num (Mod m t)) => Integral (Mod m t) where toInteger = toInteger . unMod quotRem a b = (Mod q, Mod r) where (q,r) = quotRem (unMod a) (unMod b) -- | this instance is only valid for prime m instance (Show (Mod m t), Num (Mod m t), Eq t, KnownNat m) => Fractional (Mod m t) where recip x | x*r == 1 = r | otherwise = error $ show x ++" does not have a multiplicative inverse mod "++show m' where r = x^(m'-2 :: Integer) m' = fromIntegral . natVal $ (undefined :: Proxy m) fromRational x = fromInteger (numerator x) / fromInteger (denominator x) l2 :: forall m a b c. (Num c, KnownNat m) => (c -> a -> b -> c) -> Mod m a -> Mod m b -> Mod m c l2 f (Mod u) (Mod v) = Mod (f m' u v) where m' = fromIntegral . natVal $ (undefined :: Proxy m) l1 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> Mod m a -> Mod m b l1 f (Mod u) = Mod (f m' u) where m' = fromIntegral . natVal $ (undefined :: Proxy m) l0 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> a -> Mod m b l0 f u = Mod (f m' u) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance Show t => Show (Mod n t) where show = show . unMod instance forall n t . (Integral t, KnownNat n) => Num (Mod n t) where (+) = l2 (\m a b -> (a + b) `mod` (fromIntegral m)) (*) = l2 (\m a b -> (a * b) `mod` (fromIntegral m)) (-) = l2 (\m a b -> (a - b) `mod` (fromIntegral m)) abs = l1 (const abs) signum = l1 (const signum) fromInteger = l0 (\m x -> fromInteger x `mod` (fromIntegral m)) instance KnownNat m => Element (Mod m I) where constantD x n = i2f (constantD (unMod x) n) extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js setRect i j m x = setRect i j (f2iM m) (f2iM x) sortI = sortI . f2i sortV = i2f . sortV . f2i compareV u v = compareV (f2i u) (f2i v) selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g)) remapM i j m = i2fM (remap i j (f2iM m)) rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpMI m') c (unMod a) i1 i2 j1 j2 (f2iM x) where m' = fromIntegral . natVal $ (undefined :: Proxy m) gemm u a b c = gemmg (c_gemmMI m') (f2i u) (f2iM a) (f2iM b) (f2iM c) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Element (Mod m Z) where constantD x n = i2f (constantD (unMod x) n) extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js setRect i j m x = setRect i j (f2iM m) (f2iM x) sortI = sortI . f2i sortV = i2f . sortV . f2i compareV u v = compareV (f2i u) (f2i v) selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g)) remapM i j m = i2fM (remap i j (f2iM m)) rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpML m') c (unMod a) i1 i2 j1 j2 (f2iM x) where m' = fromIntegral . natVal $ (undefined :: Proxy m) gemm u a b c = gemmg (c_gemmML m') (f2i u) (f2iM a) (f2iM b) (f2iM c) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance forall m . KnownNat m => CTrans (Mod m I) instance forall m . KnownNat m => CTrans (Mod m Z) instance forall m . KnownNat m => Container Vector (Mod m I) where conj' = id size' = dim scale' s x = vmod (scale (unMod s) (f2i x)) addConstant c x = vmod (addConstant (unMod c) (f2i x)) add' a b = vmod (add' (f2i a) (f2i b)) sub a b = vmod (sub (f2i a) (f2i b)) mul a b = vmod (mul (f2i a) (f2i b)) equal u v = equal (f2i u) (f2i v) scalar' x = fromList [x] konst' x = i2f . konst (unMod x) build' n f = build n (fromIntegral . f) cmap' = mapVector atIndex' x k = fromIntegral (atIndex (f2i x) k) minIndex' = minIndex . f2i maxIndex' = maxIndex . f2i minElement' = Mod . minElement . f2i maxElement' = Mod . maxElement . f2i sumElements' = fromIntegral . sumI m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) prodElements' = fromIntegral . prodI m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) step' = i2f . step . f2i find' = findV assoc' = assocV accum' = accumV ccompare' a b = ccompare (f2i a) (f2i b) cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g) scaleRecip s x = scale' s (cmap recip x) divide x y = mul x (cmap recip y) arctan2' = undefined cmod' m = vmod . cmod' (unMod m) . f2i fromInt' = vmod toInt' = f2i fromZ' = vmod . fromZ' toZ' = toZ' . f2i instance forall m . KnownNat m => Container Vector (Mod m Z) where conj' = id size' = dim scale' s x = vmod (scale (unMod s) (f2i x)) addConstant c x = vmod (addConstant (unMod c) (f2i x)) add' a b = vmod (add' (f2i a) (f2i b)) sub a b = vmod (sub (f2i a) (f2i b)) mul a b = vmod (mul (f2i a) (f2i b)) equal u v = equal (f2i u) (f2i v) scalar' x = fromList [x] konst' x = i2f . konst (unMod x) build' n f = build n (fromIntegral . f) cmap' = mapVector atIndex' x k = fromIntegral (atIndex (f2i x) k) minIndex' = minIndex . f2i maxIndex' = maxIndex . f2i minElement' = Mod . minElement . f2i maxElement' = Mod . maxElement . f2i sumElements' = fromIntegral . sumL m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) prodElements' = fromIntegral . prodL m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) step' = i2f . step . f2i find' = findV assoc' = assocV accum' = accumV ccompare' a b = ccompare (f2i a) (f2i b) cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g) scaleRecip s x = scale' s (cmap recip x) divide x y = mul x (cmap recip y) arctan2' = undefined cmod' m = vmod . cmod' (unMod m) . f2i fromInt' = vmod . fromInt' toInt' = toInt . f2i fromZ' = vmod toZ' = f2i instance (Storable t, Indexable (Vector t) t) => Indexable (Vector (Mod m t)) (Mod m t) where (!) = (@>) type instance RealOf (Mod n I) = I type instance RealOf (Mod n Z) = Z instance KnownNat m => Product (Mod m I) where norm2 = undefined absSum = undefined norm1 = undefined normInf = undefined multiply = lift2m (multiplyI m') where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Product (Mod m Z) where norm2 = undefined absSum = undefined norm1 = undefined normInf = undefined multiply = lift2m (multiplyL m') where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Normed (Vector (Mod m I)) where norm_0 = norm_0 . toInt norm_1 = norm_1 . toInt norm_2 = norm_2 . toInt norm_Inf = norm_Inf . toInt instance KnownNat m => Normed (Vector (Mod m Z)) where norm_0 = norm_0 . toZ norm_1 = norm_1 . toZ norm_2 = norm_2 . toZ norm_Inf = norm_Inf . toZ instance KnownNat m => Numeric (Mod m I) instance KnownNat m => Numeric (Mod m Z) i2f :: Storable t => Vector t -> Vector (Mod n t) i2f v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n) where (fp,i,n) = unsafeToForeignPtr v f2i :: Storable t => Vector (Mod n t) -> Vector t f2i v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n) where (fp,i,n) = unsafeToForeignPtr v f2iM :: (Element t, Element (Mod n t)) => Matrix (Mod n t) -> Matrix t f2iM m = m { xdat = f2i (xdat m) } i2fM :: (Element t, Element (Mod n t)) => Matrix t -> Matrix (Mod n t) i2fM m = m { xdat = i2f (xdat m) } vmod :: forall m t. (KnownNat m, Storable t, Integral t, Numeric t) => Vector t -> Vector (Mod m t) vmod = i2f . cmod' m' where m' = fromIntegral . natVal $ (undefined :: Proxy m) lift1 f a = vmod (f (f2i a)) lift2 f a b = vmod (f (f2i a) (f2i b)) lift2m f a b = liftMatrix vmod (f (f2iM a) (f2iM b)) instance forall m . KnownNat m => Num (Vector (Mod m I)) where (+) = lift2 (+) (*) = lift2 (*) (-) = lift2 (-) abs = lift1 abs signum = lift1 signum negate = lift1 negate fromInteger x = fromInt (fromInteger x) instance forall m . KnownNat m => Num (Vector (Mod m Z)) where (+) = lift2 (+) (*) = lift2 (*) (-) = lift2 (-) abs = lift1 abs signum = lift1 signum negate = lift1 negate fromInteger x = fromZ (fromInteger x) -------------------------------------------------------------------------------- instance (KnownNat m) => Testable (Matrix (Mod m I)) where checkT _ = test test = (ok, info) where v = fromList [3,-5,75] :: Vector (Mod 11 I) m = (3><3) [1..] :: Matrix (Mod 11 I) a = (3><3) [1,2 , 3 ,4,5 , 6 ,0,10,-3] :: Matrix I b = (3><2) [0..] :: Matrix I am = fromInt a :: Matrix (Mod 13 I) bm = fromInt b :: Matrix (Mod 13 I) ad = fromInt a :: Matrix Double bd = fromInt b :: Matrix Double g = (3><3) (repeat (40000)) :: Matrix I gm = fromInt g :: Matrix (Mod 100000 I) lg = (3><3) (repeat (3*10^(9::Int))) :: Matrix Z lgm = fromZ lg :: Matrix (Mod 10000000000 Z) gen n = diagRect 1 (konst 5 n) n n :: Numeric t => Matrix t rgen n = gen n :: Matrix R cgen n = complex (rgen n) + fliprl (complex (rgen n)) * scalar (0:+1) :: Matrix C sgen n = single (cgen n) checkGen x = norm_Inf $ flatten $ invg x <> x - ident (rows x) invg t = gaussElim t (ident (rows t)) checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) where (l,u,p,_) = luFact (LU x' p') where (x',p') = mutable (luST okf) t checkSolve aa = norm_Inf $ flatten (aa <> x - bb) where bb = flipud aa x = luSolve' (luPacked' aa) bb tmm = diagRect 1 (fromList [2..6]) 5 5 :: Matrix (Mod 19 I) info = do print v print m print (tr m) print $ v+v print $ m+m print $ m <> m print $ m #> v print $ am <> gaussElim am bm - bm print $ ad <> gaussElim ad bd - bd print g print $ g <> g print gm print $ gm <> gm print lg print $ lg <> lg print lgm print $ lgm <> lgm putStrLn "checkGen" print (checkGen (gen 5 :: Matrix R)) print (checkGen (gen 5 :: Matrix Float)) print (checkGen (cgen 5 :: Matrix C)) print (checkGen (sgen 5 :: Matrix (Complex Float))) print (invg (gen 5) :: Matrix (Mod 7 I)) print (invg (gen 5) :: Matrix (Mod 7 Z)) print $ mutable (luST (const True)) (gen 5 :: Matrix R) print $ mutable (luST (const True)) (gen 5 :: Matrix (Mod 11 Z)) putStrLn "checkLU" print $ checkLU (magnit 0) (gen 5 :: Matrix R) print $ checkLU (magnit 0) (gen 5 :: Matrix Float) print $ checkLU (magnit 0) (cgen 5 :: Matrix C) print $ checkLU (magnit 0) (sgen 5 :: Matrix (Complex Float)) print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I)) print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z)) putStrLn "checkSolve" print $ checkSolve (gen 5 :: Matrix R) print $ checkSolve (gen 5 :: Matrix Float) print $ checkSolve (cgen 5 :: Matrix C) print $ checkSolve (sgen 5 :: Matrix (Complex Float)) print $ checkSolve (gen 5 :: Matrix (Mod 7 I)) print $ checkSolve (gen 5 :: Matrix (Mod 7 Z)) putStrLn "luSolve'" print $ luSolve' (luPacked' tmm) (ident (rows tmm)) print $ invershur tmm ok = and [ toInt (m #> v) == cmod 11 (toInt m #> toInt v ) , am <> gaussElim_1 am bm == bm , am <> gaussElim_2 am bm == bm , am <> gaussElim am bm == bm , (checkGen (gen 5 :: Matrix R)) < 1E-15 , (checkGen (gen 5 :: Matrix Float)) < 2E-7 , (checkGen (cgen 5 :: Matrix C)) < 1E-15 , (checkGen (sgen 5 :: Matrix (Complex Float))) < 3E-7 , (checkGen (gen 5 :: Matrix (Mod 7 I))) == 0 , (checkGen (gen 5 :: Matrix (Mod 7 Z))) == 0 , (checkLU (magnit 1E-10) (gen 5 :: Matrix R)) < 2E-15 , (checkLU (magnit 1E-5) (gen 5 :: Matrix Float)) < 1E-6 , (checkLU (magnit 1E-10) (cgen 5 :: Matrix C)) < 5E-15 , (checkLU (magnit 1E-5) (sgen 5 :: Matrix (Complex Float))) < 1E-6 , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))) == 0 , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))) == 0 , checkSolve (gen 5 :: Matrix R) < 2E-15 , checkSolve (gen 5 :: Matrix Float) < 1E-6 , checkSolve (cgen 5 :: Matrix C) < 4E-15 , checkSolve (sgen 5 :: Matrix (Complex Float)) < 1E-6 , checkSolve (gen 5 :: Matrix (Mod 7 I)) == 0 , checkSolve (gen 5 :: Matrix (Mod 7 Z)) == 0 , prodElements (konst (9:: Mod 10 I) (12::Int)) == product (replicate 12 (9:: Mod 10 I)) , gm <> gm == konst 0 (3,3) , lgm <> lgm == konst 0 (3,3) , invershur tmm == luSolve' (luPacked' tmm) (ident (rows tmm)) , luSolve' (luPacked' (tr $ ident 5 :: Matrix (I ./. 2))) (ident 5) == ident 5 ] hmatrix-0.17.0.2/src/Internal/LAPACK.hs0000644000000000000000000006252212722301655015445 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.LinearAlgebra.LAPACK -- Copyright : (c) Alberto Ruiz 2006-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Functional interface to selected LAPACK functions (). -- ----------------------------------------------------------------------------- module Internal.LAPACK where import Internal.Devel import Internal.Vector import Internal.Matrix hiding ((#)) import Internal.Conversion import Internal.Element import Foreign.Ptr(nullPtr) import Foreign.C.Types import Control.Monad(when) import System.IO.Unsafe(unsafePerformIO) ----------------------------------------------------------------------------------- infixl 1 # a # b = apply a b {-# INLINE (#) #-} ----------------------------------------------------------------------------------- type TMMM t = t ::> t ::> t ::> Ok type F = Float type Q = Complex Float foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM R foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TMMM C foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TMMM F foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TMMM Q foreign import ccall unsafe "multiplyI" c_multiplyI :: I -> TMMM I foreign import ccall unsafe "multiplyL" c_multiplyL :: Z -> TMMM Z isT (rowOrder -> False) = 0 isT _ = 1 tt x@(rowOrder -> False) = x tt x = trans x multiplyAux f st a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ show (rows a,cols a) ++ " x " ++ show (rows b, cols b) s <- createMatrix ColumnMajor (rows a) (cols b) f (isT a) (isT b) # (tt a) # (tt b) # s #| st return s -- | Matrix product based on BLAS's /dgemm/. multiplyR :: Matrix Double -> Matrix Double -> Matrix Double multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b -- | Matrix product based on BLAS's /zgemm/. multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) multiplyC a b = multiplyAux zgemmc "zgemmc" a b -- | Matrix product based on BLAS's /sgemm/. multiplyF :: Matrix Float -> Matrix Float -> Matrix Float multiplyF a b = multiplyAux sgemmc "sgemmc" a b -- | Matrix product based on BLAS's /cgemm/. multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float) multiplyQ a b = multiplyAux cgemmc "cgemmc" a b multiplyI :: I -> Matrix CInt -> Matrix CInt -> Matrix CInt multiplyI m a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b s <- createMatrix ColumnMajor (rows a) (cols b) c_multiplyI m # a # b # s #|"c_multiplyI" return s multiplyL :: Z -> Matrix Z -> Matrix Z -> Matrix Z multiplyL m a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b s <- createMatrix ColumnMajor (rows a) (cols b) c_multiplyL m # a # b # s #|"c_multiplyL" return s ----------------------------------------------------------------------------- type TSVD t = t ::> t ::> R :> t ::> Ok foreign import ccall unsafe "svd_l_R" dgesvd :: TSVD R foreign import ccall unsafe "svd_l_C" zgesvd :: TSVD C foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TSVD R foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TSVD C -- | Full SVD of a real matrix using LAPACK's /dgesvd/. svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdR = svdAux dgesvd "svdR" -- | Full SVD of a real matrix using LAPACK's /dgesdd/. svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdRd = svdAux dgesdd "svdRdd" -- | Full SVD of a complex matrix using LAPACK's /zgesvd/. svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdC = svdAux zgesvd "svdC" -- | Full SVD of a complex matrix using LAPACK's /zgesdd/. svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdCd = svdAux zgesdd "svdCdd" svdAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r r s <- createVector (min r c) v <- createMatrix ColumnMajor c c f # a # u # s # v #| st return (u,s,v) where r = rows x c = cols x -- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'. thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDR = thinSVDAux dgesvd "thinSVDR" -- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'. thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDC = thinSVDAux zgesvd "thinSVDC" -- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'. thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDRd = thinSVDAux dgesdd "thinSVDRdd" -- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'. thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDCd = thinSVDAux zgesdd "thinSVDCdd" thinSVDAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r q s <- createVector q v <- createMatrix ColumnMajor q c f # a # u # s # v #| st return (u,s,v) where r = rows x c = cols x q = min r c -- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'. svR :: Matrix Double -> Vector Double svR = svAux dgesvd "svR" -- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'. svC :: Matrix (Complex Double) -> Vector Double svC = svAux zgesvd "svC" -- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'. svRd :: Matrix Double -> Vector Double svRd = svAux dgesdd "svRd" -- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'. svCd :: Matrix (Complex Double) -> Vector Double svCd = svAux zgesdd "svCd" svAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x s <- createVector q g # a # s #| st return s where r = rows x c = cols x q = min r c g ra ca xra xca pa nb pb = f ra ca xra xca pa 0 0 0 0 nullPtr nb pb 0 0 0 0 nullPtr -- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVR :: Matrix Double -> (Vector Double, Matrix Double) rightSVR = rightSVAux dgesvd "rightSVR" -- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) rightSVC = rightSVAux zgesvd "rightSVC" rightSVAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x s <- createVector q v <- createMatrix ColumnMajor c c g # a # s # v #| st return (s,v) where r = rows x c = cols x q = min r c g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr -- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVR :: Matrix Double -> (Matrix Double, Vector Double) leftSVR = leftSVAux dgesvd "leftSVR" -- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double) leftSVC = leftSVAux zgesvd "leftSVC" leftSVAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r r s <- createVector q g # a # u # s #| st return (u,s) where r = rows x c = cols x q = min r c g ra ca xra xca pa ru cu xru xcu pu nb pb = f ra ca xra xca pa ru cu xru xcu pu nb pb 0 0 0 0 nullPtr ----------------------------------------------------------------------------- foreign import ccall unsafe "eig_l_R" dgeev :: R ::> R ::> C :> R ::> Ok foreign import ccall unsafe "eig_l_C" zgeev :: C ::> C ::> C :> C ::> Ok foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> R :> R ::> Ok foreign import ccall unsafe "eig_l_H" zheev :: CInt -> R :> C ::> Ok eigAux f st m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r v <- createMatrix ColumnMajor r r g # a # l # v #| st return (l,v) where r = rows m g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr -- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) eigC = eigAux zgeev "eigC" eigOnlyAux f st m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r g # a # l #| st return l where r = rows m g ra ca xra xca pa nl pl = f ra ca xra xca pa 0 0 0 0 nullPtr nl pl 0 0 0 0 nullPtr -- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double) eigOnlyC = eigOnlyAux zgeev "eigOnlyC" -- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) eigR m = (s', v'') where (s,v) = eigRaux m s' = fixeig1 s v' = toRows $ trans v v'' = fromColumns $ fixeig (toList s') v' eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) eigRaux m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r v <- createMatrix ColumnMajor r r g # a # l # v #| "eigR" return (l,v) where r = rows m g ra ca xra xca pa = dgeev ra ca xra xca pa 0 0 0 0 nullPtr fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s)) where r = dim s fixeig [] _ = [] fixeig [_] [v] = [comp' v] fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs) | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1, mapVector negate v2) : fixeig r vs | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs) fixeig _ _ = error "fixeig with impossible inputs" -- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyR :: Matrix Double -> Vector (Complex Double) eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR" ----------------------------------------------------------------------------- eigSHAux f st m = unsafePerformIO $ do l <- createVector r v <- copy ColumnMajor m f # l # v #| st return (l,v) where r = rows m -- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order). eigS :: Matrix Double -> (Vector Double, Matrix Double) eigS m = (s', fliprl v) where (s,v) = eigS' m s' = fromList . reverse . toList $ s -- | 'eigS' in ascending order eigS' :: Matrix Double -> (Vector Double, Matrix Double) eigS' = eigSHAux (dsyev 1) "eigS'" -- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order). eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH m = (s', fliprl v) where (s,v) = eigH' m s' = fromList . reverse . toList $ s -- | 'eigH' in ascending order eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH' = eigSHAux (zheev 1) "eigH'" -- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyS :: Matrix Double -> Vector Double eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'" -- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyH :: Matrix (Complex Double) -> Vector Double eigOnlyH = vrev . fst. eigSHAux (zheev 0) "eigH'" vrev = flatten . flipud . reshape 1 ----------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveR_l" dgesv :: R ::> R ::> Ok foreign import ccall unsafe "linearSolveC_l" zgesv :: C ::> C ::> Ok linearSolveSQAux g f st a b | n1==n2 && n1==r = unsafePerformIO . g $ do a' <- copy ColumnMajor a s <- copy ColumnMajor b f # a' # s #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b -- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'. linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveR a b = linearSolveSQAux id dgesv "linearSolveR" a b mbLinearSolveR :: Matrix Double -> Matrix Double -> Maybe (Matrix Double) mbLinearSolveR a b = linearSolveSQAux mbCatch dgesv "linearSolveR" a b -- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'. linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveC a b = linearSolveSQAux id zgesv "linearSolveC" a b mbLinearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Maybe (Matrix (Complex Double)) mbLinearSolveC a b = linearSolveSQAux mbCatch zgesv "linearSolveC" a b -------------------------------------------------------------------------------- foreign import ccall unsafe "cholSolveR_l" dpotrs :: R ::> R ::> Ok foreign import ccall unsafe "cholSolveC_l" zpotrs :: C ::> C ::> Ok linearSolveSQAux2 g f st a b | n1==n2 && n1==r = unsafePerformIO . g $ do s <- copy ColumnMajor b f # a # s #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b -- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'. cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double cholSolveR a b = linearSolveSQAux2 id dpotrs "cholSolveR" (fmat a) b -- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'. cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b ----------------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok foreign import ccall unsafe "linearSolveLSC_l" zgels :: C ::> C ::> Ok foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> R ::> R ::> Ok foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> C ::> C ::> Ok linearSolveAux f st a b | m == rows b = unsafePerformIO $ do a' <- copy ColumnMajor a r <- createMatrix ColumnMajor (max m n) nrhs setRect 0 0 b r f # a' # r #| st return r | otherwise = error $ "different number of rows in linearSolve ("++st++")" where m = rows a n = cols a nrhs = cols b -- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'. linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux dgels "linearSolverLSR" a b -- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'. linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux zgels "linearSolveLSC" a b -- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDR :: Maybe Double -- ^ rcond -> Matrix Double -- ^ coefficient matrix -> Matrix Double -- ^ right hand sides (as columns) -> Matrix Double -- ^ solution vectors (as columns) linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (dgelss rcond) "linearSolveSVDR" a b linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b -- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDC :: Maybe Double -- ^ rcond -> Matrix (Complex Double) -- ^ coefficient matrix -> Matrix (Complex Double) -- ^ right hand sides (as columns) -> Matrix (Complex Double) -- ^ solution vectors (as columns) linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (zgelss rcond) "linearSolveSVDC" a b linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b ----------------------------------------------------------------------------------- foreign import ccall unsafe "chol_l_H" zpotrf :: C ::> Ok foreign import ccall unsafe "chol_l_S" dpotrf :: R ::> Ok cholAux f st a = do r <- copy ColumnMajor a f # r #| st return r -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/. cholH :: Matrix (Complex Double) -> Matrix (Complex Double) cholH = unsafePerformIO . cholAux zpotrf "cholH" -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/. cholS :: Matrix Double -> Matrix Double cholS = unsafePerformIO . cholAux dpotrf "cholS" -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version). mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double)) mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH" -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version). mbCholS :: Matrix Double -> Maybe (Matrix Double) mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS" ----------------------------------------------------------------------------------- type TMVM t = t ::> t :> t ::> Ok foreign import ccall unsafe "qr_l_R" dgeqr2 :: R :> R ::> Ok foreign import ccall unsafe "qr_l_C" zgeqr2 :: C :> C ::> Ok -- | QR factorization of a real matrix, using LAPACK's /dgeqr2/. qrR :: Matrix Double -> (Matrix Double, Vector Double) qrR = qrAux dgeqr2 "qrR" -- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/. qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) qrC = qrAux zgeqr2 "qrC" qrAux f st a = unsafePerformIO $ do r <- copy ColumnMajor a tau <- createVector mn f # tau # r #| st return (r,tau) where m = rows a n = cols a mn = min m n foreign import ccall unsafe "c_dorgqr" dorgqr :: R :> R ::> Ok foreign import ccall unsafe "c_zungqr" zungqr :: C :> C ::> Ok -- | build rotation from reflectors qrgrR :: Int -> (Matrix Double, Vector Double) -> Matrix Double qrgrR = qrgrAux dorgqr "qrgrR" -- | build rotation from reflectors qrgrC :: Int -> (Matrix (Complex Double), Vector (Complex Double)) -> Matrix (Complex Double) qrgrC = qrgrAux zungqr "qrgrC" qrgrAux f st n (a, tau) = unsafePerformIO $ do res <- copy ColumnMajor (subMatrix (0,0) (rows a,n) a) f # (subVector 0 n tau') # res #| st return res where tau' = vjoin [tau, constantD 0 n] ----------------------------------------------------------------------------------- foreign import ccall unsafe "hess_l_R" dgehrd :: R :> R ::> Ok foreign import ccall unsafe "hess_l_C" zgehrd :: C :> C ::> Ok -- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/. hessR :: Matrix Double -> (Matrix Double, Vector Double) hessR = hessAux dgehrd "hessR" -- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/. hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) hessC = hessAux zgehrd "hessC" hessAux f st a = unsafePerformIO $ do r <- copy ColumnMajor a tau <- createVector (mn-1) f # tau # r #| st return (r,tau) where m = rows a n = cols a mn = min m n ----------------------------------------------------------------------------------- foreign import ccall unsafe "schur_l_R" dgees :: R ::> R ::> Ok foreign import ccall unsafe "schur_l_C" zgees :: C ::> C ::> Ok -- | Schur factorization of a square real matrix, using LAPACK's /dgees/. schurR :: Matrix Double -> (Matrix Double, Matrix Double) schurR = schurAux dgees "schurR" -- | Schur factorization of a square complex matrix, using LAPACK's /zgees/. schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) schurC = schurAux zgees "schurC" schurAux f st a = unsafePerformIO $ do u <- createMatrix ColumnMajor n n s <- copy ColumnMajor a f # u # s #| st return (u,s) where n = rows a ----------------------------------------------------------------------------------- foreign import ccall unsafe "lu_l_R" dgetrf :: R :> R ::> Ok foreign import ccall unsafe "lu_l_C" zgetrf :: R :> C ::> Ok -- | LU factorization of a general real matrix, using LAPACK's /dgetrf/. luR :: Matrix Double -> (Matrix Double, [Int]) luR = luAux dgetrf "luR" -- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/. luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int]) luC = luAux zgetrf "luC" luAux f st a = unsafePerformIO $ do lu <- copy ColumnMajor a piv <- createVector (min n m) f # piv # lu #| st return (lu, map (pred.round) (toList piv)) where n = rows a m = cols a ----------------------------------------------------------------------------------- foreign import ccall unsafe "luS_l_R" dgetrs :: R ::> R :> R ::> Ok foreign import ccall unsafe "luS_l_C" zgetrs :: C ::> R :> C ::> Ok -- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/. lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv b -- | Solve a complex linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/. lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double) lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv b lusAux f st a piv b | n1==n2 && n2==n =unsafePerformIO $ do x <- copy ColumnMajor b f # a # piv' # x #| st return x | otherwise = error st where n1 = rows a n2 = cols a n = rows b piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double ----------------------------------------------------------------------------------- foreign import ccall unsafe "ldl_R" dsytrf :: R :> R ::> Ok foreign import ccall unsafe "ldl_C" zhetrf :: R :> C ::> Ok -- | LDL factorization of a symmetric real matrix, using LAPACK's /dsytrf/. ldlR :: Matrix Double -> (Matrix Double, [Int]) ldlR = ldlAux dsytrf "ldlR" -- | LDL factorization of a hermitian complex matrix, using LAPACK's /zhetrf/. ldlC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int]) ldlC = ldlAux zhetrf "ldlC" ldlAux f st a = unsafePerformIO $ do ldl <- copy ColumnMajor a piv <- createVector (rows a) f # piv # ldl #| st return (ldl, map (pred.round) (toList piv)) ----------------------------------------------------------------------------------- foreign import ccall unsafe "ldl_S_R" dsytrs :: R ::> R :> R ::> Ok foreign import ccall unsafe "ldl_S_C" zsytrs :: C ::> R :> C ::> Ok -- | Solve a real linear system from a precomputed LDL decomposition ('ldlR'), using LAPACK's /dsytrs/. ldlsR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double ldlsR a piv b = lusAux dsytrs "ldlsR" (fmat a) piv b -- | Solve a complex linear system from a precomputed LDL decomposition ('ldlC'), using LAPACK's /zsytrs/. ldlsC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double) ldlsC a piv b = lusAux zsytrs "ldlsC" (fmat a) piv b hmatrix-0.17.0.2/src/Internal/Random.hs0000644000000000000000000000445112722301655015727 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.LinearAlgebra.Random -- Copyright : (c) Alberto Ruiz 2009-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Random vectors and matrices. -- ----------------------------------------------------------------------------- module Internal.Random ( Seed, RandDist(..), randomVector, gaussianSample, uniformSample, rand, randn ) where import Internal.Vectorized import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Algorithms import System.Random(randomIO) -- | Obtains a matrix whose rows are pseudorandom samples from a multivariate -- Gaussian distribution. gaussianSample :: Seed -> Int -- ^ number of rows -> Vector Double -- ^ mean vector -> Matrix Double -- ^ covariance matrix -> Matrix Double -- ^ result gaussianSample seed n med cov = m where c = dim med meds = konst' 1 n `outer` med rs = reshape c $ randomVector seed Gaussian (c * n) m = rs `mXm` cholSH cov `add` meds -- | Obtains a matrix whose rows are pseudorandom samples from a multivariate -- uniform distribution. uniformSample :: Seed -> Int -- ^ number of rows -> [(Double,Double)] -- ^ ranges for each column -> Matrix Double -- ^ result uniformSample seed n rgs = m where (as,bs) = unzip rgs a = fromList as cs = zipWith subtract as bs d = dim a dat = toRows $ reshape n $ randomVector seed Uniform (n*d) am = konst' 1 n `outer` a m = fromColumns (zipWith scale cs dat) `add` am -- | pseudorandom matrix with uniform elements between 0 and 1 randm :: RandDist -> Int -- ^ rows -> Int -- ^ columns -> IO (Matrix Double) randm d r c = do seed <- randomIO return (reshape c $ randomVector seed d (r*c)) -- | pseudorandom matrix with uniform elements between 0 and 1 rand :: Int -> Int -> IO (Matrix Double) rand = randm Uniform {- | pseudorandom matrix with normal elements >>> disp 3 =<< randn 3 5 3x5 0.386 -1.141 0.491 -0.510 1.512 0.069 -0.919 1.022 -0.181 0.745 0.313 -0.670 -0.097 -1.575 -0.583 -} randn :: Int -> Int -> IO (Matrix Double) randn = randm Gaussian hmatrix-0.17.0.2/src/Internal/Vectorized.hs0000644000000000000000000004036012722301655016624 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vectorized -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Low level interface to vector operations. -- ----------------------------------------------------------------------------- module Internal.Vectorized where import Internal.Vector import Internal.Devel import Data.Complex import Foreign.Marshal.Alloc(free,malloc) import Foreign.Marshal.Array(newArray,copyArray) import Foreign.Ptr(Ptr) import Foreign.Storable(peek,Storable) import Foreign.C.Types import Foreign.C.String import System.IO.Unsafe(unsafePerformIO) import Control.Monad(when) infixl 1 # a # b = applyRaw a b {-# INLINE (#) #-} fromei x = fromIntegral (fromEnum x) :: CInt data FunCodeV = Sin | Cos | Tan | Abs | ASin | ACos | ATan | Sinh | Cosh | Tanh | ASinh | ACosh | ATanh | Exp | Log | Sign | Sqrt deriving Enum data FunCodeSV = Scale | Recip | AddConstant | Negate | PowSV | PowVS | ModSV | ModVS deriving Enum data FunCodeVV = Add | Sub | Mul | Div | Pow | ATan2 | Mod deriving Enum data FunCodeS = Norm2 | AbsSum | MaxIdx | Max | MinIdx | Min deriving Enum ------------------------------------------------------------------ -- | sum of elements sumF :: Vector Float -> Float sumF = sumg c_sumF -- | sum of elements sumR :: Vector Double -> Double sumR = sumg c_sumR -- | sum of elements sumQ :: Vector (Complex Float) -> Complex Float sumQ = sumg c_sumQ -- | sum of elements sumC :: Vector (Complex Double) -> Complex Double sumC = sumg c_sumC sumI m = sumg (c_sumI m) sumL m = sumg (c_sumL m) sumg f x = unsafePerformIO $ do r <- createVector 1 f # x # r #| "sum" return $ r @> 0 type TVV t = t :> t :> Ok foreign import ccall unsafe "sumF" c_sumF :: TVV Float foreign import ccall unsafe "sumR" c_sumR :: TVV Double foreign import ccall unsafe "sumQ" c_sumQ :: TVV (Complex Float) foreign import ccall unsafe "sumC" c_sumC :: TVV (Complex Double) foreign import ccall unsafe "sumI" c_sumI :: I -> TVV I foreign import ccall unsafe "sumL" c_sumL :: Z -> TVV Z -- | product of elements prodF :: Vector Float -> Float prodF = prodg c_prodF -- | product of elements prodR :: Vector Double -> Double prodR = prodg c_prodR -- | product of elements prodQ :: Vector (Complex Float) -> Complex Float prodQ = prodg c_prodQ -- | product of elements prodC :: Vector (Complex Double) -> Complex Double prodC = prodg c_prodC prodI :: I-> Vector I -> I prodI = prodg . c_prodI prodL :: Z-> Vector Z -> Z prodL = prodg . c_prodL prodg f x = unsafePerformIO $ do r <- createVector 1 f # x # r #| "prod" return $ r @> 0 foreign import ccall unsafe "prodF" c_prodF :: TVV Float foreign import ccall unsafe "prodR" c_prodR :: TVV Double foreign import ccall unsafe "prodQ" c_prodQ :: TVV (Complex Float) foreign import ccall unsafe "prodC" c_prodC :: TVV (Complex Double) foreign import ccall unsafe "prodI" c_prodI :: I -> TVV I foreign import ccall unsafe "prodL" c_prodL :: Z -> TVV Z ------------------------------------------------------------------ toScalarAux fun code v = unsafePerformIO $ do r <- createVector 1 fun (fromei code) # v # r #|"toScalarAux" return (r @> 0) vectorMapAux fun code v = unsafePerformIO $ do r <- createVector (dim v) fun (fromei code) # v # r #|"vectorMapAux" return r vectorMapValAux fun code val v = unsafePerformIO $ do r <- createVector (dim v) pval <- newArray [val] fun (fromei code) pval # v # r #|"vectorMapValAux" free pval return r vectorZipAux fun code u v = unsafePerformIO $ do r <- createVector (dim u) fun (fromei code) # u # v # r #|"vectorZipAux" return r --------------------------------------------------------------------- -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarR :: FunCodeS -> Vector Double -> Double toScalarR oper = toScalarAux c_toScalarR (fromei oper) foreign import ccall unsafe "toScalarR" c_toScalarR :: CInt -> TVV Double -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarF :: FunCodeS -> Vector Float -> Float toScalarF oper = toScalarAux c_toScalarF (fromei oper) foreign import ccall unsafe "toScalarF" c_toScalarF :: CInt -> TVV Float -- | obtains different functions of a vector: only norm1, norm2 toScalarC :: FunCodeS -> Vector (Complex Double) -> Double toScalarC oper = toScalarAux c_toScalarC (fromei oper) foreign import ccall unsafe "toScalarC" c_toScalarC :: CInt -> Complex Double :> Double :> Ok -- | obtains different functions of a vector: only norm1, norm2 toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float toScalarQ oper = toScalarAux c_toScalarQ (fromei oper) foreign import ccall unsafe "toScalarQ" c_toScalarQ :: CInt -> Complex Float :> Float :> Ok -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarI :: FunCodeS -> Vector CInt -> CInt toScalarI oper = toScalarAux c_toScalarI (fromei oper) foreign import ccall unsafe "toScalarI" c_toScalarI :: CInt -> TVV CInt -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarL :: FunCodeS -> Vector Z -> Z toScalarL oper = toScalarAux c_toScalarL (fromei oper) foreign import ccall unsafe "toScalarL" c_toScalarL :: CInt -> TVV Z ------------------------------------------------------------------ -- | map of real vectors with given function vectorMapR :: FunCodeV -> Vector Double -> Vector Double vectorMapR = vectorMapAux c_vectorMapR foreign import ccall unsafe "mapR" c_vectorMapR :: CInt -> TVV Double -- | map of complex vectors with given function vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double) vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper) foreign import ccall unsafe "mapC" c_vectorMapC :: CInt -> TVV (Complex Double) -- | map of real vectors with given function vectorMapF :: FunCodeV -> Vector Float -> Vector Float vectorMapF = vectorMapAux c_vectorMapF foreign import ccall unsafe "mapF" c_vectorMapF :: CInt -> TVV Float -- | map of real vectors with given function vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float) vectorMapQ = vectorMapAux c_vectorMapQ foreign import ccall unsafe "mapQ" c_vectorMapQ :: CInt -> TVV (Complex Float) -- | map of real vectors with given function vectorMapI :: FunCodeV -> Vector CInt -> Vector CInt vectorMapI = vectorMapAux c_vectorMapI foreign import ccall unsafe "mapI" c_vectorMapI :: CInt -> TVV CInt -- | map of real vectors with given function vectorMapL :: FunCodeV -> Vector Z -> Vector Z vectorMapL = vectorMapAux c_vectorMapL foreign import ccall unsafe "mapL" c_vectorMapL :: CInt -> TVV Z ------------------------------------------------------------------- -- | map of real vectors with given function vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper) foreign import ccall unsafe "mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV Double -- | map of complex vectors with given function vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double) vectorMapValC = vectorMapValAux c_vectorMapValC foreign import ccall unsafe "mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TVV (Complex Double) -- | map of real vectors with given function vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper) foreign import ccall unsafe "mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TVV Float -- | map of complex vectors with given function vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float) vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper) foreign import ccall unsafe "mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TVV (Complex Float) -- | map of real vectors with given function vectorMapValI :: FunCodeSV -> CInt -> Vector CInt -> Vector CInt vectorMapValI oper = vectorMapValAux c_vectorMapValI (fromei oper) foreign import ccall unsafe "mapValI" c_vectorMapValI :: CInt -> Ptr CInt -> TVV CInt -- | map of real vectors with given function vectorMapValL :: FunCodeSV -> Z -> Vector Z -> Vector Z vectorMapValL oper = vectorMapValAux c_vectorMapValL (fromei oper) foreign import ccall unsafe "mapValL" c_vectorMapValL :: CInt -> Ptr Z -> TVV Z ------------------------------------------------------------------- type TVVV t = t :> t :> t :> Ok -- | elementwise operation on real vectors vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double vectorZipR = vectorZipAux c_vectorZipR foreign import ccall unsafe "zipR" c_vectorZipR :: CInt -> TVVV Double -- | elementwise operation on complex vectors vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) vectorZipC = vectorZipAux c_vectorZipC foreign import ccall unsafe "zipC" c_vectorZipC :: CInt -> TVVV (Complex Double) -- | elementwise operation on real vectors vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float vectorZipF = vectorZipAux c_vectorZipF foreign import ccall unsafe "zipF" c_vectorZipF :: CInt -> TVVV Float -- | elementwise operation on complex vectors vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float) vectorZipQ = vectorZipAux c_vectorZipQ foreign import ccall unsafe "zipQ" c_vectorZipQ :: CInt -> TVVV (Complex Float) -- | elementwise operation on CInt vectors vectorZipI :: FunCodeVV -> Vector CInt -> Vector CInt -> Vector CInt vectorZipI = vectorZipAux c_vectorZipI foreign import ccall unsafe "zipI" c_vectorZipI :: CInt -> TVVV CInt -- | elementwise operation on CInt vectors vectorZipL :: FunCodeVV -> Vector Z -> Vector Z -> Vector Z vectorZipL = vectorZipAux c_vectorZipL foreign import ccall unsafe "zipL" c_vectorZipL :: CInt -> TVVV Z -------------------------------------------------------------------------------- foreign import ccall unsafe "vectorScan" c_vectorScan :: CString -> Ptr CInt -> Ptr (Ptr Double) -> IO CInt vectorScan :: FilePath -> IO (Vector Double) vectorScan s = do pp <- malloc pn <- malloc cs <- newCString s ok <- c_vectorScan cs pn pp when (not (ok == 0)) $ error ("vectorScan: file \"" ++ s ++"\" not found") n <- fromIntegral <$> peek pn p <- peek pp v <- createVector n free pn free cs unsafeWith v $ \pv -> copyArray pv p n free p free pp return v -------------------------------------------------------------------------------- type Seed = Int data RandDist = Uniform -- ^ uniform distribution in [0,1) | Gaussian -- ^ normal distribution with mean zero and standard deviation one deriving Enum -- | Obtains a vector of pseudorandom elements (use randomIO to get a random seed). randomVector :: Seed -> RandDist -- ^ distribution -> Int -- ^ vector size -> Vector Double randomVector seed dist n = unsafePerformIO $ do r <- createVector n c_random_vector (fi seed) ((fi.fromEnum) dist) # r #|"randomVector" return r foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> Double :> Ok -------------------------------------------------------------------------------- roundVector v = unsafePerformIO $ do r <- createVector (dim v) c_round_vector # v # r #|"roundVector" return r foreign import ccall unsafe "round_vector" c_round_vector :: TVV Double -------------------------------------------------------------------------------- -- | -- >>> range 5 -- fromList [0,1,2,3,4] -- range :: Int -> Vector I range n = unsafePerformIO $ do r <- createVector n c_range_vector # r #|"range" return r foreign import ccall unsafe "range_vector" c_range_vector :: CInt :> Ok float2DoubleV :: Vector Float -> Vector Double float2DoubleV = tog c_float2double double2FloatV :: Vector Double -> Vector Float double2FloatV = tog c_double2float double2IntV :: Vector Double -> Vector CInt double2IntV = tog c_double2int int2DoubleV :: Vector CInt -> Vector Double int2DoubleV = tog c_int2double double2longV :: Vector Double -> Vector Z double2longV = tog c_double2long long2DoubleV :: Vector Z -> Vector Double long2DoubleV = tog c_long2double float2IntV :: Vector Float -> Vector CInt float2IntV = tog c_float2int int2floatV :: Vector CInt -> Vector Float int2floatV = tog c_int2float int2longV :: Vector I -> Vector Z int2longV = tog c_int2long long2intV :: Vector Z -> Vector I long2intV = tog c_long2int tog f v = unsafePerformIO $ do r <- createVector (dim v) f # v # r #|"tog" return r foreign import ccall unsafe "float2double" c_float2double :: Float :> Double :> Ok foreign import ccall unsafe "double2float" c_double2float :: Double :> Float :> Ok foreign import ccall unsafe "int2double" c_int2double :: CInt :> Double :> Ok foreign import ccall unsafe "double2int" c_double2int :: Double :> CInt :> Ok foreign import ccall unsafe "long2double" c_long2double :: Z :> Double :> Ok foreign import ccall unsafe "double2long" c_double2long :: Double :> Z :> Ok foreign import ccall unsafe "int2float" c_int2float :: CInt :> Float :> Ok foreign import ccall unsafe "float2int" c_float2int :: Float :> CInt :> Ok foreign import ccall unsafe "int2long" c_int2long :: I :> Z :> Ok foreign import ccall unsafe "long2int" c_long2int :: Z :> I :> Ok --------------------------------------------------------------- stepg f v = unsafePerformIO $ do r <- createVector (dim v) f # v # r #|"step" return r stepD :: Vector Double -> Vector Double stepD = stepg c_stepD stepF :: Vector Float -> Vector Float stepF = stepg c_stepF stepI :: Vector CInt -> Vector CInt stepI = stepg c_stepI stepL :: Vector Z -> Vector Z stepL = stepg c_stepL foreign import ccall unsafe "stepF" c_stepF :: TVV Float foreign import ccall unsafe "stepD" c_stepD :: TVV Double foreign import ccall unsafe "stepI" c_stepI :: TVV CInt foreign import ccall unsafe "stepL" c_stepL :: TVV Z -------------------------------------------------------------------------------- conjugateAux fun x = unsafePerformIO $ do v <- createVector (dim x) fun # x # v #|"conjugateAux" return v conjugateQ :: Vector (Complex Float) -> Vector (Complex Float) conjugateQ = conjugateAux c_conjugateQ foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TVV (Complex Float) conjugateC :: Vector (Complex Double) -> Vector (Complex Double) conjugateC = conjugateAux c_conjugateC foreign import ccall unsafe "conjugateC" c_conjugateC :: TVV (Complex Double) -------------------------------------------------------------------------------- cloneVector :: Storable t => Vector t -> IO (Vector t) cloneVector v = do let n = dim v r <- createVector n let f _ s _ d = copyArray d s n >> return 0 f # v # r #|"cloneVector" return r -------------------------------------------------------------------------------- constantAux fun x n = unsafePerformIO $ do v <- createVector n px <- newArray [x] fun px # v #|"constantAux" free px return v type TConst t = Ptr t -> t :> Ok foreign import ccall unsafe "constantF" cconstantF :: TConst Float foreign import ccall unsafe "constantR" cconstantR :: TConst Double foreign import ccall unsafe "constantQ" cconstantQ :: TConst (Complex Float) foreign import ccall unsafe "constantC" cconstantC :: TConst (Complex Double) foreign import ccall unsafe "constantI" cconstantI :: TConst CInt foreign import ccall unsafe "constantL" cconstantL :: TConst Z ---------------------------------------------------------------------- hmatrix-0.17.0.2/src/Internal/ST.hs0000644000000000000000000002105312722301655015032 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.ST -- Copyright : (c) Alberto Ruiz 2008 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- In-place manipulation inside the ST monad. -- See @examples/inplace.hs@ in the repository. -- ----------------------------------------------------------------------------- module Internal.ST ( ST, runST, -- * Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- * Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix, mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..), -- * Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector, unsafeThawVector, unsafeFreezeVector, newUndefinedMatrix, unsafeReadMatrix, unsafeWriteMatrix, unsafeThawMatrix, unsafeFreezeMatrix ) where import Internal.Vector import Internal.Matrix import Internal.Vectorized import Control.Monad.ST(ST, runST) import Foreign.Storable(Storable, peekElemOff, pokeElemOff) import Control.Monad.ST.Unsafe(unsafeIOToST) {-# INLINE ioReadV #-} ioReadV :: Storable t => Vector t -> Int -> IO t ioReadV v k = unsafeWith v $ \s -> peekElemOff s k {-# INLINE ioWriteV #-} ioWriteV :: Storable t => Vector t -> Int -> t -> IO () ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x newtype STVector s t = STVector (Vector t) thawVector :: Storable t => Vector t -> ST s (STVector s t) thawVector = unsafeIOToST . fmap STVector . cloneVector unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t) unsafeThawVector = unsafeIOToST . return . STVector runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t runSTVector st = runST (st >>= unsafeFreezeVector) {-# INLINE unsafeReadVector #-} unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x {-# INLINE unsafeWriteVector #-} unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s () unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k {-# INLINE modifyVector #-} modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s () modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s t -> ST s a liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x freezeVector :: (Storable t) => STVector s t -> ST s (Vector t) freezeVector v = liftSTVector id v unsafeFreezeVector :: (Storable t) => STVector s t -> ST s (Vector t) unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x {-# INLINE safeIndexV #-} safeIndexV f (STVector v) k | k < 0 || k>= dim v = error $ "out of range error in vector (dim=" ++show (dim v)++", pos="++show k++")" | otherwise = f (STVector v) k {-# INLINE readVector #-} readVector :: Storable t => STVector s t -> Int -> ST s t readVector = safeIndexV unsafeReadVector {-# INLINE writeVector #-} writeVector :: Storable t => STVector s t -> Int -> t -> ST s () writeVector = safeIndexV unsafeWriteVector newUndefinedVector :: Storable t => Int -> ST s (STVector s t) newUndefinedVector = unsafeIOToST . fmap STVector . createVector {-# INLINE newVector #-} newVector :: Storable t => t -> Int -> ST s (STVector s t) newVector x n = do v <- newUndefinedVector n let go (-1) = return v go !k = unsafeWriteVector v k x >> go (k-1 :: Int) go (n-1) ------------------------------------------------------------------------- {-# INLINE ioReadM #-} ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t ioReadM m r c = ioReadV (xdat m) (r * xRow m + c * xCol m) {-# INLINE ioWriteM #-} ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO () ioWriteM m r c val = ioWriteV (xdat m) (r * xRow m + c * xCol m) val newtype STMatrix s t = STMatrix (Matrix t) thawMatrix :: Element t => Matrix t -> ST s (STMatrix s t) thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t) unsafeThawMatrix = unsafeIOToST . return . STMatrix runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t runSTMatrix st = runST (st >>= unsafeFreezeMatrix) {-# INLINE unsafeReadMatrix #-} unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r {-# INLINE unsafeWriteMatrix #-} unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c {-# INLINE modifyMatrix #-} modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s () modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c liftSTMatrix :: (Element t) => (Matrix t -> a) -> STMatrix s t -> ST s a liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x unsafeFreezeMatrix :: (Storable t) => STMatrix s t -> ST s (Matrix t) unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x freezeMatrix :: (Element t) => STMatrix s t -> ST s (Matrix t) freezeMatrix m = liftSTMatrix id m cloneMatrix m = copy (orderOf m) m {-# INLINE safeIndexM #-} safeIndexM f (STMatrix m) r c | r<0 || r>=rows m || c<0 || c>=cols m = error $ "out of range error in matrix (size=" ++show (rows m,cols m)++", pos="++show (r,c)++")" | otherwise = f (STMatrix m) r c {-# INLINE readMatrix #-} readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t readMatrix = safeIndexM unsafeReadMatrix {-# INLINE writeMatrix #-} writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () writeMatrix = safeIndexM unsafeWriteMatrix setMatrix :: Element t => STMatrix s t -> Int -> Int -> Matrix t -> ST s () setMatrix (STMatrix x) i j m = unsafeIOToST $ setRect i j m x newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t) newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c {-# NOINLINE newMatrix #-} newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t) newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c) -------------------------------------------------------------------------------- data ColRange = AllCols | ColRange Int Int | Col Int | FromCol Int getColRange c AllCols = (0,c-1) getColRange c (ColRange a b) = (a `mod` c, b `mod` c) getColRange c (Col a) = (a `mod` c, a `mod` c) getColRange c (FromCol a) = (a `mod` c, c-1) data RowRange = AllRows | RowRange Int Int | Row Int | FromRow Int getRowRange r AllRows = (0,r-1) getRowRange r (RowRange a b) = (a `mod` r, b `mod` r) getRowRange r (Row a) = (a `mod` r, a `mod` r) getRowRange r (FromRow a) = (a `mod` r, r-1) data RowOper t = AXPY t Int Int ColRange | SCAL t RowRange ColRange | SWAP Int Int ColRange rowOper :: (Num t, Element t) => RowOper t -> STMatrix s t -> ST s () rowOper (AXPY x i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 0 x i1' i2' j1 j2 m where (j1,j2) = getColRange (cols m) r i1' = i1 `mod` (rows m) i2' = i2 `mod` (rows m) rowOper (SCAL x rr rc) (STMatrix m) = unsafeIOToST $ rowOp 1 x i1 i2 j1 j2 m where (i1,i2) = getRowRange (rows m) rr (j1,j2) = getColRange (cols m) rc rowOper (SWAP i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 2 0 i1' i2' j1 j2 m where (j1,j2) = getColRange (cols m) r i1' = i1 `mod` (rows m) i2' = i2 `mod` (rows m) extractMatrix (STMatrix m) rr rc = unsafeIOToST (extractR (orderOf m) m 0 (idxs[i1,i2]) 0 (idxs[j1,j2])) where (i1,i2) = getRowRange (rows m) rr (j1,j2) = getColRange (cols m) rc -- | r0 c0 height width data Slice s t = Slice (STMatrix s t) Int Int Int Int slice (Slice (STMatrix m) r0 c0 nr nc) = subMatrix (r0,c0) (nr,nc) m gemmm :: Element t => t -> Slice s t -> t -> Slice s t -> Slice s t -> ST s () gemmm beta (slice->r) alpha (slice->a) (slice->b) = res where res = unsafeIOToST (gemm v a b r) v = fromList [alpha,beta] mutable :: Element t => (forall s . (Int, Int) -> STMatrix s t -> ST s u) -> Matrix t -> (Matrix t,u) mutable f a = runST $ do x <- thawMatrix a info <- f (rows a, cols a) x r <- unsafeFreezeMatrix x return (r,info) hmatrix-0.17.0.2/src/Internal/Util.hs0000644000000000000000000005270012722301655015424 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- {- | Module : Internal.Util Copyright : (c) Alberto Ruiz 2013 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- module Internal.Util( -- * Convenience functions vector, matrix, disp, formatSparse, approxInt, dispDots, dispBlanks, formatShort, dispShort, zeros, ones, diagl, row, col, (&), (¦), (|||), (——), (===), (?), (¿), Indexable(..), size, Numeric, rand, randn, cross, norm, ℕ,ℤ,ℝ,ℂ,iC, Normed(..), norm_Frob, norm_nuclear, magnit, unitary, mt, (~!~), pairwiseD2, rowOuters, null1, null1sym, -- * Convolution -- ** 1D corr, conv, corrMin, -- ** 2D corr2, conv2, separable, block2x2,block3x3,view1,unView1,foldMatrix, gaussElim_1, gaussElim_2, gaussElim, luST, luSolve', luSolve'', luPacked', luPacked'', invershur ) where import Internal.Vector import Internal.Matrix hiding (size) import Internal.Numeric import Internal.Element import Internal.Container import Internal.Vectorized import Internal.IO import Internal.Algorithms hiding (Normed,linearSolve',luSolve', luPacked') import Numeric.Matrix() import Numeric.Vector() import Internal.Random import Internal.Convolution import Control.Monad(when,forM_) import Text.Printf import Data.List.Split(splitOn) import Data.List(intercalate,sortBy,foldl') import Control.Arrow((&&&),(***)) import Data.Complex import Data.Function(on) import Internal.ST type ℝ = Double type ℕ = Int type ℤ = Int type ℂ = Complex Double -- | imaginary unit iC :: C iC = 0:+1 {- | Create a real vector. >>> vector [1..5] fromList [1.0,2.0,3.0,4.0,5.0] -} vector :: [R] -> Vector R vector = fromList {- | Create a real matrix. >>> matrix 5 [1..15] (3><5) [ 1.0, 2.0, 3.0, 4.0, 5.0 , 6.0, 7.0, 8.0, 9.0, 10.0 , 11.0, 12.0, 13.0, 14.0, 15.0 ] -} matrix :: Int -- ^ number of columns -> [R] -- ^ elements in row order -> Matrix R matrix c = reshape c . fromList {- | print a real matrix with given number of digits after the decimal point >>> disp 5 $ ident 2 / 3 2x2 0.33333 0.00000 0.00000 0.33333 -} disp :: Int -> Matrix Double -> IO () disp n = putStr . dispf n {- | create a real diagonal matrix from a list >>> diagl [1,2,3] (3><3) [ 1.0, 0.0, 0.0 , 0.0, 2.0, 0.0 , 0.0, 0.0, 3.0 ] -} diagl :: [Double] -> Matrix Double diagl = diag . fromList -- | a real matrix of zeros zeros :: Int -- ^ rows -> Int -- ^ columns -> Matrix Double zeros r c = konst 0 (r,c) -- | a real matrix of ones ones :: Int -- ^ rows -> Int -- ^ columns -> Matrix Double ones r c = konst 1 (r,c) -- | concatenation of real vectors infixl 3 & (&) :: Vector Double -> Vector Double -> Vector Double a & b = vjoin [a,b] {- | horizontal concatenation >>> ident 3 ||| konst 7 (3,4) (3><7) [ 1.0, 0.0, 0.0, 7.0, 7.0, 7.0, 7.0 , 0.0, 1.0, 0.0, 7.0, 7.0, 7.0, 7.0 , 0.0, 0.0, 1.0, 7.0, 7.0, 7.0, 7.0 ] -} infixl 3 ||| (|||) :: Element t => Matrix t -> Matrix t -> Matrix t a ||| b = fromBlocks [[a,b]] -- | a synonym for ('|||') (unicode 0x00a6, broken bar) infixl 3 ¦ (¦) :: Matrix Double -> Matrix Double -> Matrix Double (¦) = (|||) -- | vertical concatenation -- (===) :: Element t => Matrix t -> Matrix t -> Matrix t infixl 2 === a === b = fromBlocks [[a],[b]] -- | a synonym for ('===') (unicode 0x2014, em dash) (——) :: Matrix Double -> Matrix Double -> Matrix Double infixl 2 —— (——) = (===) -- | create a single row real matrix from a list -- -- >>> row [2,3,1,8] -- (1><4) -- [ 2.0, 3.0, 1.0, 8.0 ] -- row :: [Double] -> Matrix Double row = asRow . fromList -- | create a single column real matrix from a list -- -- >>> col [7,-2,4] -- (3><1) -- [ 7.0 -- , -2.0 -- , 4.0 ] -- col :: [Double] -> Matrix Double col = asColumn . fromList {- | extract rows >>> (20><4) [1..] ? [2,1,1] (3><4) [ 9.0, 10.0, 11.0, 12.0 , 5.0, 6.0, 7.0, 8.0 , 5.0, 6.0, 7.0, 8.0 ] -} infixl 9 ? (?) :: Element t => Matrix t -> [Int] -> Matrix t (?) = flip extractRows {- | extract columns (unicode 0x00bf, inverted question mark, Alt-Gr ?) >>> (3><4) [1..] ¿ [3,0] (3><2) [ 4.0, 1.0 , 8.0, 5.0 , 12.0, 9.0 ] -} infixl 9 ¿ (¿) :: Element t => Matrix t -> [Int] -> Matrix t (¿)= flip extractColumns cross :: Product t => Vector t -> Vector t -> Vector t -- ^ cross product (for three-element vectors) cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3] | otherwise = error $ "the cross product requires 3-element vectors (sizes given: " ++show (dim x)++" and "++show (dim y)++")" where [x1,x2,x3] = toList x [y1,y2,y3] = toList y z1 = x2*y3-x3*y2 z2 = x3*y1-x1*y3 z3 = x1*y2-x2*y1 {-# SPECIALIZE cross :: Vector Double -> Vector Double -> Vector Double #-} {-# SPECIALIZE cross :: Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-} norm :: Vector Double -> Double -- ^ 2-norm of real vector norm = pnorm PNorm2 class Normed a where norm_0 :: a -> R norm_1 :: a -> R norm_2 :: a -> R norm_Inf :: a -> R instance Normed (Vector R) where norm_0 v = sumElements (step (abs v - scalar (eps*normInf v))) norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Vector C) where norm_0 v = sumElements (step (fst (fromComplex (abs v)) - scalar (eps*normInf v))) norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Matrix R) where norm_0 = norm_0 . flatten norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Matrix C) where norm_0 = norm_0 . flatten norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Vector I) where norm_0 = fromIntegral . sumElements . step . abs norm_1 = fromIntegral . norm1 norm_2 v = sqrt . fromIntegral $ dot v v norm_Inf = fromIntegral . normInf instance Normed (Vector Z) where norm_0 = fromIntegral . sumElements . step . abs norm_1 = fromIntegral . norm1 norm_2 v = sqrt . fromIntegral $ dot v v norm_Inf = fromIntegral . normInf instance Normed (Vector Float) where norm_0 = norm_0 . double norm_1 = norm_1 . double norm_2 = norm_2 . double norm_Inf = norm_Inf . double instance Normed (Vector (Complex Float)) where norm_0 = norm_0 . double norm_1 = norm_1 . double norm_2 = norm_2 . double norm_Inf = norm_Inf . double norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> R norm_Frob = norm_2 . flatten norm_nuclear :: Field t => Matrix t -> R norm_nuclear = sumElements . singularValues {- | Check if the absolute value or complex magnitude is greater than a given threshold >>> magnit 1E-6 (1E-12 :: R) False >>> magnit 1E-6 (3+iC :: C) True >>> magnit 0 (3 :: I ./. 5) True -} magnit :: (Element t, Normed (Vector t)) => R -> t -> Bool magnit e x = norm_1 (fromList [x]) > e -- | Obtains a vector in the same direction with 2-norm=1 unitary :: Vector Double -> Vector Double unitary v = v / scalar (norm v) -- | trans . inv mt :: Matrix Double -> Matrix Double mt = trans . inv -------------------------------------------------------------------------------- {- | >>> size $ vector [1..10] 10 >>> size $ (2><5)[1..10::Double] (2,5) -} size :: Container c t => c t -> IndexOf c size = size' {- | Alternative indexing function. >>> vector [1..10] ! 3 4.0 On a matrix it gets the k-th row as a vector: >>> matrix 5 [1..15] ! 1 fromList [6.0,7.0,8.0,9.0,10.0] >>> matrix 5 [1..15] ! 1 ! 3 9.0 -} class Indexable c t | c -> t , t -> c where infixl 9 ! (!) :: c -> Int -> t instance Indexable (Vector Double) Double where (!) = (@>) instance Indexable (Vector Float) Float where (!) = (@>) instance Indexable (Vector I) I where (!) = (@>) instance Indexable (Vector Z) Z where (!) = (@>) instance Indexable (Vector (Complex Double)) (Complex Double) where (!) = (@>) instance Indexable (Vector (Complex Float)) (Complex Float) where (!) = (@>) instance Element t => Indexable (Matrix t) (Vector t) where m!j = subVector (j*c) c (flatten m) where c = cols m -------------------------------------------------------------------------------- -- | Matrix of pairwise squared distances of row vectors -- (using the matrix product trick in blog.smola.org) pairwiseD2 :: Matrix Double -> Matrix Double -> Matrix Double pairwiseD2 x y | ok = x2 `outer` oy + ox `outer` y2 - 2* x <> trans y | otherwise = error $ "pairwiseD2 with different number of columns: " ++ show (size x) ++ ", " ++ show (size y) where ox = one (rows x) oy = one (rows y) oc = one (cols x) one k = konst 1 k x2 = x * x <> oc y2 = y * y <> oc ok = cols x == cols y -------------------------------------------------------------------------------- {- | outer products of rows >>> a (3><2) [ 1.0, 2.0 , 10.0, 20.0 , 100.0, 200.0 ] >>> b (3><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 ] >>> rowOuters a (b ||| 1) (3><8) [ 1.0, 2.0, 3.0, 1.0, 2.0, 4.0, 6.0, 2.0 , 40.0, 50.0, 60.0, 10.0, 80.0, 100.0, 120.0, 20.0 , 700.0, 800.0, 900.0, 100.0, 1400.0, 1600.0, 1800.0, 200.0 ] -} rowOuters :: Matrix Double -> Matrix Double -> Matrix Double rowOuters a b = a' * b' where a' = kronecker a (ones 1 (cols b)) b' = kronecker (ones 1 (cols a)) b -------------------------------------------------------------------------------- -- | solution of overconstrained homogeneous linear system null1 :: Matrix R -> Vector R null1 = last . toColumns . snd . rightSV -- | solution of overconstrained homogeneous symmetric linear system null1sym :: Herm R -> Vector R null1sym = last . toColumns . snd . eigSH -------------------------------------------------------------------------------- infixl 0 ~!~ c ~!~ msg = when c (error msg) -------------------------------------------------------------------------------- formatSparse :: String -> String -> String -> Int -> Matrix Double -> String formatSparse zeroI _zeroF sep _ (approxInt -> Just m) = format sep f m where f 0 = zeroI f x = printf "%.0f" x formatSparse zeroI zeroF sep n m = format sep f m where f x | abs (x::Double) < 2*peps = zeroI++zeroF | abs (fromIntegral (round x::Int) - x) / abs x < 2*peps = printf ("%.0f."++replicate n ' ') x | otherwise = printf ("%."++show n++"f") x approxInt m | norm_Inf (v - vi) < 2*peps * norm_Inf v = Just (reshape (cols m) vi) | otherwise = Nothing where v = flatten m vi = roundVector v dispDots n = putStr . formatSparse "." (replicate n ' ') " " n dispBlanks n = putStr . formatSparse "" "" " " n formatShort sep fmt maxr maxc m = auxm4 where (rm,cm) = size m (r1,r2,r3) | rm <= maxr = (rm,0,0) | otherwise = (maxr-3,rm-maxr+1,2) (c1,c2,c3) | cm <= maxc = (cm,0,0) | otherwise = (maxc-3,cm-maxc+1,2) [ [a,_,b] ,[_,_,_] ,[c,_,d]] = toBlocks [r1,r2,r3] [c1,c2,c3] m auxm = fromBlocks [[a,b],[c,d]] auxm2 | cm > maxc = format "|" fmt auxm | otherwise = format sep fmt auxm auxm3 | cm > maxc = map (f . splitOn "|") (lines auxm2) | otherwise = (lines auxm2) f items = intercalate sep (take (maxc-3) items) ++ " .. " ++ intercalate sep (drop (maxc-3) items) auxm4 | rm > maxr = unlines (take (maxr-3) auxm3 ++ vsep : drop (maxr-3) auxm3) | otherwise = unlines auxm3 vsep = map g (head auxm3) g '.' = ':' g _ = ' ' dispShort :: Int -> Int -> Int -> Matrix Double -> IO () dispShort maxr maxc dec m = printf "%dx%d\n%s" (rows m) (cols m) (formatShort " " fmt maxr maxc m) where fmt = printf ("%."++show dec ++"f") -------------------------------------------------------------------------------- -- matrix views block2x2 r c m = [[m11,m12],[m21,m22]] where m11 = m ?? (Take r, Take c) m12 = m ?? (Take r, Drop c) m21 = m ?? (Drop r, Take c) m22 = m ?? (Drop r, Drop c) block3x3 r nr c nc m = [[m ?? (er !! i, ec !! j) | j <- [0..2] ] | i <- [0..2] ] where er = [ Range 0 1 (r-1), Range r 1 (r+nr-1), Drop (nr+r) ] ec = [ Range 0 1 (c-1), Range c 1 (c+nc-1), Drop (nc+c) ] view1 :: Numeric t => Matrix t -> Maybe (View1 t) view1 m | rows m > 0 && cols m > 0 = Just (e, flatten m12, flatten m21 , m22) | otherwise = Nothing where [[m11,m12],[m21,m22]] = block2x2 1 1 m e = m11 `atIndex` (0, 0) unView1 :: Numeric t => View1 t -> Matrix t unView1 (e,r,c,m) = fromBlocks [[scalar e, asRow r],[asColumn c, m]] type View1 t = (t, Vector t, Vector t, Matrix t) foldMatrix :: Numeric t => (Matrix t -> Matrix t) -> (View1 t -> View1 t) -> (Matrix t -> Matrix t) foldMatrix g f ( (f <$>) . view1 . g -> Just (e,r,c,m)) = unView1 (e, r, c, foldMatrix g f m) foldMatrix _ _ m = m swapMax k m | rows m > 0 && j>0 = (j, m ?? (Pos (idxs swapped), All)) | otherwise = (0,m) where j = maxIndex $ abs (tr m ! k) swapped = j:[1..j-1] ++ 0:[j+1..rows m-1] down g a = foldMatrix g f a where f (e,r,c,m) | e /= 0 = (1, r', 0, m - outer c r') | otherwise = error "singular!" where r' = r / scalar e -- | generic reference implementation of gaussian elimination -- -- @a <> gaussElim a b = b@ -- gaussElim_2 :: (Eq t, Fractional t, Num (Vector t), Numeric t) => Matrix t -> Matrix t -> Matrix t gaussElim_2 a b = flipudrl r where flipudrl = flipud . fliprl splitColsAt n = (takeColumns n &&& dropColumns n) go f x y = splitColsAt (cols a) (down f $ x ||| y) (a1,b1) = go (snd . swapMax 0) a b ( _, r) = go id (flipudrl $ a1) (flipudrl $ b1) -------------------------------------------------------------------------------- gaussElim_1 :: (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) => Matrix t -> Matrix t -> Matrix t gaussElim_1 x y = dropColumns (rows x) (flipud $ fromRows s2) where rs = toRows $ x ||| y s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting s2 = pivotUp (rows x-1) (toRows $ flipud s1) pivotDown t n xs | t == n = [] | otherwise = y : pivotDown t (n+1) ys where y:ys = redu (pivot n xs) pivot k = (const k &&& id) . sortBy (flip compare `on` (abs. (!k))) redu (k,x:zs) | p == 0 = error "gauss: singular!" -- FIXME | otherwise = u : map f zs where p = x!k u = scale (recip (x!k)) x f z = z - scale (z!k) u redu (_,[]) = [] pivotUp n xs | n == -1 = [] | otherwise = y : pivotUp (n-1) ys where y:ys = redu' (n,xs) redu' (k,x:zs) = u : map f zs where u = x f z = z - scale (z!k) u redu' (_,[]) = [] -------------------------------------------------------------------------------- gaussElim a b = dropColumns (rows a) $ fst $ mutable gaussST (a ||| b) gaussST (r,_) x = do let n = r-1 axpy m a i j = rowOper (AXPY a i j AllCols) m swap m i j = rowOper (SWAP i j AllCols) m scal m a i = rowOper (SCAL a (Row i) AllCols) m forM_ [0..n] $ \i -> do c <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i) swap x i (i+c) a <- readMatrix x i i when (a == 0) $ error "singular!" scal x (recip a) i forM_ [i+1..n] $ \j -> do b <- readMatrix x j i axpy x (-b) i j forM_ [n,n-1..1] $ \i -> do forM_ [i-1,i-2..0] $ \j -> do b <- readMatrix x j i axpy x (-b) i j luST ok (r,_) x = do let axpy m a i j = rowOper (AXPY a i j (FromCol (i+1))) m swap m i j = rowOper (SWAP i j AllCols) m p <- newUndefinedVector r forM_ [0..r-1] $ \i -> do k <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i) writeVector p i (k+i) swap x i (i+k) a <- readMatrix x i i when (ok a) $ do forM_ [i+1..r-1] $ \j -> do b <- (/a) <$> readMatrix x j i axpy x (-b) i j writeMatrix x j i b v <- unsafeFreezeVector p return (toList v) {- | Experimental implementation of 'luPacked' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'. >>> let m = ident 5 + (5><5) [0..] :: Matrix (Z ./. 17) (5><5) [ 1, 1, 2, 3, 4 , 5, 7, 7, 8, 9 , 10, 11, 13, 13, 14 , 15, 16, 0, 2, 2 , 3, 4, 5, 6, 8 ] >>> let (l,u,p,s) = luFact $ luPacked' m >>> l (5><5) [ 1, 0, 0, 0, 0 , 6, 1, 0, 0, 0 , 12, 7, 1, 0, 0 , 7, 10, 7, 1, 0 , 8, 2, 6, 11, 1 ] >>> u (5><5) [ 15, 16, 0, 2, 2 , 0, 13, 7, 13, 14 , 0, 0, 15, 0, 11 , 0, 0, 0, 15, 15 , 0, 0, 0, 0, 1 ] -} luPacked' x = LU m p where (m,p) = mutable (luST (magnit 0)) x -------------------------------------------------------------------------------- scalS a (Slice x r0 c0 nr nc) = rowOper (SCAL a (RowRange r0 (r0+nr-1)) (ColRange c0 (c0+nc-1))) x view x k r = do d <- readMatrix x k k let rr = r-1-k o = if k < r-1 then 1 else 0 s = Slice x (k+1) (k+1) rr rr u = Slice x k (k+1) o rr l = Slice x (k+1) k rr o return (d,u,l,s) withVec r f = \s x -> do p <- newUndefinedVector r _ <- f s x p v <- unsafeFreezeVector p return v luPacked'' m = (id *** toList) (mutable (withVec (rows m) lu2) m) where lu2 (r,_) x p = do forM_ [0..r-1] $ \k -> do pivot x p k (d,u,l,s) <- view x k r when (magnit 0 d) $ do scalS (recip d) l gemmm 1 s (-1) l u pivot x p k = do j <- maxIndex . abs . flatten <$> extractMatrix x (FromRow k) (Col k) writeVector p k (j+k) swap k (k+j) where swap i j = rowOper (SWAP i j AllCols) x -------------------------------------------------------------------------------- rowRange m = [0..rows m -1] at k = Pos (idxs[k]) backSust' lup rhs = foldl' f (rhs?[]) (reverse ls) where ls = [ (d k , u k , b k) | k <- rowRange lup ] where d k = lup ?? (at k, at k) u k = lup ?? (at k, Drop (k+1)) b k = rhs ?? (at k, All) f x (d,u,b) = (b - u<>x) / d === x forwSust' lup rhs = foldl' f (rhs?[]) ls where ls = [ (l k , b k) | k <- rowRange lup ] where l k = lup ?? (at k, Take k) b k = rhs ?? (at k, All) f x (l,b) = x === (b - l<>x) luSolve'' (LU lup p) b = backSust' lup (forwSust' lup pb) where pb = b ?? (Pos (fixPerm' p), All) -------------------------------------------------------------------------------- forwSust lup rhs = fst $ mutable f rhs where f (r,c) x = do l <- unsafeThawMatrix lup let go k = gemmm 1 (Slice x k 0 1 c) (-1) (Slice l k 0 1 k) (Slice x 0 0 k c) mapM_ go [0..r-1] backSust lup rhs = fst $ mutable f rhs where f (r,c) m = do l <- unsafeThawMatrix lup let d k = recip (lup `atIndex` (k,k)) u k = Slice l k (k+1) 1 (r-1-k) b k = Slice m k 0 1 c x k = Slice m (k+1) 0 (r-1-k) c scal k = rowOper (SCAL (d k) (Row k) AllCols) m go k = gemmm 1 (b k) (-1) (u k) (x k) >> scal k mapM_ go [r-1,r-2..0] {- | Experimental implementation of 'luSolve' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'. >>> let a = (2><2) [1,2,3,5] :: Matrix (Z ./. 13) (2><2) [ 1, 2 , 3, 5 ] >>> b (2><3) [ 5, 1, 3 , 8, 6, 3 ] >>> luSolve' (luPacked' a) b (2><3) [ 4, 7, 4 , 7, 10, 6 ] -} luSolve' (LU lup p) b = backSust lup (forwSust lup pb) where pb = b ?? (Pos (fixPerm' p), All) -------------------------------------------------------------------------------- data MatrixView t b = Elem t | Block b b b b deriving Show viewBlock' r c m | (rt,ct) == (1,1) = Elem (atM' m 0 0) | otherwise = Block m11 m12 m21 m22 where (rt,ct) = size m m11 = subm (0,0) (r,c) m m12 = subm (0,c) (r,ct-c) m m21 = subm (r,0) (rt-r,c) m m22 = subm (r,c) (rt-r,ct-c) m subm = subMatrix viewBlock m = viewBlock' n n m where n = rows m `div` 2 invershur (viewBlock -> Block a b c d) = fromBlocks [[a',b'],[c',d']] where r1 = invershur a r2 = c <> r1 r3 = r1 <> b r4 = c <> r3 r5 = r4-d r6 = invershur r5 b' = r3 <> r6 c' = r6 <> r2 r7 = r3 <> c' a' = r1-r7 d' = -r6 invershur x = recip x -------------------------------------------------------------------------------- instance Testable (Matrix I) where checkT _ = test test :: (Bool, IO()) test = (and ok, return ()) where m = (3><4) [1..12] :: Matrix I r = (2><3) [1,2,3,4,3,2] c = (3><2) [0,4,4,1,2,3] p = (9><10) [0..89] :: Matrix I ep = (2><3) [10,24,32,44,31,23] md = fromInt m :: Matrix Double ok = [ tr m <> m == toInt (tr md <> md) , m <> tr m == toInt (md <> tr md) , m ?? (Take 2, Take 3) == remap (asColumn (range 2)) (asRow (range 3)) m , remap r (tr c) p == ep , tr p ?? (PosCyc (idxs[-5,13]), Pos (idxs[3,7,1])) == (2><3) [35,75,15,33,73,13] ] hmatrix-0.17.0.2/src/Internal/Foreign.hs0000644000000000000000000000622112722301655016075 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples #-} -- | FFI and hmatrix helpers. -- -- Sample usage, to upload a perspective matrix to a shader. -- -- @ glUniformMatrix4fv 0 1 (fromIntegral gl_TRUE) \`appMatrix\` perspective 0.01 100 (pi\/2) (4\/3) -- @ -- module Internal.Foreign ( app , appVector, appVectorLen , appMatrix, appMatrixLen, appMatrixRaw, appMatrixRawLen , unsafeMatrixToVector, unsafeMatrixToForeignPtr ) where import Foreign.C.Types(CInt) import Internal.Vector import Internal.Matrix import qualified Data.Vector.Storable as S import Foreign (Ptr, ForeignPtr, Storable) import GHC.Base (IO(..), realWorld#) {-# INLINE unsafeInlinePerformIO #-} -- | If we use unsafePerformIO, it may not get inlined, so in a function that returns IO (which are all safe uses of app* in this module), there would be -- unecessary calls to unsafePerformIO or its internals. unsafeInlinePerformIO :: IO a -> a unsafeInlinePerformIO (IO f) = case f realWorld# of (# _, x #) -> x {-# INLINE app #-} -- | Only useful since it is left associated with a precedence of 1, unlike 'Prelude.$', which is right associative. -- e.g. -- -- @ -- someFunction -- \`appMatrixLen\` m -- \`appVectorLen\` v -- \`app\` other -- \`app\` arguments -- \`app\` go here -- @ -- -- One could also write: -- -- @ -- (someFunction -- \`appMatrixLen\` m -- \`appVectorLen\` v) -- other -- arguments -- (go here) -- @ -- app :: (a -> b) -> a -> b app f = f {-# INLINE appVector #-} appVector :: Storable a => (Ptr a -> b) -> Vector a -> b appVector f x = unsafeInlinePerformIO (S.unsafeWith x (return . f)) {-# INLINE appVectorLen #-} appVectorLen :: Storable a => (CInt -> Ptr a -> b) -> Vector a -> b appVectorLen f x = unsafeInlinePerformIO (S.unsafeWith x (return . f (fromIntegral (S.length x)))) {-# INLINE appMatrix #-} appMatrix :: Element a => (Ptr a -> b) -> Matrix a -> b appMatrix f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f)) {-# INLINE appMatrixLen #-} appMatrixLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b appMatrixLen f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f r c)) where r = fromIntegral (rows x) c = fromIntegral (cols x) {-# INLINE appMatrixRaw #-} appMatrixRaw :: Storable a => (Ptr a -> b) -> Matrix a -> b appMatrixRaw f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f)) {-# INLINE appMatrixRawLen #-} appMatrixRawLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b appMatrixRawLen f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f r c)) where r = fromIntegral (rows x) c = fromIntegral (cols x) infixl 1 `app` infixl 1 `appVector` infixl 1 `appMatrix` infixl 1 `appMatrixRaw` {-# INLINE unsafeMatrixToVector #-} -- | This will disregard the order of the matrix, and simply return it as-is. -- If the order of the matrix is RowMajor, this function is identical to 'flatten'. unsafeMatrixToVector :: Matrix a -> Vector a unsafeMatrixToVector = xdat {-# INLINE unsafeMatrixToForeignPtr #-} unsafeMatrixToForeignPtr :: Storable a => Matrix a -> (ForeignPtr a, Int) unsafeMatrixToForeignPtr m = S.unsafeToForeignPtr0 (xdat m) hmatrix-0.17.0.2/src/Internal/Static.hs0000644000000000000000000003600312722301655015734 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {- | Module : Internal.Static Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Stability : provisional -} module Internal.Static where import GHC.TypeLits import qualified Numeric.LinearAlgebra as LA import Numeric.LinearAlgebra hiding (konst,size,R,C) import Internal.Vector as D hiding (R,C) import Internal.ST import Data.Proxy(Proxy) import Foreign.Storable(Storable) import Text.Printf -------------------------------------------------------------------------------- type ℝ = Double type ℂ = Complex Double newtype Dim (n :: Nat) t = Dim t deriving Show lift1F :: (c t -> c t) -> Dim n (c t) -> Dim n (c t) lift1F f (Dim v) = Dim (f v) lift2F :: (c t -> c t -> c t) -> Dim n (c t) -> Dim n (c t) -> Dim n (c t) lift2F f (Dim u) (Dim v) = Dim (f u v) -------------------------------------------------------------------------------- newtype R n = R (Dim n (Vector ℝ)) deriving (Num,Fractional,Floating) newtype C n = C (Dim n (Vector ℂ)) deriving (Num,Fractional,Floating) newtype L m n = L (Dim m (Dim n (Matrix ℝ))) newtype M m n = M (Dim m (Dim n (Matrix ℂ))) mkR :: Vector ℝ -> R n mkR = R . Dim mkC :: Vector ℂ -> C n mkC = C . Dim mkL :: Matrix ℝ -> L m n mkL x = L (Dim (Dim x)) mkM :: Matrix ℂ -> M m n mkM x = M (Dim (Dim x)) -------------------------------------------------------------------------------- type V n t = Dim n (Vector t) ud :: Dim n (Vector t) -> Vector t ud (Dim v) = v mkV :: forall (n :: Nat) t . t -> Dim n t mkV = Dim vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t) => V n t -> V m t -> V (n+m) t (ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v']) where du = fromIntegral . natVal $ (undefined :: Proxy n) dv = fromIntegral . natVal $ (undefined :: Proxy m) u' | du > 1 && LA.size u == 1 = LA.konst (u D.@> 0) du | otherwise = u v' | dv > 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv | otherwise = v gvec2 :: Storable t => t -> t -> V 2 t gvec2 a b = mkV $ runSTVector $ do v <- newUndefinedVector 2 writeVector v 0 a writeVector v 1 b return v gvec3 :: Storable t => t -> t -> t -> V 3 t gvec3 a b c = mkV $ runSTVector $ do v <- newUndefinedVector 3 writeVector v 0 a writeVector v 1 b writeVector v 2 c return v gvec4 :: Storable t => t -> t -> t -> t -> V 4 t gvec4 a b c d = mkV $ runSTVector $ do v <- newUndefinedVector 4 writeVector v 0 a writeVector v 1 b writeVector v 2 c writeVector v 3 d return v gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t gvect st xs' | ok = mkV v | not (null rest) && null (tail rest) = abort (show xs') | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]") | otherwise = abort (show xs) where (xs,rest) = splitAt d xs' ok = LA.size v == d && null rest v = LA.fromList xs d = fromIntegral . natVal $ (undefined :: Proxy n) abort info = error $ st++" "++show d++" can't be created from elements "++info -------------------------------------------------------------------------------- type GM m n t = Dim m (Dim n (Matrix t)) gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t gmat st xs' | ok = Dim (Dim x) | not (null rest) && null (tail rest) = abort (show xs') | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]") | otherwise = abort (show xs) where (xs,rest) = splitAt (m'*n') xs' v = LA.fromList xs x = reshape n' v ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n')) m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info -------------------------------------------------------------------------------- class Num t => Sized t s d | s -> t, s -> d where konst :: t -> s unwrap :: s -> d t fromList :: [t] -> s extract :: s -> d t create :: d t -> Maybe s size :: s -> IndexOf d singleV v = LA.size v == 1 singleM m = rows m == 1 && cols m == 1 instance forall n. KnownNat n => Sized ℂ (C n) Vector where size _ = fromIntegral . natVal $ (undefined :: Proxy n) konst x = mkC (LA.scalar x) unwrap (C (Dim v)) = v fromList xs = C (gvect "C" xs) extract s@(unwrap -> v) | singleV v = LA.konst (v!0) (size s) | otherwise = v create v | LA.size v == size r = Just r | otherwise = Nothing where r = mkC v :: C n instance forall n. KnownNat n => Sized ℝ (R n) Vector where size _ = fromIntegral . natVal $ (undefined :: Proxy n) konst x = mkR (LA.scalar x) unwrap (R (Dim v)) = v fromList xs = R (gvect "R" xs) extract s@(unwrap -> v) | singleV v = LA.konst (v!0) (size s) | otherwise = v create v | LA.size v == size r = Just r | otherwise = Nothing where r = mkR v :: R n instance forall m n . (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix where size _ = ((fromIntegral . natVal) (undefined :: Proxy m) ,(fromIntegral . natVal) (undefined :: Proxy n)) konst x = mkL (LA.scalar x) fromList xs = L (gmat "L" xs) unwrap (L (Dim (Dim m))) = m extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n' extract s@(unwrap -> a) | singleM a = LA.konst (a `atIndex` (0,0)) (size s) | otherwise = a create x | LA.size x == size r = Just r | otherwise = Nothing where r = mkL x :: L m n instance forall m n . (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix where size _ = ((fromIntegral . natVal) (undefined :: Proxy m) ,(fromIntegral . natVal) (undefined :: Proxy n)) konst x = mkM (LA.scalar x) fromList xs = M (gmat "M" xs) unwrap (M (Dim (Dim m))) = m extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n' extract s@(unwrap -> a) | singleM a = LA.konst (a `atIndex` (0,0)) (size s) | otherwise = a create x | LA.size x == size r = Just r | otherwise = Nothing where r = mkM x :: M m n -------------------------------------------------------------------------------- instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m) where tr a@(isDiag -> Just _) = mkL (extract a) tr (extract -> a) = mkL (tr a) tr' = tr instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m) where tr a@(isDiagC -> Just _) = mkM (extract a) tr (extract -> a) = mkM (tr a) tr' a@(isDiagC -> Just _) = mkM (extract a) tr' (extract -> a) = mkM (tr' a) -------------------------------------------------------------------------------- isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int)) isDiag (L x) = isDiagg x isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int)) isDiagC (M x) = isDiagg x isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int)) isDiagg (Dim (Dim x)) | singleM x = Nothing | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n')) | otherwise = Nothing where m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int v = flatten x z = v `atIndex` 0 y = subVector 1 (LA.size v-1) v ny = LA.size y zeros = LA.konst 0 (max 0 (min m' n' - ny)) yz = vjoin [y,zeros] -------------------------------------------------------------------------------- instance forall n . KnownNat n => Show (R n) where show s@(R (Dim v)) | singleV v = "("++show (v!0)++" :: R "++show d++")" | otherwise = "(vector"++ drop 8 (show v)++" :: R "++show d++")" where d = size s instance forall n . KnownNat n => Show (C n) where show s@(C (Dim v)) | singleV v = "("++show (v!0)++" :: C "++show d++")" | otherwise = "(vector"++ drop 8 (show v)++" :: C "++show d++")" where d = size s instance forall m n . (KnownNat m, KnownNat n) => Show (L m n) where show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (drop 9 $ show y) m' n' show s@(L (Dim (Dim x))) | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n' | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: L "++show m'++" "++show n'++")" where (m',n') = size s instance forall m n . (KnownNat m, KnownNat n) => Show (M m n) where show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (drop 9 $ show y) m' n' show s@(M (Dim (Dim x))) | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n' | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: M "++show m'++" "++show n'++")" where (m',n') = size s -------------------------------------------------------------------------------- instance forall n t . (Num (Vector t), Numeric t )=> Num (Dim n (Vector t)) where (+) = lift2F (+) (*) = lift2F (*) (-) = lift2F (-) abs = lift1F abs signum = lift1F signum negate = lift1F negate fromInteger x = Dim (fromInteger x) instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim n (Vector t)) where fromRational x = Dim (fromRational x) (/) = lift2F (/) instance (Fractional t, Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where sin = lift1F sin cos = lift1F cos tan = lift1F tan asin = lift1F asin acos = lift1F acos atan = lift1F atan sinh = lift1F sinh cosh = lift1F cosh tanh = lift1F tanh asinh = lift1F asinh acosh = lift1F acosh atanh = lift1F atanh exp = lift1F exp log = lift1F log sqrt = lift1F sqrt (**) = lift2F (**) pi = Dim pi instance (Num (Matrix t), Numeric t) => Num (Dim m (Dim n (Matrix t))) where (+) = (lift2F . lift2F) (+) (*) = (lift2F . lift2F) (*) (-) = (lift2F . lift2F) (-) abs = (lift1F . lift1F) abs signum = (lift1F . lift1F) signum negate = (lift1F . lift1F) negate fromInteger x = Dim (Dim (fromInteger x)) instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim m (Dim n (Matrix t))) where fromRational x = Dim (Dim (fromRational x)) (/) = (lift2F.lift2F) (/) instance (Num (Vector t), Floating (Matrix t), Fractional t, Numeric t) => Floating (Dim m (Dim n (Matrix t))) where sin = (lift1F . lift1F) sin cos = (lift1F . lift1F) cos tan = (lift1F . lift1F) tan asin = (lift1F . lift1F) asin acos = (lift1F . lift1F) acos atan = (lift1F . lift1F) atan sinh = (lift1F . lift1F) sinh cosh = (lift1F . lift1F) cosh tanh = (lift1F . lift1F) tanh asinh = (lift1F . lift1F) asinh acosh = (lift1F . lift1F) acosh atanh = (lift1F . lift1F) atanh exp = (lift1F . lift1F) exp log = (lift1F . lift1F) log sqrt = (lift1F . lift1F) sqrt (**) = (lift2F . lift2F) (**) pi = Dim (Dim pi) -------------------------------------------------------------------------------- adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b)) adaptDiag f a b = f a b isFull m = isDiag m == Nothing && not (singleM (unwrap m)) lift1L f (L v) = L (f v) lift2L f (L a) (L b) = L (f a b) lift2LD f = adaptDiag (lift2L f) instance (KnownNat n, KnownNat m) => Num (L n m) where (+) = lift2LD (+) (*) = lift2LD (*) (-) = lift2LD (-) abs = lift1L abs signum = lift1L signum negate = lift1L negate fromInteger = L . Dim . Dim . fromInteger instance (KnownNat n, KnownNat m) => Fractional (L n m) where fromRational = L . Dim . Dim . fromRational (/) = lift2LD (/) instance (KnownNat n, KnownNat m) => Floating (L n m) where sin = lift1L sin cos = lift1L cos tan = lift1L tan asin = lift1L asin acos = lift1L acos atan = lift1L atan sinh = lift1L sinh cosh = lift1L cosh tanh = lift1L tanh asinh = lift1L asinh acosh = lift1L acosh atanh = lift1L atanh exp = lift1L exp log = lift1L log sqrt = lift1L sqrt (**) = lift2LD (**) pi = konst pi -------------------------------------------------------------------------------- adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b)) adaptDiagC f a b = f a b isFullC m = isDiagC m == Nothing && not (singleM (unwrap m)) lift1M f (M v) = M (f v) lift2M f (M a) (M b) = M (f a b) lift2MD f = adaptDiagC (lift2M f) instance (KnownNat n, KnownNat m) => Num (M n m) where (+) = lift2MD (+) (*) = lift2MD (*) (-) = lift2MD (-) abs = lift1M abs signum = lift1M signum negate = lift1M negate fromInteger = M . Dim . Dim . fromInteger instance (KnownNat n, KnownNat m) => Fractional (M n m) where fromRational = M . Dim . Dim . fromRational (/) = lift2MD (/) instance (KnownNat n, KnownNat m) => Floating (M n m) where sin = lift1M sin cos = lift1M cos tan = lift1M tan asin = lift1M asin acos = lift1M acos atan = lift1M atan sinh = lift1M sinh cosh = lift1M cosh tanh = lift1M tanh asinh = lift1M asinh acosh = lift1M acosh atanh = lift1M atanh exp = lift1M exp log = lift1M log sqrt = lift1M sqrt (**) = lift2MD (**) pi = M pi -------------------------------------------------------------------------------- class Disp t where disp :: Int -> t -> IO () instance (KnownNat m, KnownNat n) => Disp (L m n) where disp n x = do let a = extract x let su = LA.dispf n a printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su) instance (KnownNat m, KnownNat n) => Disp (M m n) where disp n x = do let a = extract x let su = LA.dispcf n a printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su) instance KnownNat n => Disp (R n) where disp n v = do let su = LA.dispf n (asRow $ extract v) putStr "R " >> putStr (tail . dropWhile (/='x') $ su) instance KnownNat n => Disp (C n) where disp n v = do let su = LA.dispcf n (asRow $ extract v) putStr "C " >> putStr (tail . dropWhile (/='x') $ su) -------------------------------------------------------------------------------- #else module Numeric.LinearAlgebra.Static.Internal where #endif hmatrix-0.17.0.2/src/Internal/Devel.hs0000644000000000000000000000447412722301655015553 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Internal.Devel -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- module Internal.Devel where import Control.Monad ( when ) import Foreign.C.Types ( CInt ) --import Foreign.Storable.Complex () import Foreign.Ptr(Ptr) import Control.Exception as E ( SomeException, catch ) import Internal.Vector(Vector,avec) import Foreign.Storable(Storable) -- | postfix function application (@flip ($)@) (//) :: x -> (x -> y) -> y infixl 0 // (//) = flip ($) -- GSL error codes are <= 1024 -- | error codes for the auxiliary functions required by the wrappers errorCode :: CInt -> String errorCode 2000 = "bad size" errorCode 2001 = "bad function code" errorCode 2002 = "memory problem" errorCode 2003 = "bad file" errorCode 2004 = "singular" errorCode 2005 = "didn't converge" errorCode 2006 = "the input matrix is not positive definite" errorCode 2007 = "not yet supported in this OS" errorCode n = "code "++show n -- | clear the fpu foreign import ccall unsafe "asm_finit" finit :: IO () -- | check the error code check :: String -> IO CInt -> IO () check msg f = do -- finit err <- f when (err/=0) $ error (msg++": "++errorCode err) return () -- | postfix error code check infixl 0 #| (#|) = flip check -- | Error capture and conversion to Maybe mbCatch :: IO x -> IO (Maybe x) mbCatch act = E.catch (Just `fmap` act) f where f :: SomeException -> IO (Maybe x) f _ = return Nothing -------------------------------------------------------------------------------- type CM b r = CInt -> CInt -> Ptr b -> r type CV b r = CInt -> Ptr b -> r type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r type CIdxs r = CV CInt r type Ok = IO CInt infixr 5 :>, ::>, ..> type (:>) t r = CV t r type (::>) t r = OM t r type (..>) t r = CM t r class TransArray c where type Trans c b type TransRaw c b apply :: (Trans c b) -> c -> b applyRaw :: (TransRaw c b) -> c -> b infixl 1 `apply`, `applyRaw` instance Storable t => TransArray (Vector t) where type Trans (Vector t) b = CInt -> Ptr t -> b type TransRaw (Vector t) b = CInt -> Ptr t -> b apply = avec {-# INLINE apply #-} applyRaw = avec {-# INLINE applyRaw #-} hmatrix-0.17.0.2/src/Internal/C/0000755000000000000000000000000012722301655014331 5ustar0000000000000000hmatrix-0.17.0.2/src/Internal/C/vector-aux.c0000644000000000000000000007366612722301655016614 0ustar0000000000000000#include #include typedef double complex TCD; typedef float complex TCF; #undef complex #include "lapack-aux.h" #define V(x) x##n,x##p #include #include #include #include #include #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define OK return 0; #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) #ifdef DBG #define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M); #else #define DEBUGMSG(M) #endif #define CHECK(RES,CODE) MACRO(if(RES) return CODE;) #define BAD_SIZE 2000 #define BAD_CODE 2001 #define MEM 2002 #define BAD_FILE 2003 int sumF(KFVEC(x),FVEC(r)) { DEBUGMSG("sumF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumR(KDVEC(x),DVEC(r)) { DEBUGMSG("sumR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumI(int m, KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 0; if (m==1) { for (i = 0; i < xn; i++) res += xp[i]; } else { for (i = 0; i < xn; i++) res = (res + xp[i]) % m; } rp[0] = res; OK } int sumL(int64_t m, KLVEC(x),LVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 0; if (m==1) { for (i = 0; i < xn; i++) res += xp[i]; } else { for (i = 0; i < xn; i++) res = (res + xp[i]) % m; } rp[0] = res; OK } int sumQ(KQVEC(x),QVEC(r)) { DEBUGMSG("sumQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int sumC(KCVEC(x),CVEC(r)) { DEBUGMSG("sumC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int prodF(KFVEC(x),FVEC(r)) { DEBUGMSG("prodF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodR(KDVEC(x),DVEC(r)) { DEBUGMSG("prodR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodI(int m, KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 1; if (m==1) { for (i = 0; i < xn; i++) res *= xp[i]; } else { for (i = 0; i < xn; i++) res = (res * xp[i]) % m; } rp[0] = res; OK } int prodL(int64_t m, KLVEC(x),LVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 1; if (m==1) { for (i = 0; i < xn; i++) res *= xp[i]; } else { for (i = 0; i < xn; i++) res = (res * xp[i]) % m; } rp[0] = res; OK } int prodQ(KQVEC(x),QVEC(r)) { DEBUGMSG("prodQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; float temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } int prodC(KCVEC(x),CVEC(r)) { DEBUGMSG("prodC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; double temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } double dnrm2_(integer*, const double*, integer*); double dasum_(integer*, const double*, integer*); double vector_max(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kr) { r = xp[k]; } } return r; } double vector_min(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index(KDVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } float vector_min_f(KFVEC(x)) { float r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_f(KFVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } int vector_min_i(KIVEC(x)) { int r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_i(KIVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } int64_t vector_min_l(KLVEC(x)) { int64_t r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_l(KLVEC(x)) { int k, r = 0; for (k = 1; k0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } inline float float_sign(float x) { if(x>0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } #define OP(C,F) case C: { for(k=0;k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } int random_vector(unsigned int seed, int code, DVEC(r)) { int phase = 0; double V1,V2,S; srandom(seed); int k; switch (code) { case 0: { // uniform for (k=0; k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } int random_vector(unsigned int seed, int code, DVEC(r)) { struct random_data buffer; char random_state[128]; memset(&buffer, 0, sizeof(struct random_data)); memset(random_state, 0, sizeof(random_state)); initstate_r(seed,random_state,sizeof(random_state),&buffer); // setstate_r(random_state,&buffer); // srandom_r(seed,&buffer); int phase = 0; double V1,V2,S; int k; switch (code) { case 0: { // uniform for (k=0; k *(double*)b; } int sort_valuesD(KDVEC(v),DVEC(r)) { memcpy(rp,vp,vn*sizeof(double)); qsort(rp,rn,sizeof(double),compare_doubles); OK } int compare_floats (const void *a, const void *b) { return *(float*)a > *(float*)b; } int sort_valuesF(KFVEC(v),FVEC(r)) { memcpy(rp,vp,vn*sizeof(float)); qsort(rp,rn,sizeof(float),compare_floats); OK } int compare_ints(const void *a, const void *b) { return *(int*)a > *(int*)b; } int sort_valuesI(KIVEC(v),IVEC(r)) { memcpy(rp,vp,vn*sizeof(int)); qsort(rp,rn,sizeof(int),compare_ints); OK } int compare_longs(const void *a, const void *b) { return *(int64_t*)a > *(int64_t*)b; } int sort_valuesL(KLVEC(v),LVEC(r)) { memcpy(rp,vp,vn*sizeof(int64_t)); qsort(rp,rn,sizeof(int64_t),compare_ints); OK } //////////////////////////////////////// #define SORTIDX_IMP(T,C) \ T* x = (T*)malloc(sizeof(T)*vn); \ int k; \ for (k=0;kval > ((DI*)b)->val; } int sort_indexD(KDVEC(v),IVEC(r)) { SORTIDX_IMP(DI,compare_doubles_i) } typedef struct FI { int pos; float val;} FI; int compare_floats_i (const void *a, const void *b) { return ((FI*)a)->val > ((FI*)b)->val; } int sort_indexF(KFVEC(v),IVEC(r)) { SORTIDX_IMP(FI,compare_floats_i) } typedef struct II { int pos; int val;} II; int compare_ints_i (const void *a, const void *b) { return ((II*)a)->val > ((II*)b)->val; } int sort_indexI(KIVEC(v),IVEC(r)) { SORTIDX_IMP(II,compare_ints_i) } typedef struct LI { int pos; int64_t val;} LI; int compare_longs_i (const void *a, const void *b) { return ((II*)a)->val > ((II*)b)->val; } int sort_indexL(KLVEC(v),LVEC(r)) { SORTIDX_IMP(II,compare_longs_i) } //////////////////////////////////////////////////////////////////////////////// int round_vector(KDVEC(v),DVEC(r)) { int k; for(k=0; k0; \ } \ OK int stepF(KFVEC(x),FVEC(y)) { STEP_IMP } int stepD(KDVEC(x),DVEC(y)) { STEP_IMP } int stepI(KIVEC(x),IVEC(y)) { STEP_IMP } int stepL(KLVEC(x),LVEC(y)) { STEP_IMP } //////////////////// cond ///////////////////////// #define COMPARE_IMP \ REQUIRES(xn==yn && xn==rn ,BAD_SIZE); \ int k; \ for(k=0;kyp[k]?1:0); \ } \ OK int compareF(KFVEC(x),KFVEC(y),IVEC(r)) { COMPARE_IMP } int compareD(KDVEC(x),KDVEC(y),IVEC(r)) { COMPARE_IMP } int compareI(KIVEC(x),KIVEC(y),IVEC(r)) { COMPARE_IMP } int compareL(KLVEC(x),KLVEC(y),IVEC(r)) { COMPARE_IMP } #define CHOOSE_IMP \ REQUIRES(condn==ltn && ltn==eqn && ltn==gtn && ltn==rn ,BAD_SIZE); \ int k; \ for(k=0;k0?gtp[k]:eqp[k]); \ } \ OK int chooseF(KIVEC(cond),KFVEC(lt),KFVEC(eq),KFVEC(gt),FVEC(r)) { CHOOSE_IMP } int chooseD(KIVEC(cond),KDVEC(lt),KDVEC(eq),KDVEC(gt),DVEC(r)) { CHOOSE_IMP } int chooseI(KIVEC(cond),KIVEC(lt),KIVEC(eq),KIVEC(gt),IVEC(r)) { CHOOSE_IMP } int chooseL(KIVEC(cond),KLVEC(lt),KLVEC(eq),KLVEC(gt),LVEC(r)) { CHOOSE_IMP } int chooseC(KIVEC(cond),KCVEC(lt),KCVEC(eq),KCVEC(gt),CVEC(r)) { CHOOSE_IMP } int chooseQ(KIVEC(cond),KQVEC(lt),KQVEC(eq),KQVEC(gt),QVEC(r)) { CHOOSE_IMP } hmatrix-0.17.0.2/src/Internal/C/lapack-aux.c0000644000000000000000000012277512722301655016541 0ustar0000000000000000#include #include #include #include #include #include #include typedef double complex TCD; typedef float complex TCF; #undef complex #include "lapack-aux.h" #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) // #define DBGL #ifdef DBGL #define DEBUGMSG(M) printf("\nLAPACK "M"\n"); #else #define DEBUGMSG(M) #endif #define OK return 0; // #ifdef DBGL // #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL); // #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;); // #else // #define DEBUGMSG(M) // #define OK return 0; // #endif #define INFOMAT(M) printf("%dx%d %d:%d\n",M##r,M##c,M##Xr,M##Xc); #define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \ for(q=0;q=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveR_l"); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; dgesv_ (&n,&nhrs, ap, &n, ipiv, bp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); OK } //////////////////// general complex linear system //////////// int zgesv_(integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer * info); int linearSolveC_l(OCMAT(a),OCMAT(b)) { integer n = ar; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveC_l"); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; zgesv_ (&n,&nhrs, ap, &n, ipiv, bp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); OK } //////// symmetric positive definite real linear system using Cholesky //////////// int dpotrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * info); int cholSolveR_l(KODMAT(a),ODMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveR_l"); integer res; dpotrs_ ("U", &n,&nhrs, (double*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////// Hermitian positive definite real linear system using Cholesky //////////// int zpotrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info); int cholSolveC_l(KOCMAT(a),OCMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveC_l"); integer res; zpotrs_ ("U", &n,&nhrs, (doublecomplex*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////////////////// least squares real linear system //////////// int dgels_(char *trans, integer *m, integer *n, integer * nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info); int linearSolveLSR_l(ODMAT(a),ODMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveLSR_l"); integer res; integer lwork = -1; double ans; dgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, &ans,&lwork, &res); lwork = ceil(ans); double * work = (double*)malloc(lwork*sizeof(double)); dgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, work,&lwork, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(work); OK } //////////////////// least squares complex linear system //////////// int zgels_(char *trans, integer *m, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info); int linearSolveLSC_l(OCMAT(a),OCMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveLSC_l"); integer res; integer lwork = -1; doublecomplex ans; zgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, &ans,&lwork, &res); lwork = ceil(ans.r); doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, work,&lwork, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(work); OK } //////////////////// least squares real linear system using SVD //////////// int dgelss_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info); int linearSolveSVDR_l(double rcond,ODMAT(a),ODMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveSVDR_l"); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); integer res; integer lwork = -1; integer rank; double ans; dgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, &ans,&lwork, &res); lwork = ceil(ans); double * work = (double*)malloc(lwork*sizeof(double)); dgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, work,&lwork, &res); if(res>0) { return NOCONVER; } CHECK(res,res); free(work); free(S); OK } //////////////////// least squares complex linear system using SVD //////////// int zgelss_(integer *m, integer *n, integer *nhrs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer* rank, doublecomplex *work, integer* lwork, doublereal* rwork, integer *info); int linearSolveSVDC_l(double rcond, OCMAT(a),OCMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveSVDC_l"); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double)); integer res; integer lwork = -1; integer rank; doublecomplex ans; zgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, &ans,&lwork, RWORK, &res); lwork = ceil(ans.r); doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, work,&lwork, RWORK, &res); if(res>0) { return NOCONVER; } CHECK(res,res); free(work); free(RWORK); free(S); OK } //////////////////// Cholesky factorization ///////////////////////// int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info); int chol_l_H(OCMAT(l)) { integer n = lr; REQUIRES(n>=1 && lc == n,BAD_SIZE); DEBUGMSG("chol_l_H"); char uplo = 'U'; integer res; zpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); doublecomplex zero = {0.,0.}; int r,c; for (r=0; r=1 && lc == n,BAD_SIZE); DEBUGMSG("chol_l_S"); char uplo = 'U'; integer res; dpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); int r,c; for (r=0; r=1 && n >=1 && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_R"); double *WORK = (double*)malloc(n*sizeof(double)); CHECK(!WORK,MEM); integer res; dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } int zgeqr2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info); int qr_l_C(CVEC(tau), OCMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_C"); doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } int dorgqr_(integer *m, integer *n, integer *k, doublereal * a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); int c_dorgqr(KDVEC(tau), ODMAT(r)) { integer m = rr; integer n = MIN(rc,rr); integer k = taun; DEBUGMSG("c_dorgqr"); integer lwork = 8*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); CHECK(!WORK,MEM); integer res; dorgqr_ (&m,&n,&k,rp,&m,(double*)taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info); int c_zungqr(KCVEC(tau), OCMAT(r)) { integer m = rr; integer n = MIN(rc,rr); integer k = taun; DEBUGMSG("z_ungqr"); integer lwork = 8*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; zungqr_ (&m,&n,&k,rp,&m,(doublecomplex*)taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } //////////////////// Hessenberg factorization ///////////////////////// int dgehrd_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); int hess_l_R(DVEC(tau), ODMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_R"); integer lwork = 5*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); CHECK(!WORK,MEM); integer res; integer one = 1; dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } int zgehrd_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info); int hess_l_C(CVEC(tau), OCMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_C"); integer lwork = 5*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; integer one = 1; zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } //////////////////// Schur factorization ///////////////////////// int dgees_(char *jobvs, char *sort, L_fp select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info); int schur_l_R(ODMAT(u), ODMAT(s)) { integer m = sr; integer n = sc; REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE); DEBUGMSG("schur_l_R"); integer lwork = 6*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); double *WR = (double*)malloc(n*sizeof(double)); double *WI = (double*)malloc(n*sizeof(double)); // WR and WI not really required in this call logical *BWORK = (logical*)malloc(n*sizeof(logical)); integer res; integer sdim; dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res); if(res>0) { return NOCONVER; } CHECK(res,res); free(WR); free(WI); free(BWORK); free(WORK); OK } int zgees_(char *jobvs, char *sort, L_fp select, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info); int schur_l_C(OCMAT(u), OCMAT(s)) { integer m = sr; integer n = sc; REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE); DEBUGMSG("schur_l_C"); integer lwork = 6*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex)); // W not really required in this call logical *BWORK = (logical*)malloc(n*sizeof(logical)); double *RWORK = (double*)malloc(n*sizeof(double)); integer res; integer sdim; zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W, up,&n, WORK,&lwork,RWORK,BWORK,&res); if(res>0) { return NOCONVER; } CHECK(res,res); free(W); free(BWORK); free(WORK); OK } //////////////////// LU factorization ///////////////////////// int dgetrf_(integer *m, integer *n, doublereal *a, integer * lda, integer *ipiv, integer *info); int lu_l_R(DVEC(ipiv), ODMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_R"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); integer res; dgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // FIXME } CHECK(res,res); int k; for (k=0; k=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_C"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); integer res; zgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // FIXME } CHECK(res,res); int k; for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); DEBUGMSG("ldl_R"); integer* auxipiv = (integer*)malloc(n*sizeof(integer)); integer res; integer lda = rXc; integer lwork = -1; doublereal ans; dsytrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res); lwork = ceil(ans); doublereal* work = (doublereal*)malloc(lwork*sizeof(doublereal)); dsytrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); CHECK(res,res); int k; for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); DEBUGMSG("ldl_R"); integer* auxipiv = (integer*)malloc(n*sizeof(integer)); integer res; integer lda = rXc; integer lwork = -1; doublecomplex ans; zhetrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res); lwork = ceil(ans.r); doublecomplex* work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zhetrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); CHECK(res,res); int k; for (k=0; k=0 && x=0 && y0) { return m >=0 ? m : m+b; } else { return m <=0 ? m : m+b; } } static inline int64_t mod_l (int64_t a, int64_t b) { int64_t m = a % b; if (b>0) { return m >=0 ? m : m+b; } else { return m <=0 ? m : m+b; } }