hmatrix-0.15.0.0/0000755000000000000000000000000012165764700011605 5ustar0000000000000000hmatrix-0.15.0.0/INSTALL.md0000644000000000000000000001024512165764700013237 0ustar0000000000000000 # [hmatrix][hmatrix2] installation This package requires the [Glasgow Haskell Compiler](http://www.haskell.org/ghc/index.html) ghc >= 6.10, and [cabal-install](http://www.haskell.org/haskellwiki/Cabal-Install), conveniently available in the [Haskell Platform](http://hackage.haskell.org/platform), and the development packages for [GSL](http://www.gnu.org/software/gsl) and BLAS/[LAPACK](http://www.netlib.org/lapack). (The graphical functions also require **gnuplot** and **imagemagick**.) [hmatrix]: http://code.haskell.org/hmatrix [hmatrix2]: http://perception.inf.um.es/hmatrix ## Linux ################################################## Ubuntu/Debian: $ sudo apt-get install libgsl0-dev liblapack-dev $ cabal install hmatrix Arch Linux: If the automatic installation from Hackage fails, install atlas-lapack and gsl, unpack the source, change the build-type to Simple in hmatrix.cabal (line 28) and add extra-libraries: gsl lapack (line 194). Other distributions may require additional libraries. They can be given in a **--configure-option**. ## Mac OS/X ############################################### GSL must be installed via MacPorts: $ sudo port install gsl-devel +universal $ cabal install hmatrix (Contributed by Heinrich Apfelmus and Torsten Kemps-Benedix). ## Windows ############################################### We use this [GSL binary](http://www.miscdebris.net/blog/2009/04/20/mingw-345-binaries-of-gnu-scientific-library-112-for-use-with-mingw-and-visual-c/), and blas/lapack dlls built with g77 (contributed by Gilberto Camara). All required files are in [gsl-lapack-windows.zip][winpack]. (Due to [issue 21](https://github.com/albertoruiz/hmatrix/issues/21) we need hmatrix-0.13.1.0.) 1) Install the Haskell Platform (tested on 2011.2.0.1) > cabal update 2) Download and unzip the following file into a stable folder %GSL% http://perception.inf.um.es/hmatrix/gsl-lapack-windows.zip 3.a) In a msys shell the installation should be fully automatic: $ cabal install hmatrix-0.13.1.0 --extra-lib-dir=${GSL} --extra-include-dir=${GSL} 3.b) Alternatively, in a normal windows cmd: > cabal unpack hmatrix-0.13.1.0 Edit hmatrix.cabal, in line 28 change build-type to "Simple", and then > cabal install --extra-lib-dir=%GSL% --extra-include-dir=%GSL% It may be necessary to put the dlls in the search path. NOTE: The examples using graphics do not yet work in windows. [install]: http://code.haskell.org/hmatrix/INSTALL [install2]: http://patch-tag.com/r/aruiz/hmatrix/snapshot/current/content/pretty/INSTALL [winpack2]: http://perception.inf.um.es/hmatrix/gsl-lapack-windows.zip [winpack]: https://github.com/downloads/AlbertoRuiz/hmatrix/gsl-lapack-windows.zip ## Tests ############################################### After installation we must verify that the library works as expected: $ cabal install hmatrix-tests --enable-tests $ ghci > Numeric.LinearAlgebra.Tests.runTests 20 OK, passed 100 tests. OK, passed 100 tests. ... etc... If you get any failure please run lapack's own tests to confirm that your version is not broken. For instance, in ubuntu 9.04, **libatlas-sse2** does not work (see this [bug report](https://bugs.launchpad.net/ubuntu/+source/atlas/+bug/368478)). If your lapack library is ok but hmatrix's tests fail please send a bug report! ## Optimized BLAS/LAPACK ########################################## I have successfully tested ATLAS and MKL on Linux. ### [ATLAS](http://math-atlas.sourceforge.net/) #################### In Ubuntu >= 9.04 we need: $ sudo apt-get install libatlas-base-dev In older Ubuntu/Debian versions we needed: $ sudo apt-get install refblas3-dev lapack3-dev atlas3-base-dev We may use a version (sse2, 3dnow, etc.) optimized for the machine. ### Intel's MKL ############################################### There is a free noncommercial download available from Intel's website. To use it I have added the following lines in my .bashrc configuration file: export LD_LIBRARY_PATH=/path/to/mkl/lib/arch export LIBRARY_PATH=/path/to/mkl/lib/arch where arch = 32 or em64t. The library must be installed with the -fmkl flag: $ cabal install hmatrix -fmkl hmatrix-0.15.0.0/Setup.lhs0000644000000000000000000000077112165764700013422 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > import Distribution.Simple.Setup > import Distribution.PackageDescription > import Distribution.Simple.LocalBuildInfo > import System.Process(system) > import Config(config) > main = defaultMainWithHooks simpleUserHooks { confHook = c } > c x y = do > binfo <- confHook simpleUserHooks x y > pbi <- config binfo > let pkg_descr = localPkgDescr binfo > return $ binfo { localPkgDescr = updatePackageDescription pbi pkg_descr } hmatrix-0.15.0.0/CHANGES.md0000644000000000000000000000626012165764700013203 0ustar00000000000000000.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.15.0.0/LICENSE0000644000000000000000000000005512165764700012612 0ustar0000000000000000Copyright Alberto Ruiz 2006-2007 GPL license hmatrix-0.15.0.0/Config.hs0000644000000000000000000001357012165764700013354 0ustar0000000000000000{- GSL and LAPACK may require auxiliary libraries which depend on OS, distribution, and implementation. This script tries to to find out the correct link command for your system. Suggestions and contributions are welcome. By default we try to link -lgsl -llapack. This works in ubuntu/debian, both with and without ATLAS. If this fails we try different sets of additional libraries which are known to work in some systems. The desired libraries can also be explicitly given by the user using cabal flags (e.g., -fmkl, -faccelerate) or --configure-option=link:lib1,lib2,lib3,... -} module Config(config) where import System.Process import System.Exit import System.Environment import System.Directory(createDirectoryIfMissing) import System.FilePath(()) import Data.List(isPrefixOf, intercalate) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Configure import Distribution.PackageDescription -- possible additional dependencies for the desired libs (by default gsl lapack) opts = [ "" -- Ubuntu/Debian , "blas" , "blas cblas" , "cblas" , "gslcblas" , "blas gslcblas" , "f77blas" , "f77blas cblas atlas gcc_s" -- Arch Linux (older version of atlas-lapack) , "blas gslcblas gfortran" -- Arch Linux with normal blas and lapack ] -- location of test program testProgLoc bInfo = buildDir bInfo "dummy.c" testOutLoc bInfo = buildDir bInfo "dummy" -- write test program writeTestProg bInfo contents = writeFile (testProgLoc bInfo) contents -- compile, discarding error messages compile cmd = do let processRecord = (shell $ join cmd) { std_out = CreatePipe , std_err = CreatePipe } ( _, _, _, h) <- createProcess processRecord waitForProcess h -- command to compile the test program compileCmd bInfo buildInfo = [ "gcc " , (join $ ccOptions buildInfo) , (join $ cppOptions buildInfo) , (join $ map ("-I"++) $ includeDirs buildInfo) , testProgLoc bInfo , "-o" , testOutLoc bInfo , (join $ map ("-L"++) $ extraLibDirs buildInfo) ] -- compile a simple program with symbols from GSL and LAPACK with the given libs testprog bInfo buildInfo libs fmks = do writeTestProg bInfo "#include \nint main(){dgemm_(); zgesvd_(); gsl_sf_gamma(5);}" compile $ compileCmd bInfo buildInfo ++ [ (prepend "-l" $ libs) , (prepend "-framework " fmks) ] join = intercalate " " prepend x = unwords . map (x++) . words check bInfo buildInfo libs fmks = (ExitSuccess ==) `fmap` testprog bInfo buildInfo libs fmks -- simple test for GSL gsl bInfo buildInfo = do writeTestProg bInfo "#include \nint main(){gsl_sf_gamma(5);}" compile $ compileCmd bInfo buildInfo ++ ["-lgsl", "-lgslcblas"] -- test for gsl >= 1.12 gsl112 bInfo buildInfo = do writeTestProg bInfo "#include \nint main(){gsl_sf_exprel_n_CF_e(1,1,0);}" compile $ compileCmd bInfo buildInfo ++ ["-lgsl", "-lgslcblas"] -- test for odeiv2 gslodeiv2 bInfo buildInfo = do writeTestProg bInfo "#include \nint main(){return 0;}" compile $ compileCmd bInfo buildInfo ++ ["-lgsl", "-lgslcblas"] checkCommand c = (ExitSuccess ==) `fmap` c -- test different configurations until the first one works try _ _ _ _ [] = return Nothing try l i b f (opt:rest) = do ok <- check l i (b ++ " " ++ opt) f if ok then return (Just opt) else try l i b f rest -- read --configure-option=link:lib1,lib2,lib3,etc linkop = "--configure-option=link:" getUserLink = concatMap (g . drop (length linkop)) . filter (isPrefixOf linkop) where g = map cs cs ',' = ' ' cs x = x config :: LocalBuildInfo -> IO HookedBuildInfo config bInfo = do putStr "Checking foreign libraries..." args <- getArgs let Just lib = library . localPkgDescr $ bInfo buildInfo = libBuildInfo lib base = unwords . extraLibs $ buildInfo fwks = unwords . frameworks $ buildInfo auxpref = getUserLink args -- We extract the desired libs from hmatrix.cabal (using a cabal flags) -- and from a posible --configure-option=link:lib1,lib2,lib3 -- by default the desired libs are gsl lapack. let pref = if null (words (base ++ " " ++ auxpref)) then "gsl lapack" else auxpref fullOpts = map ((pref++" ")++) opts -- create the build directory (used for tmp files) if necessary createDirectoryIfMissing True $ buildDir bInfo r <- try bInfo buildInfo base fwks fullOpts case r of Nothing -> do putStrLn " FAIL" g <- checkCommand $ gsl bInfo buildInfo if g then putStrLn " *** Sorry, I can't link LAPACK." else putStrLn " *** Sorry, I can't link GSL." putStrLn " *** Please make sure that the appropriate -dev packages are installed." putStrLn " *** You can also specify the required libraries using" putStrLn " *** cabal install hmatrix --configure-option=link:lib1,lib2,lib3,etc." return (Just emptyBuildInfo { buildable = False }, []) Just ops -> do putStrLn $ " OK " ++ ops g1 <- checkCommand $ gsl112 bInfo buildInfo let op1 = if g1 then "" else "-DGSL110" g2 <- checkCommand $ gslodeiv2 bInfo buildInfo let op2 = if g2 then "" else "-DGSLODE1" opts = filter (not.null) [op1,op2] let hbi = emptyBuildInfo { extraLibs = words ops, ccOptions = opts } return (Just hbi, []) hmatrix-0.15.0.0/hmatrix.cabal0000644000000000000000000001460712165764700014255 0ustar0000000000000000Name: hmatrix Version: 0.15.0.0 License: GPL License-file: LICENSE Author: Alberto Ruiz Maintainer: Alberto Ruiz Stability: provisional Homepage: https://github.com/albertoruiz/hmatrix Synopsis: Linear algebra and numerical computation Description: Purely functional interface to basic linear algebra and other numerical computations, internally implemented using GSL, BLAS and LAPACK. . The Linear Algebra API is organized as follows: . - "Data.Packed": structure manipulation . - "Numeric.Container": simple numeric functions . - "Numeric.LinearAlgebra.Algorithms": matrix computations . - "Numeric.LinearAlgebra": everything + instances of standard Haskell numeric classes Category: Math tested-with: GHC ==7.6 cabal-version: >=1.8 build-type: Custom extra-source-files: Config.hs THANKS.md INSTALL.md CHANGES.md extra-source-files: examples/deriv.hs examples/integrate.hs examples/minimize.hs examples/root.hs examples/ode.hs examples/pca1.hs examples/pca2.hs examples/pinv.hs examples/data.txt examples/lie.hs examples/kalman.hs examples/parallel.hs examples/plot.hs examples/inplace.hs examples/error.hs examples/fitting.hs examples/devel/ej1/wrappers.hs examples/devel/ej1/functions.c examples/devel/ej2/wrappers.hs examples/devel/ej2/functions.c examples/vector.hs examples/monadic.hs examples/bool.hs examples/multiply.hs extra-source-files: lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h, lib/Numeric/GSL/gsl-ode.c flag dd description: svd = zgesdd default: True flag mkl description: Link with Intel's MKL optimized libraries. default: False flag unsafe description: Compile the library with bound checking disabled. default: False flag finit description: Force FPU initialization in foreing calls default: False flag debugfpu description: Check FPU stack default: False flag debugnan description: Check NaN default: False library Build-Depends: base >= 4 && < 5, array, storable-complex, process, random, vector >= 0.8, binary, deepseq Extensions: ForeignFunctionInterface, CPP hs-source-dirs: lib Exposed-modules: Data.Packed, Data.Packed.Vector, Data.Packed.Matrix, Data.Packed.Foreign, Numeric.GSL.Differentiation, Numeric.GSL.Integration, Numeric.GSL.Fourier, Numeric.GSL.Polynomials, Numeric.GSL.Minimization, Numeric.GSL.Root, Numeric.GSL.Fitting, Numeric.GSL.ODE, Numeric.GSL, Numeric.Container, Numeric.LinearAlgebra, Numeric.LinearAlgebra.LAPACK, Numeric.LinearAlgebra.Algorithms, Numeric.LinearAlgebra.Util, Graphics.Plot, Data.Packed.ST, Data.Packed.Development other-modules: Data.Packed.Internal, Data.Packed.Internal.Common, Data.Packed.Internal.Signatures, Data.Packed.Internal.Vector, Data.Packed.Internal.Matrix, Data.Packed.Random, Numeric.GSL.Internal, Numeric.GSL.Vector, Numeric.Conversion, Numeric.ContainerBoot, Numeric.IO, Numeric.Chain, Numeric.Vector, Numeric.Matrix, Numeric.LinearAlgebra.Util.Convolution C-sources: lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c, lib/Numeric/GSL/gsl-aux.c cpp-options: -DBINARY -- ghc-prof-options: -auto ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans -fno-warn-unused-binds if flag(unsafe) cpp-options: -DUNSAFE if !flag(dd) cpp-options: -DNOZGESDD if impl(ghc < 6.10.2) cpp-options: -DFINIT if impl(ghc == 7.0.1) cpp-options: -DFINIT if impl(ghc == 7.0.2) cpp-options: -DFINIT if flag(finit) cpp-options: -DFINIT if flag(debugfpu) cc-options: -DFPUDEBUG if flag(debugnan) cc-options: -DNANDEBUG if impl(ghc == 7.0.1) cpp-options: -DNONORMVTEST if flag(mkl) if arch(x86_64) extra-libraries: gsl mkl_lapack mkl_intel_lp64 mkl_sequential mkl_core else extra-libraries: gsl mkl_lapack mkl_intel mkl_sequential mkl_core if os(OSX) extra-lib-dirs: /opt/local/lib/ include-dirs: /opt/local/include/ extra-lib-dirs: /usr/local/lib/ include-dirs: /usr/local/include/ extra-libraries: gsl if arch(i386) cc-options: -arch i386 frameworks: Accelerate if os(windows) extra-libraries: gsl-0 blas lapack -- The extra-libraries required for GSL and LAPACK -- should now be automatically detected by configure(.hs) extra-libraries: extra-lib-dirs: source-repository head type: git location: https://github.com/albertoruiz/hmatrix -- The tests are in package hmatrix-tests hmatrix-0.15.0.0/THANKS.md0000644000000000000000000001163712165764700013127 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. - 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. - 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. - Mike Ledger contributed alternative FFI helpers for matrix interoperation with C - Stephen J. Barr suggested flipping argument order in the double integral example hmatrix-0.15.0.0/examples/0000755000000000000000000000000012165764700013423 5ustar0000000000000000hmatrix-0.15.0.0/examples/multiply.hs0000644000000000000000000000440012165764700015634 0ustar0000000000000000{-# LANGUAGE UnicodeSyntax , MultiParamTypeClasses , FunctionalDependencies , FlexibleInstances , FlexibleContexts -- , OverlappingInstances , UndecidableInstances #-} import Numeric.LinearAlgebra class Scaling a b c | a b -> c where -- ^ 0x22C5 8901 DOT OPERATOR, scaling infixl 7 ⋅ (⋅) :: a -> b -> c class Contraction a b c | a b -> c where -- ^ 0x00D7 215 MULTIPLICATION SIGN ×, contraction infixl 7 × (×) :: a -> b -> c class Outer a b c | a b -> c where -- ^ 0x2297 8855 CIRCLED TIMES ⊗, outer product (not associative) infixl 7 ⊗ (⊗) :: a -> b -> c ------- instance (Num t) => Scaling t t t where (⋅) = (*) instance Container Vector t => Scaling t (Vector t) (Vector t) where (⋅) = scale instance Container Vector t => Scaling (Vector t) t (Vector t) where (⋅) = flip scale instance Container Vector t => Scaling t (Matrix t) (Matrix t) where (⋅) = scale instance Container Vector t => Scaling (Matrix t) t (Matrix t) where (⋅) = flip scale instance Product t => Contraction (Vector t) (Vector t) t where (×) = dot instance Product t => Contraction (Matrix t) (Vector t) (Vector t) where (×) = mXv instance Product t => Contraction (Vector t) (Matrix t) (Vector t) where (×) = vXm instance Product t => Contraction (Matrix t) (Matrix t) (Matrix t) where (×) = mXm --instance Scaling a b c => Contraction a b c where -- (×) = (⋅) ----- instance Product t => Outer (Vector t) (Vector t) (Matrix t) where (⊗) = outer instance Product t => Outer (Vector t) (Matrix t) (Matrix t) where v ⊗ m = kronecker (asColumn v) m instance Product t => Outer (Matrix t) (Vector t) (Matrix t) where m ⊗ v = kronecker m (asRow v) instance Product t => Outer (Matrix t) (Matrix t) (Matrix t) where (⊗) = kronecker ----- v = 3 |> [1..] :: Vector Double m = (3 >< 3) [1..] :: Matrix Double s = 3 :: Double a = s ⋅ v × m × m × v ⋅ s b = (v ⊗ m) ⊗ (v ⊗ m) c = v ⊗ m ⊗ v ⊗ m d = s ⋅ (3 |> [10,20..] :: Vector Double) main = do print $ scale s v <> m <.> v print $ scale s v <.> (m <> v) print $ s * (v <> m <.> v) print $ s ⋅ v × m × v print a print (b == c) print d hmatrix-0.15.0.0/examples/inplace.hs0000644000000000000000000000670612165764700015403 0ustar0000000000000000-- some tests of the interface for pure -- computations with inplace updates import Numeric.LinearAlgebra import Data.Packed.ST import Data.Packed.Convert import Data.Array.Unboxed import Data.Array.ST import Control.Monad.ST import Control.Monad main = sequence_[ print test1, print test2, print test3, print test4, test5, test6, print test7, test8, test0] -- helper functions vector l = fromList l :: Vector Double norm v = pnorm PNorm2 v -- hmatrix vector and matrix v = vector [1..10] m = (5><10) [1..50::Double] ---------------------------------------------------------------------- -- vector creation by in-place updates on a copy of the argument test1 = fun v fun :: Element t => Vector t -> Vector t fun x = runSTVector $ do a <- thawVector x mapM_ (flip (modifyVector a) (+57)) [0 .. dim x `div` 2 - 1] return a -- another example: creation of an antidiagonal matrix from a list test2 = antiDiag 5 8 [1..] :: Matrix Double antiDiag :: (Element b) => Int -> Int -> [b] -> Matrix b antiDiag r c l = runSTMatrix $ do m <- newMatrix 0 r c let d = min r c - 1 sequence_ $ zipWith (\i v -> writeMatrix m i (c-1-i) v) [0..d] l return m -- using vector or matrix functions on mutable objects requires freezing: test3 = g1 v g1 x = runST $ do a <- thawVector x writeVector a (dim x -1) 0 b <- freezeVector a return (norm b) -- another possibility: test4 = g2 v g2 x = runST $ do a <- thawVector x writeVector a (dim x -1) 0 t <- liftSTVector norm a return t -------------------------------------------------------------- -- haskell arrays hv = listArray (0,9) [1..10::Double] hm = listArray ((0,0),(4,9)) [1..50::Double] -- conversion from standard Haskell arrays test5 = do print $ norm (vectorFromArray hv) print $ norm v print $ rcond (matrixFromArray hm) print $ rcond m -- conversion to mutable ST arrays test6 = do let y = clearColumn m 1 print y print (matrixFromArray y) clearColumn x c = runSTUArray $ do a <- mArrayFromMatrix x forM_ [0..rows x-1] $ \i-> writeArray a (i,c) (0::Double) return a -- hmatrix functions applied to mutable ST arrays test7 = unitary (listArray (1,4) [3,5,7,2] :: UArray Int Double) unitary v = runSTUArray $ do a <- thaw v n <- norm `fmap` vectorFromMArray a b <- mapArray (/n) a return b ------------------------------------------------- -- (just to check that they are not affected) test0 = do print v print m --print hv --print hm ------------------------------------------------- histogram n ds = runSTVector $ do h <- newVector (0::Double) n -- number of bins let inc k = modifyVector h k (+1) mapM_ inc ds return h -- check that newVector is really called with a fresh new array histoCheck ds = runSTVector $ do h <- newVector (0::Double) 15 -- > constant for this test let inc k = modifyVector h k (+1) mapM_ inc ds return h hc = fromList [1 .. 15::Double] -- check that thawVector creates a new array histoCheck2 ds = runSTVector $ do h <- thawVector hc let inc k = modifyVector h k (+1) mapM_ inc ds return h test8 = do let ds = [0..14] print $ histogram 15 ds print $ histogram 15 ds print $ histogram 15 ds print $ histoCheck ds print $ histoCheck ds print $ histoCheck ds print $ histoCheck2 ds print $ histoCheck2 ds print $ histoCheck2 ds putStrLn "----------------------" hmatrix-0.15.0.0/examples/data.txt0000644000000000000000000000016712165764700015101 0ustar0000000000000000 0.9 1.1 2.1 3.9 3.1 9.2 4.0 51.8 4.9 25.3 6.1 35.7 7.0 49.4 7.9 3.6 9.1 81.5 10.2 99.5hmatrix-0.15.0.0/examples/pca2.hs0000644000000000000000000000375512165764700014616 0ustar0000000000000000-- Improved PCA, including illustrative graphics import Numeric.LinearAlgebra import Graphics.Plot import System.Directory(doesFileExist) import System.Process(system) import Control.Monad(when) type Vec = Vector Double type Mat = Matrix Double -- Vector with the mean value of the columns of a matrix mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a -- covariance matrix of a list of observations stored as rows cov x = (trans xc <> xc) / fromIntegral (rows x - 1) where xc = x - asRow (mean x) type Stat = (Vec, [Double], Mat) -- 1st and 2nd order statistics of a dataset (mean, eigenvalues and eigenvectors of cov) stat :: Mat -> Stat stat x = (m, toList s, trans v) where m = mean x (s,v) = eigSH' (cov x) -- creates the compression and decompression functions from the desired reconstruction -- quality and the statistics of a data set pca :: Double -> Stat -> (Vec -> Vec , Vec -> Vec) pca prec (m,s,v) = (encode,decode) where encode x = vp <> (x - m) decode x = x <> vp + m vp = takeRows n v n = 1 + (length $ fst $ span (< (prec'*sum s)) $ cumSum s) cumSum = tail . scanl (+) 0.0 prec' = if prec <=0.0 || prec >= 1.0 then error "the precision in pca must be 0 IO () shdigit v = imshow (reshape 28 (-v)) -- shows the effect of a given reconstruction quality on a test vector test :: Stat -> Double -> Vec -> IO () test st prec x = do let (pe,pd) = pca prec st let y = pe x print $ dim y shdigit (pd y) main = do ok <- doesFileExist ("mnist.txt") when (not ok) $ do putStrLn "\nTrying to download test datafile..." system("wget -nv http://dis.um.es/~alberto/material/sp/mnist.txt.gz") system("gunzip mnist.txt.gz") return () m <- loadMatrix "mnist.txt" let xs = takeColumns (cols m -1) m let x = toRows xs !! 4 -- an arbitrary test vector shdigit x let st = stat xs test st 0.90 x test st 0.50 x hmatrix-0.15.0.0/examples/pinv.hs0000644000000000000000000000121612165764700014733 0ustar0000000000000000import Numeric.LinearAlgebra import Graphics.Plot import Text.Printf(printf) expand :: Int -> Vector Double -> Matrix Double expand n x = fromColumns $ map (x^) [0 .. n] polynomialModel :: Vector Double -> Vector Double -> Int -> (Vector Double -> Vector Double) polynomialModel x y n = f where f z = expand n z <> ws ws = expand n x <\> y main = do [x,y] <- (toColumns . readMatrix) `fmap` readFile "data.txt" let pol = polynomialModel x y let view = [x, y, pol 1 x, pol 2 x, pol 3 x] putStrLn $ " x y p 1 p 2 p 3" putStrLn $ format " " (printf "%.2f") $ fromColumns view mplot view hmatrix-0.15.0.0/examples/plot.hs0000644000000000000000000000073212165764700014737 0ustar0000000000000000import Numeric.LinearAlgebra import Graphics.Plot import Numeric.GSL.Special(erf_Z, erf) sombrero n = f x y where (x,y) = meshdom range range range = linspace n (-2,2) f x y = exp (-r2) * cos (2*r2) where r2 = x*x+y*y f x = sin x + 0.5 * sin (5*x) gaussianPDF = erf_Z cumdist x = 0.5 * (1+ erf (x/sqrt 2)) main = do let x = linspace 1000 (-4,4) mplot [f x] mplot [x, mapVector cumdist x, mapVector gaussianPDF x] mesh (sombrero 40)hmatrix-0.15.0.0/examples/ode.hs0000644000000000000000000000253612165764700014534 0ustar0000000000000000{-# LANGUAGE ViewPatterns #-} import Numeric.GSL.ODE import Numeric.LinearAlgebra import Graphics.Plot import Debug.Trace(trace) debug x = trace (show x) x vanderpol mu = do let xdot mu t [x,v] = [v, -x + mu * v * (1-x^2)] ts = linspace 1000 (0,50) sol = toColumns $ odeSolve (xdot mu) [1,0] ts mplot (ts : sol) mplot sol harmonic w d = do let xdot w d t [x,v] = [v, a*x + b*v] where a = -w^2; b = -2*d*w ts = linspace 100 (0,20) sol = odeSolve (xdot w d) [1,0] ts mplot (ts : toColumns sol) kepler v a = mplot (take 2 $ toColumns sol) where xdot t [x,y,vx,vy] = [vx,vy,x*k,y*k] where g=1 k=(-g)*(x*x+y*y)**(-1.5) ts = linspace 100 (0,30) sol = odeSolve xdot [4, 0, v * cos (a*degree), v * sin (a*degree)] ts degree = pi/180 main = do vanderpol 2 harmonic 1 0 harmonic 1 0.1 kepler 0.3 60 kepler 0.4 70 vanderpol' 2 -- example of odeSolveV with jacobian vanderpol' mu = do let xdot mu t (toList->[x,v]) = fromList [v, -x + mu * v * (1-x^2)] jac t (toList->[x,v]) = (2><2) [ 0 , 1 , -1-2*x*v*mu, mu*(1-x**2) ] ts = linspace 1000 (0,50) hi = (ts@>1 - ts@>0)/100 sol = toColumns $ odeSolveV (MSBDF jac) hi 1E-8 1E-8 (xdot mu) (fromList [1,0]) ts mplot sol hmatrix-0.15.0.0/examples/bool.hs0000644000000000000000000000254012165764700014713 0ustar0000000000000000-- vectorized boolean operations defined in terms of step or cond import Numeric.LinearAlgebra infix 4 .==., ./=., .<., .<=., .>=., .>. infixr 3 .&&. infixr 2 .||. a .<. b = step (b-a) a .<=. b = cond a b 1 1 0 a .==. b = cond a b 0 1 0 a ./=. b = cond a b 1 0 1 a .>=. b = cond a b 0 1 1 a .>. b = step (a-b) a .&&. b = step (a*b) a .||. b = step (a+b) no a = 1-a xor a b = a ./=. b equiv a b = a .==. b imp a b = no a .||. b taut x = minElement x == 1 minEvery a b = cond a b a a b maxEvery a b = cond a b b b a -- examples clip a b x = cond y b y y b where y = cond x a a x x disp = putStr . dispf 3 eye n = ident n :: Matrix Double row = asRow . fromList :: [Double] -> Matrix Double col = asColumn . fromList :: [Double] -> Matrix Double m = (3><4) [1..] :: Matrix Double p = row [0,0,1,1] q = row [0,1,0,1] main = do print $ find (>6) m disp $ assoc (6,8) 7 $ zip (find (/=0) (eye 5)) [10..] disp $ accum (eye 5) (+) [((0,2),3), ((3,1),7), ((1,1),1)] disp $ m .>=. 10 .||. m .<. 4 (disp . fromColumns . map flatten) [p, q, p.&&.q, p .||.q, p `xor` q, p `equiv` q, p `imp` q] print $ taut $ (p `imp` q ) `equiv` (no q `imp` no p) print $ taut $ (xor p q) `equiv` (p .&&. no q .||. no p .&&. q) disp $ clip 3 8 m disp $ col [1..7] .<=. row [1..5] disp $ cond (col [1..3]) (row [1..4]) m 50 (3*m) hmatrix-0.15.0.0/examples/vector.hs0000644000000000000000000000162312165764700015263 0ustar0000000000000000-- conversion to/from Data.Vector.Storable -- from Roman Leshchinskiy "vector" package -- -- In the future Data.Packed.Vector will be replaced by Data.Vector.Storable ------------------------------------------- import Numeric.LinearAlgebra as H import Data.Packed.Development(unsafeFromForeignPtr, unsafeToForeignPtr) import Foreign.Storable import qualified Data.Vector.Storable as V fromVector :: Storable t => V.Vector t -> H.Vector t fromVector v = unsafeFromForeignPtr p i n where (p,i,n) = V.unsafeToForeignPtr v toVector :: Storable t => H.Vector t -> V.Vector t toVector v = V.unsafeFromForeignPtr p i n where (p,i,n) = unsafeToForeignPtr v ------------------------------------------- v = V.slice 5 10 (V.fromList [1 .. 10::Double] V.++ V.replicate 10 7) w = subVector 2 3 (linspace 5 (0,1)) :: Vector Double main = do print v print $ fromVector v print w print $ toVector w hmatrix-0.15.0.0/examples/kalman.hs0000644000000000000000000000274612165764700015233 0ustar0000000000000000import Numeric.LinearAlgebra import Graphics.Plot vector l = fromList l :: Vector Double matrix ls = fromLists ls :: Matrix Double diagl = diag . vector f = matrix [[1,0,0,0], [1,1,0,0], [0,0,1,0], [0,0,0,1]] h = matrix [[0,-1,1,0], [0,-1,0,1]] q = diagl [1,1,0,0] r = diagl [2,2] s0 = State (vector [0, 0, 10, -10]) (diagl [10,0, 100, 100]) data System = System {kF, kH, kQ, kR :: Matrix Double} data State = State {sX :: Vector Double , sP :: Matrix Double} type Measurement = Vector Double kalman :: System -> State -> Measurement -> State kalman (System f h q r) (State x p) z = State x' p' where px = f <> x -- prediction pq = f <> p <> trans f + q -- its covariance y = z - h <> px -- residue cy = h <> pq <> trans h + r -- its covariance k = pq <> trans h <> inv cy -- kalman gain x' = px + k <> y -- new state p' = (ident (dim x) - k <> h) <> pq -- its covariance sys = System f h q r zs = [vector [15-k,-20-k] | k <- [0..]] xs = s0 : zipWith (kalman sys) xs zs des = map (sqrt.takeDiag.sP) xs evolution n (xs,des) = vector [1.. fromIntegral n]:(toColumns $ fromRows $ take n (zipWith (-) (map sX xs) des)) ++ (toColumns $ fromRows $ take n (zipWith (+) (map sX xs) des)) main = do print $ fromRows $ take 10 (map sX xs) mapM_ (print . sP) $ take 10 xs mplot (evolution 20 (xs,des)) hmatrix-0.15.0.0/examples/deriv.hs0000644000000000000000000000026212165764700015070 0ustar0000000000000000-- Numerical differentiation import Numeric.GSL d :: (Double -> Double) -> (Double -> Double) d f x = fst $ derivCentral 0.01 f x main = print $ d (\x-> x * d (\y-> x+y) 1) 1 hmatrix-0.15.0.0/examples/integrate.hs0000644000000000000000000000111512165764700015737 0ustar0000000000000000-- Numerical integration import Numeric.GSL quad f a b = fst $ integrateQAGS 1E-9 100 f a b -- A multiple integral can be easily defined using partial application quad2 f y1 y2 g1 g2 = quad h y1 y2 where h y = quad (flip f y) (g1 y) (g2 y) volSphere r = 8 * quad2 (\x y -> sqrt (r*r-x*x-y*y)) 0 r (const 0) (\x->sqrt (r*r-x*x)) -- wikipedia example exw = quad2 f 7 10 (const 11) (const 14) where f x y = x**2 + 4*y main = do print $ quad (\x -> 4/(x^2+1)) 0 1 print pi print $ volSphere 2.5 print $ 4/3*pi*2.5**3 print $ exw hmatrix-0.15.0.0/examples/fitting.hs0000644000000000000000000000114312165764700015422 0ustar0000000000000000-- nonlinear least-squares fitting import Numeric.GSL.Fitting import Numeric.LinearAlgebra xs = map return [0 .. 39] sigma = 0.1 ys = map return $ toList $ fromList (map (head . expModel [5,0.1,1]) xs) + scalar sigma * (randomVector 0 Gaussian 40) dat :: [([Double],([Double],Double))] dat = zip xs (zip ys (repeat sigma)) expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b] expModelDer [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]] (sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0] main = do print dat print path print sol hmatrix-0.15.0.0/examples/error.hs0000644000000000000000000000074512165764700015116 0ustar0000000000000000import Numeric.GSL import Numeric.GSL.Special import Numeric.LinearAlgebra import Prelude hiding (catch) import Control.Exception test x = catch (print x) (\e -> putStrLn $ "captured ["++ show (e :: SomeException) ++"]") main = do setErrorHandlerOff test $ log_e (-1) test $ 5 + (fst.exp_e) 1000 test $ bessel_zero_Jnu_e (-0.3) 2 test $ (linearSolve 0 4 :: Matrix Double) test $ (linearSolve 5 (sqrt (-1)) :: Matrix Double) putStrLn "Bye"hmatrix-0.15.0.0/examples/lie.hs0000644000000000000000000000216712165764700014536 0ustar0000000000000000-- The magic of Lie Algebra import Numeric.LinearAlgebra disp = putStrLn . dispf 5 rot1 :: Double -> Matrix Double rot1 a = (3><3) [ 1, 0, 0 , 0, c, s , 0,-s, c ] where c = cos a s = sin a g1,g2,g3 :: Matrix Double g1 = (3><3) [0, 0,0 ,0, 0,1 ,0,-1,0] rot2 :: Double -> Matrix Double rot2 a = (3><3) [ c, 0, s , 0, 1, 0 ,-s, 0, c ] where c = cos a s = sin a g2 = (3><3) [ 0,0,1 , 0,0,0 ,-1,0,0] rot3 :: Double -> Matrix Double rot3 a = (3><3) [ c, s, 0 ,-s, c, 0 , 0, 0, 1 ] where c = cos a s = sin a g3 = (3><3) [ 0,1,0 ,-1,0,0 , 0,0,0] deg=pi/180 -- commutator infix 8 & a & b = a <> b - b <> a infixl 6 |+| a |+| b = a + b + a&b /2 + (a-b)&(a & b) /12 main = do let a = 45*deg b = 50*deg c = -30*deg exact = rot3 a <> rot1 b <> rot2 c lie = scalar a * g3 |+| scalar b * g1 |+| scalar c * g2 putStrLn "position in the tangent space:" disp lie putStrLn "exponential map back to the group (2 terms):" disp (expm lie) putStrLn "exact position:" disp exact hmatrix-0.15.0.0/examples/root.hs0000644000000000000000000000125612165764700014746 0ustar0000000000000000-- root finding examples import Numeric.GSL import Numeric.LinearAlgebra import Text.Printf(printf) rosenbrock a b [x,y] = [ a*(1-x), b*(y-x^2) ] test method = do print method let (s,p) = root method 1E-7 30 (rosenbrock 1 10) [-10,-5] print s -- solution disp p -- evolution of the algorithm jacobian a b [x,y] = [ [-a , 0] , [-2*b*x, b] ] testJ method = do print method let (s,p) = rootJ method 1E-7 30 (rosenbrock 1 10) (jacobian 1 10) [-10,-5] print s disp p disp = putStrLn . format " " (printf "%.3f") main = do test Hybrids test Hybrid test DNewton test Broyden mapM_ testJ [HybridsJ .. GNewton] hmatrix-0.15.0.0/examples/monadic.hs0000644000000000000000000000676612165764700015410 0ustar0000000000000000-- monadic computations -- (contributed by Vivian McPhail) import Numeric.LinearAlgebra import Control.Monad.State.Strict import Control.Monad.Maybe import Foreign.Storable(Storable) import System.Random(randomIO) ------------------------------------------- -- an instance of MonadIO, a monad transformer type VectorMonadT = StateT Int IO test1 :: Vector Int -> IO (Vector Int) test1 = mapVectorM $ \x -> do putStr $ (show x) ++ " " return (x + 1) -- we can have an arbitrary monad AND do IO addInitialM :: Vector Int -> VectorMonadT () addInitialM = mapVectorM_ $ \x -> do i <- get liftIO $ putStr $ (show $ x + i) ++ " " put $ x + i -- sum the values of the even indiced elements sumEvens :: Vector Int -> Int sumEvens = foldVectorWithIndex (\x a b -> if x `mod` 2 == 0 then a + b else b) 0 -- sum and print running total of evens sumEvensAndPrint :: Vector Int -> VectorMonadT () sumEvensAndPrint = mapVectorWithIndexM_ $ \ i x -> do when (i `mod` 2 == 0) $ do v <- get put $ v + x v' <- get liftIO $ putStr $ (show v') ++ " " indexPlusSum :: Vector Int -> VectorMonadT () indexPlusSum v' = do let f i x = do s <- get let inc = x+s liftIO $ putStr $ show (i,inc) ++ " " put inc return inc v <- mapVectorWithIndexM f v' liftIO $ do putStrLn "" putStrLn $ show v ------------------------------------------- -- short circuit monoStep :: Double -> MaybeT (State Double) () monoStep d = do dp <- get when (d < dp) (fail "negative difference") put d {-# INLINE monoStep #-} isMonotoneIncreasing :: Vector Double -> Bool isMonotoneIncreasing v = let res = evalState (runMaybeT $ (mapVectorM_ monoStep v)) (v @> 0) in case res of Nothing -> False Just _ -> True ------------------------------------------- -- | apply a test to successive elements of a vector, evaluates to true iff test passes for all pairs successive_ :: Storable a => (a -> a -> Bool) -> Vector a -> Bool successive_ t v = maybe False (\_ -> True) $ evalState (runMaybeT (mapVectorM_ step (subVector 1 (dim v - 1) v))) (v @> 0) where step e = do ep <- lift $ get if t e ep then lift $ put e else (fail "successive_ test failed") -- | operate on successive elements of a vector and return the resulting vector, whose length 1 less than that of the input successive :: (Storable a, Storable b) => (a -> a -> b) -> Vector a -> Vector b successive f v = evalState (mapVectorM step (subVector 1 (dim v - 1) v)) (v @> 0) where step e = do ep <- get put e return $ f ep e ------------------------------------------- v :: Vector Int v = 10 |> [0..] w = fromList ([1..10]++[10,9..1]) :: Vector Double main = do v' <- test1 v putStrLn "" putStrLn $ show v' evalStateT (addInitialM v) 0 putStrLn "" putStrLn $ show (sumEvens v) evalStateT (sumEvensAndPrint v) 0 putStrLn "" evalStateT (indexPlusSum v) 0 putStrLn "-----------------------" mapVectorM_ print v print =<< (mapVectorM (const randomIO) v :: IO (Vector Double)) print =<< (mapVectorM (\a -> fmap (+a) randomIO) (5|>[0,100..1000]) :: IO (Vector Double)) putStrLn "-----------------------" print $ isMonotoneIncreasing w print $ isMonotoneIncreasing (subVector 0 7 w) print $ successive_ (>) v print $ successive_ (>) w print $ successive (+) v hmatrix-0.15.0.0/examples/parallel.hs0000644000000000000000000000151712165764700015557 0ustar0000000000000000-- $ ghc --make -O -rtsopts -threaded parallel.hs -- $ ./parallel 3000 +RTS -N4 -s -A200M import System.Environment(getArgs) import Numeric.LinearAlgebra import Control.Parallel.Strategies import System.Time inParallel = parMap rwhnf id -- matrix product decomposed into p parallel subtasks parMul p x y = fromBlocks [ inParallel ( map (x <>) ys ) ] where [ys] = toBlocksEvery (rows y) (cols y `div` p) y main = do n <- (read . head) `fmap` getArgs let m = ident n :: Matrix Double time $ print $ maxElement $ takeDiag $ m <> m time $ print $ maxElement $ takeDiag $ parMul 2 m m time $ print $ maxElement $ takeDiag $ parMul 4 m m time $ print $ maxElement $ takeDiag $ parMul 8 m m time act = do t0 <- getClockTime act t1 <- getClockTime print $ tdSec $ normalizeTimeDiff $ diffClockTimes t1 t0 hmatrix-0.15.0.0/examples/minimize.hs0000644000000000000000000000247412165764700015607 0ustar0000000000000000-- the multidimensional minimization example in the GSL manual import Numeric.GSL import Numeric.LinearAlgebra import Graphics.Plot import Text.Printf(printf) -- the function to be minimized f [x,y] = 10*(x-1)^2 + 20*(y-2)^2 + 30 -- exact gradient df [x,y] = [20*(x-1), 40*(y-2)] -- a minimization algorithm which does not require the gradient minimizeS f xi = minimize NMSimplex2 1E-2 100 (replicate (length xi) 1) f xi -- Numerical estimation of the gradient gradient f v = [partialDerivative k f v | k <- [0 .. length v -1]] partialDerivative n f v = fst (derivCentral 0.01 g (v!!n)) where g x = f (concat [a,x:b]) (a,_:b) = splitAt n v disp = putStrLn . format " " (printf "%.3f") allMethods :: (Enum a, Bounded a) => [a] allMethods = [minBound .. maxBound] test method = do print method let (s,p) = minimize method 1E-2 30 [1,1] f [5,7] print s disp p testD method = do print method let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f df [5,7] print s disp p testD' method = do putStrLn $ show method ++ " with estimated gradient" let (s,p) = minimizeD method 1E-3 30 1E-2 1E-4 f (gradient f) [5,7] print s disp p main = do mapM_ test [NMSimplex, NMSimplex2] mapM_ testD allMethods testD' ConjugateFR mplot $ drop 3 . toColumns . snd $ minimizeS f [5,7] hmatrix-0.15.0.0/examples/pca1.hs0000644000000000000000000000265312165764700014611 0ustar0000000000000000-- Principal component analysis import Numeric.LinearAlgebra import System.Directory(doesFileExist) import System.Process(system) import Control.Monad(when) type Vec = Vector Double type Mat = Matrix Double -- Vector with the mean value of the columns of a matrix mean a = constant (recip . fromIntegral . rows $ a) (rows a) <> a -- covariance matrix of a list of observations stored as rows cov x = (trans xc <> xc) / fromIntegral (rows x - 1) where xc = x - asRow (mean x) -- creates the compression and decompression functions from the desired number of components pca :: Int -> Mat -> (Vec -> Vec , Vec -> Vec) pca n dataSet = (encode,decode) where encode x = vp <> (x - m) decode x = x <> vp + m m = mean dataSet c = cov dataSet (_,v) = eigSH' c vp = takeRows n (trans v) norm = pnorm PNorm2 main = do ok <- doesFileExist ("mnist.txt") when (not ok) $ do putStrLn "\nTrying to download test datafile..." system("wget -nv http://dis.um.es/~alberto/material/sp/mnist.txt.gz") system("gunzip mnist.txt.gz") return () m <- loadMatrix "mnist.txt" -- fromFile "mnist.txt" (5000,785) let xs = takeColumns (cols m -1) m -- the last column is the digit type (class label) let x = toRows xs !! 4 -- an arbitrary test Vec let (pe,pd) = pca 10 xs let y = pe x print y -- compressed version print $ norm (x - pd y) / norm x --reconstruction quality hmatrix-0.15.0.0/examples/devel/0000755000000000000000000000000012165764700014522 5ustar0000000000000000hmatrix-0.15.0.0/examples/devel/ej1/0000755000000000000000000000000012165764700015201 5ustar0000000000000000hmatrix-0.15.0.0/examples/devel/ej1/wrappers.hs0000644000000000000000000000246112165764700017403 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} -- $ ghc -O2 --make wrappers.hs functions.c import Numeric.LinearAlgebra import Data.Packed.Development import Foreign(Ptr,unsafePerformIO) import Foreign.C.Types(CInt) ----------------------------------------------------- main = do print $ myScale 3.0 (fromList [1..10]) print $ myDiag $ (3><5) [1..] ----------------------------------------------------- foreign import ccall unsafe "c_scale_vector" cScaleVector :: Double -- scale -> CInt -> Ptr Double -- argument -> CInt -> Ptr Double -- result -> IO CInt -- exit code myScale s x = unsafePerformIO $ do y <- createVector (dim x) app2 (cScaleVector s) vec x vec y "cScaleVector" return y ----------------------------------------------------- -- forcing row order foreign import ccall unsafe "c_diag" cDiag :: CInt -> CInt -> Ptr Double -- argument -> CInt -> Ptr Double -- result1 -> CInt -> CInt -> Ptr Double -- result2 -> IO CInt -- exit code myDiag m = unsafePerformIO $ do y <- createVector (min r c) z <- createMatrix RowMajor r c app3 cDiag mat (cmat m) vec y mat z "cDiag" return (y,z) where r = rows m c = cols m hmatrix-0.15.0.0/examples/devel/ej1/functions.c0000644000000000000000000000144412165764700017360 0ustar0000000000000000/* assuming row order */ typedef struct { double r, i; } doublecomplex; #define DVEC(A) int A##n, double*A##p #define CVEC(A) int A##n, doublecomplex*A##p #define DMAT(A) int A##r, int A##c, double*A##p #define CMAT(A) int A##r, int A##c, doublecomplex*A##p #define AT(M,row,col) (M##p[(row)*M##c + (col)]) /*-----------------------------------------------------*/ int c_scale_vector(double s, DVEC(x), DVEC(y)) { int k; for (k=0; k<=yn; k++) { yp[k] = s*xp[k]; } return 0; } /*-----------------------------------------------------*/ int c_diag(DMAT(m),DVEC(y),DMAT(z)) { int i,j; for (j=0; j<5) [1..] ----------------------------------------------------- -- arbitrary data order foreign import ccall unsafe "c_diag" cDiag :: CInt -- matrix order -> CInt -> CInt -> Ptr Double -- argument -> CInt -> Ptr Double -- result1 -> CInt -> CInt -> Ptr Double -- result2 -> IO CInt -- exit code myDiag m = unsafePerformIO $ do y <- createVector (min r c) z <- createMatrix (orderOf m) r c app3 (cDiag o) mat m vec y mat z "cDiag" return (y,z) where r = rows m c = cols m o = if orderOf m == RowMajor then 1 else 0 hmatrix-0.15.0.0/examples/devel/ej2/functions.c0000644000000000000000000000115512165764700017360 0ustar0000000000000000/* general element order */ typedef struct { double r, i; } doublecomplex; #define DVEC(A) int A##n, double*A##p #define CVEC(A) int A##n, doublecomplex*A##p #define DMAT(A) int A##r, int A##c, double*A##p #define CMAT(A) int A##r, int A##c, doublecomplex*A##p #define AT(M,r,c) (M##p[(r)*sr+(c)*sc]) int c_diag(int ro, DMAT(m),DVEC(y),DMAT(z)) { int i,j,sr,sc; if (ro==1) { sr = mc; sc = 1;} else { sr = 1; sc = mr;} for (j=0; j gmail.com> -- Stability : provisional -- Portability : portable -- -- optimisation of association order for chains of matrix multiplication -- ----------------------------------------------------------------------------- module Numeric.Chain ( optimiseMult, ) where import Data.Maybe import Data.Packed.Matrix import Numeric.ContainerBoot 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.15.0.0/lib/Numeric/Vector.hs0000644000000000000000000001151712165764700015560 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vector -- Copyright : (c) Alberto Ruiz 2011 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Vector'. -- ----------------------------------------------------------------------------- module Numeric.Vector () where import Numeric.GSL.Vector import Numeric.Container ------------------------------------------------------------------- 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 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 (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.15.0.0/lib/Numeric/ContainerBoot.hs0000644000000000000000000004320612165764700017064 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.ContainerBoot -- Copyright : (c) Alberto Ruiz 2010 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- Module to avoid cyclyc dependencies. -- ----------------------------------------------------------------------------- module Numeric.ContainerBoot ( -- * Basic functions ident, diag, ctrans, -- * Generic operations Container(..), -- * Matrix product and related functions Product(..), mXm,mXv,vXm, outer, kronecker, -- * Element conversion Convert(..), Complexable(), RealElement(), RealOf, ComplexOf, SingleOf, DoubleOf, IndexOf, module Data.Complex, -- * Experimental build', konst' ) where import Data.Packed import Data.Packed.ST as ST import Numeric.Conversion import Data.Packed.Internal import Numeric.GSL.Vector import Data.Complex import Control.Monad(ap) import Numeric.LinearAlgebra.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ) ------------------------------------------------------------------- type family IndexOf (c :: * -> *) type instance IndexOf Vector = Int type instance IndexOf Matrix = (Int,Int) type family ArgOf (c :: * -> *) a type instance ArgOf Vector a = a -> a type instance ArgOf Matrix a = a -> a -> a ------------------------------------------------------------------- -- | Basic element-by-element functions for numeric containers class (Complexable c, Fractional e, Element e) => Container c e where -- | create a structure with a single element scalar :: e -> c e -- | complex conjugate conj :: c e -> c e scale :: e -> c e -> c e -- | scale the element by element reciprocal of the object: -- -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@ scaleRecip :: e -> c e -> c e addConstant :: e -> c e -> c e add :: c e -> c e -> c e sub :: c e -> c e -> c e -- | element by element multiplication mul :: c e -> c e -> c e -- | element by element division divide :: c e -> c e -> c e equal :: c e -> c e -> Bool -- -- element by element inverse tangent arctan2 :: c e -> c e -> c e -- -- | cannot implement instance Functor because of Element class constraint cmap :: (Element b) => (e -> b) -> c e -> c b -- | constant structure of given size konst :: e -> IndexOf c -> c e -- | create a structure using a function -- -- Hilbert matrix of order N: -- -- @hilb n = build (n,n) (\\i j -> 1/(i+j+1))@ build :: IndexOf c -> (ArgOf c e) -> c e --build :: BoundsOf f -> f -> (ContainerOf f) e -- -- | indexing function atIndex :: c e -> IndexOf c -> e -- | index of min element minIndex :: c e -> IndexOf c -- | index of max element maxIndex :: c e -> IndexOf c -- | value of min element minElement :: c e -> e -- | value of max element maxElement :: c e -> e -- the C functions sumX/prodX are twice as fast as using foldVector -- | the sum of elements (faster than using @fold@) sumElements :: c e -> e -- | the product of elements (faster than using @fold@) prodElements :: c e -> e -- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@ -- -- @> step $ linspace 5 (-1,1::Double) -- 5 |> [0.0,0.0,0.0,1.0,1.0]@ step :: RealElement e => c e -> c e -- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@. -- -- Arguments with any dimension = 1 are automatically expanded: -- -- @> cond ((1>\<4)[1..]) ((3>\<1)[1..]) 0 100 ((3>\<4)[1..]) :: Matrix Double -- (3><4) -- [ 100.0, 2.0, 3.0, 4.0 -- , 0.0, 100.0, 7.0, 8.0 -- , 0.0, 0.0, 100.0, 12.0 ]@ cond :: RealElement e => c e -- ^ a -> c e -- ^ b -> c e -- ^ l -> c e -- ^ e -> c e -- ^ g -> c e -- ^ result -- | Find index of elements which satisfy a predicate -- -- @> find (>0) (ident 3 :: Matrix Double) -- [(0,0),(1,1),(2,2)]@ find :: (e -> Bool) -> c e -> [IndexOf c] -- | Create a structure from an association list -- -- @> assoc 5 0 [(2,7),(1,3)] :: Vector Double -- 5 |> [0.0,3.0,7.0,0.0,0.0]@ assoc :: IndexOf c -- ^ size -> e -- ^ default value -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result -- | 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 ]@ accum :: c e -- ^ initial structure -> (e -> e -> e) -- ^ update function -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result -------------------------------------------------------------------------- instance Container Vector Float where scale = vectorMapValF Scale scaleRecip = vectorMapValF Recip addConstant = vectorMapValF AddConstant add = vectorZipF Add sub = vectorZipF Sub mul = vectorZipF Mul divide = vectorZipF Div equal u v = dim u == dim v && maxElement (vectorMapF Abs (sub u v)) == 0.0 arctan2 = vectorZipF ATan2 scalar x = fromList [x] konst = constantD build = buildV conj = id cmap = mapVector atIndex = (@>) minIndex = round . toScalarF MinIdx maxIndex = round . toScalarF MaxIdx minElement = toScalarF Min maxElement = toScalarF Max sumElements = sumF prodElements = prodF step = stepF find = findV assoc = assocV accum = accumV cond = condV condF instance Container Vector Double where scale = vectorMapValR Scale scaleRecip = vectorMapValR Recip addConstant = vectorMapValR AddConstant add = vectorZipR Add sub = vectorZipR Sub mul = vectorZipR Mul divide = vectorZipR Div equal u v = dim u == dim v && maxElement (vectorMapR Abs (sub u v)) == 0.0 arctan2 = vectorZipR ATan2 scalar x = fromList [x] konst = constantD build = buildV conj = id cmap = mapVector atIndex = (@>) minIndex = round . toScalarR MinIdx maxIndex = round . toScalarR MaxIdx minElement = toScalarR Min maxElement = toScalarR Max sumElements = sumR prodElements = prodR step = stepD find = findV assoc = assocV accum = accumV cond = condV condD instance Container Vector (Complex Double) where scale = vectorMapValC Scale scaleRecip = vectorMapValC Recip addConstant = vectorMapValC AddConstant add = vectorZipC Add sub = vectorZipC Sub mul = vectorZipC Mul divide = vectorZipC Div equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 arctan2 = vectorZipC ATan2 scalar x = fromList [x] konst = constantD build = buildV conj = conjugateC cmap = mapVector atIndex = (@>) minIndex = minIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate) maxIndex = maxIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate) minElement = ap (@>) minIndex maxElement = ap (@>) maxIndex sumElements = sumC prodElements = prodC step = undefined -- cannot match find = findV assoc = assocV accum = accumV cond = undefined -- cannot match instance Container Vector (Complex Float) where scale = vectorMapValQ Scale scaleRecip = vectorMapValQ Recip addConstant = vectorMapValQ AddConstant add = vectorZipQ Add sub = vectorZipQ Sub mul = vectorZipQ Mul divide = vectorZipQ Div equal u v = dim u == dim v && maxElement (mapVector magnitude (sub u v)) == 0.0 arctan2 = vectorZipQ ATan2 scalar x = fromList [x] konst = constantD build = buildV conj = conjugateQ cmap = mapVector atIndex = (@>) minIndex = minIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate) maxIndex = maxIndex . fst . fromComplex . (zipVectorWith (*) `ap` mapVector conjugate) minElement = ap (@>) minIndex maxElement = ap (@>) maxIndex sumElements = sumQ prodElements = prodQ step = undefined -- cannot match find = findV assoc = assocV accum = accumV cond = undefined -- cannot match --------------------------------------------------------------- instance (Container Vector a) => Container Matrix a where scale x = liftMatrix (scale x) scaleRecip x = liftMatrix (scaleRecip x) addConstant x = liftMatrix (addConstant x) add = liftMatrix2 add sub = liftMatrix2 sub mul = liftMatrix2 mul divide = liftMatrix2 divide equal a b = cols a == cols b && flatten a `equal` flatten b arctan2 = liftMatrix2 arctan2 scalar x = (1><1) [x] konst v (r,c) = reshape c (konst v (r*c)) build = buildM conj = liftMatrix conj cmap f = liftMatrix (mapVector f) atIndex = (@@>) minIndex m = let (r,c) = (rows m,cols m) i = (minIndex $ flatten m) in (i `div` c,i `mod` c) maxIndex m = let (r,c) = (rows m,cols m) i = (maxIndex $ flatten m) in (i `div` c,i `mod` c) minElement = ap (@@>) minIndex maxElement = ap (@@>) maxIndex sumElements = sumElements . flatten prodElements = prodElements . flatten step = liftMatrix step find = findM assoc = assocM accum = accumM cond = condM ---------------------------------------------------- -- | Matrix product and related functions class Element e => Product e where -- | matrix product multiply :: Matrix e -> Matrix e -> Matrix e -- | dot (inner) product dot :: Vector e -> Vector e -> e -- | sum of absolute value of elements (differs in complex case from @norm1@) absSum :: Vector e -> RealOf e -- | sum of absolute value of elements norm1 :: Vector e -> RealOf e -- | euclidean norm norm2 :: Vector e -> RealOf e -- | element of maximum magnitude normInf :: Vector e -> RealOf e instance Product Float where norm2 = toScalarF Norm2 absSum = toScalarF AbsSum dot = dotF norm1 = toScalarF AbsSum normInf = maxElement . vectorMapF Abs multiply = multiplyF instance Product Double where norm2 = toScalarR Norm2 absSum = toScalarR AbsSum dot = dotR norm1 = toScalarR AbsSum normInf = maxElement . vectorMapR Abs multiply = multiplyR instance Product (Complex Float) where norm2 = toScalarQ Norm2 absSum = toScalarQ AbsSum dot = dotQ norm1 = sumElements . fst . fromComplex . vectorMapQ Abs normInf = maxElement . fst . fromComplex . vectorMapQ Abs multiply = multiplyQ instance Product (Complex Double) where norm2 = toScalarC Norm2 absSum = toScalarC AbsSum dot = dotC norm1 = sumElements . fst . fromComplex . vectorMapC Abs normInf = maxElement . fst . fromComplex . vectorMapC Abs multiply = multiplyC ---------------------------------------------------------- -- synonym for matrix product mXm :: Product t => Matrix t -> Matrix t -> Matrix t mXm = multiply -- matrix - vector product mXv :: Product t => Matrix t -> Vector t -> Vector t mXv m v = flatten $ m `mXm` (asColumn v) -- vector - matrix product vXm :: Product t => Vector t -> Matrix t -> Vector t vXm v m = flatten $ (asRow v) `mXm` m {- | Outer product of two vectors. @\> 'fromList' [1,2,3] \`outer\` 'fromList' [5,2,3] (3><3) [ 5.0, 2.0, 3.0 , 10.0, 4.0, 6.0 , 15.0, 6.0, 9.0 ]@ -} outer :: (Product t) => Vector t -> Vector t -> Matrix t outer u v = asColumn u `multiply` asRow v {- | Kronecker product of two matrices. @m1=(2><3) [ 1.0, 2.0, 0.0 , 0.0, -1.0, 3.0 ] m2=(4><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 ]@ @\> kronecker m1 m2 (8><9) [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0 , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0 , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0 , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0 , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0 , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0 , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0 , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ]@ -} kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t kronecker a b = fromBlocks . splitEvery (cols a) . map (reshape (cols b)) . toRows $ flatten a `outer` flatten b ------------------------------------------------------------------- class Convert t where real :: Container c t => c (RealOf t) -> c t complex :: Container c t => c t -> c (ComplexOf t) single :: Container c t => c t -> c (SingleOf t) double :: Container c t => c t -> c (DoubleOf t) toComplex :: (Container c t, RealElement t) => (c t, c t) -> c (Complex t) fromComplex :: (Container c t, RealElement t) => c (Complex t) -> (c t, c t) instance Convert Double where real = id complex = comp' single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert Float where real = id complex = comp' single = id double = double' toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Double) where real = comp' complex = id single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Float) where real = comp' complex = id single = id double = double' toComplex = toComplex' fromComplex = fromComplex' ------------------------------------------------------------------- type family RealOf x type instance RealOf Double = Double type instance RealOf (Complex Double) = Double type instance RealOf Float = Float type instance RealOf (Complex Float) = Float type family ComplexOf x type instance ComplexOf Double = Complex Double type instance ComplexOf (Complex Double) = Complex Double type instance ComplexOf Float = Complex Float type instance ComplexOf (Complex Float) = Complex Float type family SingleOf x type instance SingleOf Double = Float type instance SingleOf Float = Float type instance SingleOf (Complex a) = Complex (SingleOf a) type family DoubleOf x type instance DoubleOf Double = Double type instance DoubleOf Float = Double type instance DoubleOf (Complex a) = Complex (DoubleOf a) type family ElementOf c type instance ElementOf (Vector a) = a type instance ElementOf (Matrix a) = a ------------------------------------------------------------ class Build f where build' :: BoundsOf f -> f -> ContainerOf f type family BoundsOf x type instance BoundsOf (a->a) = Int type instance BoundsOf (a->a->a) = (Int,Int) type family ContainerOf x type instance ContainerOf (a->a) = Vector a type instance ContainerOf (a->a->a) = Matrix a instance (Element a, Num a) => Build (a->a) where build' = buildV instance (Element a, Num a) => Build (a->a->a) where build' = buildM 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)] ---------------------------------------------------- -- experimental class Konst s where konst' :: Element e => e -> s -> ContainerOf' s e type family ContainerOf' x y type instance ContainerOf' Int a = Vector a type instance ContainerOf' (Int,Int) a = Matrix a instance Konst Int where konst' = constantD instance Konst (Int,Int) where konst' k (r,c) = reshape c $ konst' k (r*c) -------------------------------------------------------- -- | conjugate transpose ctrans :: (Container Vector e, Element e) => Matrix e -> Matrix e ctrans = liftMatrix conj . trans -- | Creates a square matrix with a given diagonal. diag :: (Num a, Element a) => Vector a -> Matrix a diag v = diagRect 0 v n n where n = dim v -- | creates the identity matrix of given dimension ident :: (Num a, Element a) => Int -> Matrix a ident n = diag (constantD 1 n) -------------------------------------------------------- findV p x = foldVectorWithIndex g [] x where g k z l = if p z then k:l else l findM p x = map ((`divMod` cols x)) $ findV p (flatten x) assocV n z xs = ST.runSTVector $ do v <- ST.newVector z n mapM_ (\(k,x) -> ST.writeVector v k x) xs return v assocM (r,c) z xs = ST.runSTMatrix $ do m <- ST.newMatrix z r c mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs return m accumV v0 f xs = ST.runSTVector $ do v <- ST.thawVector v0 mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs return v accumM m0 f xs = ST.runSTMatrix $ do m <- ST.thawMatrix m0 mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs return m ---------------------------------------------------------------------- condM a b l e t = reshape (cols a'') $ cond a' b' l' e' t' where args@(a'':_) = conformMs [a,b,l,e,t] [a', b', l', e', t'] = map flatten args condV f a b l e t = f a' b' l' e' t' where [a', b', l', e', t'] = conformVs [a,b,l,e,t] hmatrix-0.15.0.0/lib/Numeric/Conversion.hs0000644000000000000000000000543712165764700016447 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Conversion -- Copyright : (c) Alberto Ruiz 2010 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- Conversion routines -- ----------------------------------------------------------------------------- module Numeric.Conversion ( Complexable(..), RealElement, module Data.Complex ) where import Data.Packed.Internal.Vector import Data.Packed.Internal.Matrix import Data.Complex import Control.Arrow((***)) ------------------------------------------------------------------- -- | Supported single-double precision type pairs class (Element s, Element d) => Precision s d | s -> d, d -> s where double2FloatG :: Vector d -> Vector s float2DoubleG :: Vector s -> Vector d instance Precision Float Double where double2FloatG = double2FloatV float2DoubleG = float2DoubleV instance Precision (Complex Float) (Complex Double) where double2FloatG = asComplex . double2FloatV . asReal float2DoubleG = asComplex . float2DoubleV . asReal -- | Supported real types class (Element t, Element (Complex t), RealFloat t -- , RealOf t ~ t, RealOf (Complex t) ~ t ) => RealElement t instance RealElement Double instance RealElement Float -- | Structures that may contain complex numbers class Complexable c where toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e) fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e) comp' :: (RealElement e) => c e -> c (Complex e) single' :: Precision a b => c b -> c a double' :: Precision a b => c a -> c b instance Complexable Vector where toComplex' = toComplexV fromComplex' = fromComplexV comp' v = toComplex' (v,constantD 0 (dim v)) single' = double2FloatG double' = float2DoubleG -- | creates a complex vector from vectors with real and imaginary parts toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a) toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i] -- | the inverse of 'toComplex' fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a) fromComplexV z = (r,i) where [r,i] = toColumns $ reshape 2 $ asReal z instance Complexable Matrix where toComplex' = uncurry $ liftMatrix2 $ curry toComplex' fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z where c = cols z comp' = liftMatrix comp' single' = liftMatrix single' double' = liftMatrix double' hmatrix-0.15.0.0/lib/Numeric/Matrix.hs0000644000000000000000000000433012165764700015555 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Matrix -- Copyright : (c) Alberto Ruiz 2010 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- 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 Numeric.Container ------------------------------------------------------------------- instance Container Matrix a => Eq (Matrix a) where (==) = equal instance (Container Matrix 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 (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] hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra.hs0000644000000000000000000000165612165764700017011 0ustar0000000000000000----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra Copyright : (c) Alberto Ruiz 2006-10 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi This module reexports all normally required functions for Linear Algebra applications. It also provides instances of standard classes 'Show', 'Read', 'Eq', 'Num', 'Fractional', and 'Floating' for 'Vector' and 'Matrix'. In arithmetic operations one-component vectors and matrices automatically expand to match the dimensions of the other operand. -} ----------------------------------------------------------------------------- module Numeric.LinearAlgebra ( module Numeric.Container, module Numeric.LinearAlgebra.Algorithms ) where import Numeric.Container import Numeric.LinearAlgebra.Algorithms import Numeric.Matrix() import Numeric.Vector()hmatrix-0.15.0.0/lib/Numeric/Container.hs0000644000000000000000000001005712165764700016236 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Container -- Copyright : (c) Alberto Ruiz 2010 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- 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 Numeric.Container ( -- * Basic functions module Data.Packed, constant, linspace, diag, ident, ctrans, -- * Generic operations Container(..), -- * Matrix product Product(..), optimiseMult, mXm,mXv,vXm,(<.>),Mul(..),LSDiv(..), outer, kronecker, -- * Random numbers RandDist(..), randomVector, gaussianSample, uniformSample, meanCov, -- * Element conversion Convert(..), Complexable(), RealElement(), RealOf, ComplexOf, SingleOf, DoubleOf, IndexOf, module Data.Complex, -- * Input / Output dispf, disps, dispcf, vecdisp, latexFormat, format, loadMatrix, saveMatrix, fromFile, fileDimensions, readMatrix, fscanfVector, fprintfVector, freadVector, fwriteVector, -- * Experimental build', konst' ) where import Data.Packed import Data.Packed.Internal(constantD) import Numeric.ContainerBoot import Numeric.Chain import Numeric.IO import Data.Complex import Numeric.LinearAlgebra.Algorithms(Field,linearSolveSVD) import Data.Packed.Random ------------------------------------------------------------------ {- | creates a vector with a given number of equal components: @> constant 2 7 7 |> [2.0,2.0,2.0,2.0,2.0,2.0,2.0]@ -} constant :: Element a => a -> Int -> Vector a -- constant x n = runSTVector (newVector x n) constant = constantD-- about 2x faster {- | Creates a real vector containing a range of values: @\> linspace 5 (-3,7) 5 |> [-3.0,-0.5,2.0,4.5,7.0]@ Logarithmic spacing can be defined as follows: @logspace n (a,b) = 10 ** linspace n (a,b)@ -} linspace :: (Enum e, Container Vector e) => Int -> (e, e) -> Vector e linspace n (a,b) = addConstant a $ scale s $ fromList [0 .. fromIntegral n-1] where s = (b-a)/fromIntegral (n-1) -- | Dot product: @u \<.\> v = dot u v@ (<.>) :: Product t => Vector t -> Vector t -> t infixl 7 <.> (<.>) = dot -------------------------------------------------------- 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 -------------------------------------------------------- class LSDiv b c | b -> c, c->b where infixl 7 <\> -- | least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD) (<\>) :: Field t => Matrix t -> b t -> c t instance LSDiv Vector Vector where m <\> v = flatten (linearSolveSVD m (reshape 1 v)) instance LSDiv Matrix Matrix where (<\>) = linearSolveSVD -------------------------------------------------------- -- | Compute mean vector and covariance matrix of the rows of a matrix. 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) hmatrix-0.15.0.0/lib/Numeric/GSL.hs0000644000000000000000000000224612165764700014742 0ustar0000000000000000{- | Module : Numeric.GSL Copyright : (c) Alberto Ruiz 2006-7 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses -fffi and -fglasgow-exts This module reexports all available GSL functions. The GSL special functions are in the separate package hmatrix-special. -} module Numeric.GSL ( module Numeric.GSL.Integration , module Numeric.GSL.Differentiation , module Numeric.GSL.Fourier , module Numeric.GSL.Polynomials , module Numeric.GSL.Minimization , module Numeric.GSL.Root , module Numeric.GSL.ODE , module Numeric.GSL.Fitting , module Data.Complex , setErrorHandlerOff ) where import Numeric.GSL.Integration import Numeric.GSL.Differentiation import Numeric.GSL.Fourier import Numeric.GSL.Polynomials import Numeric.GSL.Minimization import Numeric.GSL.Root import Numeric.GSL.ODE import Numeric.GSL.Fitting import Data.Complex -- | This action removes the GSL default error handler (which aborts the program), so that -- GSL errors can be handled by Haskell (using Control.Exception) and ghci doesn't abort. foreign import ccall unsafe "GSL/gsl-aux.h no_abort_on_error" setErrorHandlerOff :: IO () hmatrix-0.15.0.0/lib/Numeric/IO.hs0000644000000000000000000001207112165764700014621 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.IO -- Copyright : (c) Alberto Ruiz 2010 -- License : GPL -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- Display, formatting and IO functions for numeric 'Vector' and 'Matrix' -- ----------------------------------------------------------------------------- module Numeric.IO ( dispf, disps, dispcf, vecdisp, latexFormat, format, loadMatrix, saveMatrix, fromFile, fileDimensions, readMatrix, fromArray2D, fscanfVector, fprintfVector, freadVector, fwriteVector ) where import Data.Packed import Data.Packed.Internal import System.Process(readProcess) import Text.Printf(printf) import Data.List(intersperse) import Data.Complex {- | 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. @disp = putStr . disps 2 \> disp $ 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. @disp = putStr . dispf 3 \> disp (1/3 + ident 4) 4x4 1.333 0.333 0.333 0.333 0.333 1.333 0.333 0.333 0.333 0.333 1.333 0.333 0.333 0.333 0.333 1.333 @ -} 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 = 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. @disp = putStr . vecdisp ('dispf' 2) \> disp ('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 :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc. -> String -- ^ Formatted matrix, with elements separated by spaces and newlines -> String latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}" where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines -- | Pretty print a complex number with at most n decimal digits. showComplex :: Int -> Complex Double -> String showComplex d (a:+b) | isZero a && isZero b = "0" | isZero b = sa | isZero a && isOne b = s2++"i" | isZero a = sb++"i" | isOne b = sa++s3++"i" | otherwise = sa++s1++sb++"i" where sa = shcr d a sb = shcr d b s1 = if b<0 then "" else "+" s2 = if b<0 then "-" else "" s3 = if b<0 then "-" else "+" shcr d a | lookslikeInt a = printf "%.0f" a | otherwise = printf ("%."++show d++"f") a lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx where shx = show x isZero x = show x `elem` ["0.0","-0.0"] isOne x = show x `elem` ["1.0","-1.0"] -- | Pretty print a complex matrix with at most n decimal digits. dispcf :: Int -> Matrix (Complex Double) -> String dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m -------------------------------------------------------------------- -- | reads a matrix from a string containing a table of numbers. readMatrix :: String -> Matrix Double readMatrix = fromLists . map (map read). map words . filter (not.null) . lines {- | obtains the number of rows and columns in an ASCII data file (provisionally using unix's wc). -} fileDimensions :: FilePath -> IO (Int,Int) fileDimensions fname = do wcres <- readProcess "wc" ["-w",fname] "" contents <- readFile fname let tot = read . head . words $ wcres c = length . head . dropWhile null . map words . lines $ contents if tot > 0 then return (tot `div` c, c) else return (0,0) -- | Loads a matrix from an ASCII file formatted as a 2D table. loadMatrix :: FilePath -> IO (Matrix Double) loadMatrix file = fromFile file =<< fileDimensions file -- | Loads a matrix from an ASCII file (the number of rows and columns must be known in advance). fromFile :: FilePath -> (Int,Int) -> IO (Matrix Double) fromFile filename (r,c) = reshape c `fmap` fscanfVector filename (r*c) hmatrix-0.15.0.0/lib/Numeric/GSL/0000755000000000000000000000000012165764700014402 5ustar0000000000000000hmatrix-0.15.0.0/lib/Numeric/GSL/Fourier.hs0000644000000000000000000000252012165764700016350 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- {- | Module : Numeric.GSL.Fourier Copyright : (c) Alberto Ruiz 2006 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Fourier Transform. -} ----------------------------------------------------------------------------- module Numeric.GSL.Fourier ( fft, ifft ) where import Data.Packed.Internal import Data.Complex import Foreign.C.Types import System.IO.Unsafe (unsafePerformIO) genfft code v = unsafePerformIO $ do r <- createVector (dim v) app2 (c_fft code) vec v vec r "fft" return r foreign import ccall unsafe "gsl-aux.h fft" c_fft :: CInt -> TCVCV {- | Fast 1D Fourier transform of a 'Vector' @(@'Complex' 'Double'@)@ using /gsl_fft_complex_forward/. It uses the same scaling conventions as GNU Octave. @> fft ('fromList' [1,2,3,4]) vector (4) [10.0 :+ 0.0,(-2.0) :+ 2.0,(-2.0) :+ 0.0,(-2.0) :+ (-2.0)]@ -} fft :: Vector (Complex Double) -> Vector (Complex Double) fft = genfft 0 -- | The inverse of 'fft', using /gsl_fft_complex_inverse/. ifft :: Vector (Complex Double) -> Vector (Complex Double) ifft = genfft 1 hmatrix-0.15.0.0/lib/Numeric/GSL/Internal.hs0000644000000000000000000000424012165764700016512 0ustar0000000000000000-- Module : Numeric.GSL.Internal -- Copyright : (c) Alberto Ruiz 2009 -- License : GPL -- -- Maintainer : Alberto Ruiz (aruiz at um dot es) -- Stability : provisional -- Portability : uses ffi -- -- Auxiliary functions. -- -- #hide module Numeric.GSL.Internal where import Data.Packed.Internal import Foreign.Marshal.Array(copyArray) import Foreign.Ptr(Ptr, FunPtr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) iv :: (Vector Double -> Double) -> (CInt -> Ptr Double -> Double) iv f n p = f (createV (fromIntegral n) copy "iv") where copy n' q = do copyArray q p (fromIntegral n') return 0 -- | conversion of Haskell functions into function pointers that can be used in the C side foreign import ccall safe "wrapper" mkVecfun :: (CInt -> Ptr Double -> Double) -> IO( FunPtr (CInt -> Ptr Double -> Double)) foreign import ccall safe "wrapper" mkVecVecfun :: TVV -> IO (FunPtr TVV) foreign import ccall safe "wrapper" mkDoubleVecVecfun :: (Double -> TVV) -> IO (FunPtr (Double -> TVV)) foreign import ccall safe "wrapper" mkDoublefun :: (Double -> Double) -> IO (FunPtr (Double -> Double)) aux_vTov :: (Vector Double -> Vector Double) -> TVV aux_vTov f n p nr r = g where v = f x x = createV (fromIntegral n) copy "aux_vTov" copy n' q = do copyArray q p (fromIntegral n') return 0 g = do unsafeWith v $ \p' -> copyArray r p' (fromIntegral nr) return 0 foreign import ccall safe "wrapper" mkVecMatfun :: TVM -> IO (FunPtr TVM) foreign import ccall safe "wrapper" mkDoubleVecMatfun :: (Double -> TVM) -> IO (FunPtr (Double -> TVM)) aux_vTom :: (Vector Double -> Matrix Double) -> TVM aux_vTom f n p rr cr r = g where v = flatten $ f x x = createV (fromIntegral n) copy "aux_vTov" copy n' q = do copyArray q p (fromIntegral n') return 0 g = do unsafeWith v $ \p' -> copyArray r p' (fromIntegral $ rr*cr) return 0 createV n fun msg = unsafePerformIO $ do r <- createVector n app1 fun vec r msg return r createMIO r c fun msg = do res <- createMatrix RowMajor r c app1 fun mat res msg return res hmatrix-0.15.0.0/lib/Numeric/GSL/Differentiation.hs0000644000000000000000000000705612165764700020060 0ustar0000000000000000{-# OPTIONS #-} ----------------------------------------------------------------------------- {- | Module : Numeric.GSL.Differentiation Copyright : (c) Alberto Ruiz 2006 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Numerical differentiation. From the GSL manual: \"The functions described in this chapter compute numerical derivatives by finite differencing. An adaptive algorithm is used to find the best choice of finite difference and to estimate the error in the derivative.\" -} ----------------------------------------------------------------------------- module Numeric.GSL.Differentiation ( derivCentral, derivForward, derivBackward ) where import Foreign.C.Types import Foreign.Marshal.Alloc(malloc, free) import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr) import Foreign.Storable(peek) import Data.Packed.Internal(check,(//)) import System.IO.Unsafe(unsafePerformIO) derivGen :: CInt -- ^ type: 0 central, 1 forward, 2 backward -> Double -- ^ initial step size -> (Double -> Double) -- ^ function -> Double -- ^ point where the derivative is taken -> (Double, Double) -- ^ result and error derivGen c h f x = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\y _ -> f y) c_deriv c fp x h r e // check "deriv" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h deriv" c_deriv :: CInt -> FunPtr (Double -> Ptr () -> Double) -> Double -> Double -> Ptr Double -> Ptr Double -> IO CInt {- | Adaptive central difference algorithm, /gsl_deriv_central/. For example: > > let deriv = derivCentral 0.01 > > deriv sin (pi/4) >(0.7071067812000676,1.0600063101654055e-10) > > cos (pi/4) >0.7071067811865476 -} derivCentral :: Double -- ^ initial step size -> (Double -> Double) -- ^ function -> Double -- ^ point where the derivative is taken -> (Double, Double) -- ^ result and absolute error derivCentral = derivGen 0 -- | Adaptive forward difference algorithm, /gsl_deriv_forward/. The function is evaluated only at points greater than x, and never at x itself. The derivative is returned in result and an estimate of its absolute error is returned in abserr. This function should be used if f(x) has a discontinuity at x, or is undefined for values less than x. A backward derivative can be obtained using a negative step. derivForward :: Double -- ^ initial step size -> (Double -> Double) -- ^ function -> Double -- ^ point where the derivative is taken -> (Double, Double) -- ^ result and absolute error derivForward = derivGen 1 -- | Adaptive backward difference algorithm, /gsl_deriv_backward/. derivBackward ::Double -- ^ initial step size -> (Double -> Double) -- ^ function -> Double -- ^ point where the derivative is taken -> (Double, Double) -- ^ result and absolute error derivBackward = derivGen 2 {- | conversion of Haskell functions into function pointers that can be used in the C side -} foreign import ccall safe "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) hmatrix-0.15.0.0/lib/Numeric/GSL/Minimization.hs0000644000000000000000000002015112165764700017404 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- {- | Module : Numeric.GSL.Minimization Copyright : (c) Alberto Ruiz 2006-9 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Minimization of a multidimensional function using some of the algorithms described in: The example in the GSL manual: @ f [x,y] = 10*(x-1)^2 + 20*(y-2)^2 + 30 main = do let (s,p) = minimize NMSimplex2 1E-2 30 [1,1] f [5,7] print s print p \> main [0.9920430849306288,1.9969168063253182] 0.000 512.500 1.130 6.500 5.000 1.000 290.625 1.409 5.250 4.000 2.000 290.625 1.409 5.250 4.000 3.000 252.500 1.409 5.500 1.000 ... 22.000 30.001 0.013 0.992 1.997 23.000 30.001 0.008 0.992 1.997 @ The path to the solution can be graphically shown by means of: @'Graphics.Plot.mplot' $ drop 3 ('toColumns' p)@ Taken from the GSL manual: The vector Broyden-Fletcher-Goldfarb-Shanno (BFGS) algorithm is a quasi-Newton method which builds up an approximation to the second derivatives of the function f using the difference between successive gradient vectors. By combining the first and second derivatives the algorithm is able to take Newton-type steps towards the function minimum, assuming quadratic behavior in that region. The bfgs2 version of this minimizer is the most efficient version available, and is a faithful implementation of the line minimization scheme described in Fletcher's Practical Methods of Optimization, Algorithms 2.6.2 and 2.6.4. It supercedes the original bfgs routine and requires substantially fewer function and gradient evaluations. The user-supplied tolerance tol corresponds to the parameter \sigma used by Fletcher. A value of 0.1 is recommended for typical use (larger values correspond to less accurate line searches). The nmsimplex2 version is a new O(N) implementation of the earlier O(N^2) nmsimplex minimiser. It calculates the size of simplex as the rms distance of each vertex from the center rather than the mean distance, which has the advantage of allowing a linear update. -} ----------------------------------------------------------------------------- module Numeric.GSL.Minimization ( minimize, minimizeV, MinimizeMethod(..), minimizeD, minimizeVD, MinimizeMethodD(..), minimizeNMSimplex, minimizeConjugateGradient, minimizeVectorBFGS2 ) where import Data.Packed.Internal import Data.Packed.Matrix import Numeric.GSL.Internal import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) ------------------------------------------------------------------------ {-# DEPRECATED minimizeNMSimplex "use minimize NMSimplex2 eps maxit sizes f xi" #-} minimizeNMSimplex f xi szs eps maxit = minimize NMSimplex eps maxit szs f xi {-# DEPRECATED minimizeConjugateGradient "use minimizeD ConjugateFR eps maxit step tol f g xi" #-} minimizeConjugateGradient step tol eps maxit f g xi = minimizeD ConjugateFR eps maxit step tol f g xi {-# DEPRECATED minimizeVectorBFGS2 "use minimizeD VectorBFGS2 eps maxit step tol f g xi" #-} minimizeVectorBFGS2 step tol eps maxit f g xi = minimizeD VectorBFGS2 eps maxit step tol f g xi ------------------------------------------------------------------------- data MinimizeMethod = NMSimplex | NMSimplex2 deriving (Enum,Eq,Show,Bounded) -- | Minimization without derivatives minimize :: MinimizeMethod -> Double -- ^ desired precision of the solution (size test) -> Int -- ^ maximum number of iterations allowed -> [Double] -- ^ sizes of the initial search box -> ([Double] -> Double) -- ^ function to minimize -> [Double] -- ^ starting point -> ([Double], Matrix Double) -- ^ solution vector and optimization path -- | Minimization without derivatives (vector version) minimizeV :: MinimizeMethod -> Double -- ^ desired precision of the solution (size test) -> Int -- ^ maximum number of iterations allowed -> Vector Double -- ^ sizes of the initial search box -> (Vector Double -> Double) -- ^ function to minimize -> Vector Double -- ^ starting point -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path minimize method eps maxit sz f xi = v2l $ minimizeV method eps maxit (fromList sz) (f.toList) (fromList xi) where v2l (v,m) = (toList v, m) ww2 w1 o1 w2 o2 f = w1 o1 $ \a1 -> w2 o2 $ \a2 -> f a1 a2 minimizeV method eps maxit szv f xiv = unsafePerformIO $ do let n = dim xiv fp <- mkVecfun (iv f) rawpath <- ww2 vec xiv vec szv $ \xiv' szv' -> createMIO maxit (n+3) (c_minimize (fi (fromEnum method)) fp eps (fi maxit) // xiv' // szv') "minimize" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath sol = cdat $ dropColumns 3 $ dropRows (it-1) path freeHaskellFunPtr fp return (sol, path) foreign import ccall safe "gsl-aux.h minimize" c_minimize:: CInt -> FunPtr (CInt -> Ptr Double -> Double) -> Double -> CInt -> TVVM ---------------------------------------------------------------------------------- data MinimizeMethodD = ConjugateFR | ConjugatePR | VectorBFGS | VectorBFGS2 | SteepestDescent deriving (Enum,Eq,Show,Bounded) -- | Minimization with derivatives. minimizeD :: MinimizeMethodD -> Double -- ^ desired precision of the solution (gradient test) -> Int -- ^ maximum number of iterations allowed -> Double -- ^ size of the first trial step -> Double -- ^ tol (precise meaning depends on method) -> ([Double] -> Double) -- ^ function to minimize -> ([Double] -> [Double]) -- ^ gradient -> [Double] -- ^ starting point -> ([Double], Matrix Double) -- ^ solution vector and optimization path -- | Minimization with derivatives (vector version) minimizeVD :: MinimizeMethodD -> Double -- ^ desired precision of the solution (gradient test) -> Int -- ^ maximum number of iterations allowed -> Double -- ^ size of the first trial step -> Double -- ^ tol (precise meaning depends on method) -> (Vector Double -> Double) -- ^ function to minimize -> (Vector Double -> Vector Double) -- ^ gradient -> Vector Double -- ^ starting point -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path minimizeD method eps maxit istep tol f df xi = v2l $ minimizeVD method eps maxit istep tol (f.toList) (fromList.df.toList) (fromList xi) where v2l (v,m) = (toList v, m) minimizeVD method eps maxit istep tol f df xiv = unsafePerformIO $ do let n = dim xiv f' = f df' = (checkdim1 n . df) fp <- mkVecfun (iv f') dfp <- mkVecVecfun (aux_vTov df') rawpath <- vec xiv $ \xiv' -> createMIO maxit (n+2) (c_minimizeD (fi (fromEnum method)) fp dfp istep tol eps (fi maxit) // xiv') "minimizeD" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath sol = cdat $ dropColumns 2 $ dropRows (it-1) path freeHaskellFunPtr fp freeHaskellFunPtr dfp return (sol,path) foreign import ccall safe "gsl-aux.h minimizeD" c_minimizeD :: CInt -> FunPtr (CInt -> Ptr Double -> Double) -> FunPtr TVV -> Double -> Double -> Double -> CInt -> TVM --------------------------------------------------------------------- checkdim1 n v | dim v == n = v | otherwise = error $ "Error: "++ show n ++ " components expected in the result of the gradient supplied to minimizeD" hmatrix-0.15.0.0/lib/Numeric/GSL/Fitting.hs0000644000000000000000000001702712165764700016351 0ustar0000000000000000{- | Module : Numeric.GSL.Fitting Copyright : (c) Alberto Ruiz 2010 License : GPL Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Nonlinear Least-Squares Fitting The example program in the GSL manual (see examples/fitting.hs): @dat = [ ([0.0],([6.0133918608118675],0.1)), ([1.0],([5.5153769909966535],0.1)), ([2.0],([5.261094606015287],0.1)), ... ([39.0],([1.0619821710802808],0.1))] expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b] expModelDer [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]] (sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0] \> path (6><5) [ 1.0, 76.45780563978782, 1.6465931240727802, 1.8147715267618197e-2, 0.6465931240727797 , 2.0, 37.683816318260355, 2.858760367632973, 8.092094813253975e-2, 1.4479636296208662 , 3.0, 9.5807893736187, 4.948995119561291, 0.11942927999921617, 1.0945766509238248 , 4.0, 5.630494933603935, 5.021755718065913, 0.10287787128056883, 1.0338835440862608 , 5.0, 5.443976278682909, 5.045204331329302, 0.10405523433131504, 1.019416067207375 , 6.0, 5.4439736648994685, 5.045357818922331, 0.10404905846029407, 1.0192487112786812 ] \> sol [(5.045357818922331,6.027976702418132e-2), (0.10404905846029407,3.157045047172834e-3), (1.0192487112786812,3.782067731353722e-2)]@ -} ----------------------------------------------------------------------------- module Numeric.GSL.Fitting ( -- * Levenberg-Marquardt nlFitting, FittingMethod(..), -- * Utilities fitModelScaled, fitModel ) where import Data.Packed.Internal import Numeric.LinearAlgebra import Numeric.GSL.Internal import Foreign.Ptr(FunPtr, freeHaskellFunPtr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) ------------------------------------------------------------------------- data FittingMethod = LevenbergMarquardtScaled -- ^ Interface to gsl_multifit_fdfsolver_lmsder. This is a robust and efficient version of the Levenberg-Marquardt algorithm as implemented in the scaled lmder routine in minpack. Minpack was written by Jorge J. More, Burton S. Garbow and Kenneth E. Hillstrom. | LevenbergMarquardt -- ^ This is an unscaled version of the lmder algorithm. The elements of the diagonal scaling matrix D are set to 1. This algorithm may be useful in circumstances where the scaled version of lmder converges too slowly, or the function is already scaled appropriately. deriving (Enum,Eq,Show,Bounded) -- | Nonlinear multidimensional least-squares fitting. nlFitting :: FittingMethod -> Double -- ^ absolute tolerance -> Double -- ^ relative tolerance -> Int -- ^ maximum number of iterations allowed -> (Vector Double -> Vector Double) -- ^ function to be minimized -> (Vector Double -> Matrix Double) -- ^ Jacobian -> Vector Double -- ^ starting point -> (Vector Double, Matrix Double) -- ^ solution vector and optimization path nlFitting method epsabs epsrel maxit fun jac xinit = nlFitGen (fi (fromEnum method)) fun jac xinit epsabs epsrel maxit nlFitGen m f jac xiv epsabs epsrel maxit = unsafePerformIO $ do let p = dim xiv n = dim (f xiv) fp <- mkVecVecfun (aux_vTov (checkdim1 n p . f)) jp <- mkVecMatfun (aux_vTom (checkdim2 n p . jac)) rawpath <- createMatrix RowMajor maxit (2+p) app2 (c_nlfit m fp jp epsabs epsrel (fi maxit) (fi n)) vec xiv mat rawpath "c_nlfit" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath [sol] = toRows $ dropRows (it-1) path freeHaskellFunPtr fp freeHaskellFunPtr jp return (subVector 2 p sol, path) foreign import ccall safe "nlfit" c_nlfit:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> Double -> CInt -> CInt -> TVM ------------------------------------------------------- checkdim1 n _p v | dim v == n = v | otherwise = error $ "Error: "++ show n ++ " components expected in the result of the function supplied to nlFitting" checkdim2 n p m | rows m == n && cols m == p = m | otherwise = error $ "Error: "++ show n ++ "x" ++ show p ++ " Jacobian expected in nlFitting" ------------------------------------------------------------ err (model,deriv) dat vsol = zip sol errs where sol = toList vsol c = max 1 (chi/sqrt (fromIntegral dof)) dof = length dat - (rows cov) chi = norm2 (fromList $ cost (resMs model) dat sol) js = fromLists $ jacobian (resDs deriv) dat sol cov = inv $ trans js <> js errs = toList $ scalar c * sqrt (takeDiag cov) -- | Higher level interface to 'nlFitting' 'LevenbergMarquardtScaled'. The optimization function and -- Jacobian are automatically built from a model f vs x = y and its derivatives, and a list of -- instances (x, (y,sigma)) to be fitted. fitModelScaled :: Double -- ^ absolute tolerance -> Double -- ^ relative tolerance -> Int -- ^ maximum number of iterations allowed -> ([Double] -> x -> [Double], [Double] -> x -> [[Double]]) -- ^ (model, derivatives) -> [(x, ([Double], Double))] -- ^ instances -> [Double] -- ^ starting point -> ([(Double, Double)], Matrix Double) -- ^ (solution, error) and optimization path fitModelScaled epsabs epsrel maxit (model,deriv) dt xin = (err (model,deriv) dt sol, path) where (sol,path) = nlFitting LevenbergMarquardtScaled epsabs epsrel maxit (fromList . cost (resMs model) dt . toList) (fromLists . jacobian (resDs deriv) dt . toList) (fromList xin) -- | Higher level interface to 'nlFitting' 'LevenbergMarquardt'. The optimization function and -- Jacobian are automatically built from a model f vs x = y and its derivatives, and a list of -- instances (x,y) to be fitted. fitModel :: Double -- ^ absolute tolerance -> Double -- ^ relative tolerance -> Int -- ^ maximum number of iterations allowed -> ([Double] -> x -> [Double], [Double] -> x -> [[Double]]) -- ^ (model, derivatives) -> [(x, [Double])] -- ^ instances -> [Double] -- ^ starting point -> ([Double], Matrix Double) -- ^ solution and optimization path fitModel epsabs epsrel maxit (model,deriv) dt xin = (toList sol, path) where (sol,path) = nlFitting LevenbergMarquardt epsabs epsrel maxit (fromList . cost (resM model) dt . toList) (fromLists . jacobian (resD deriv) dt . toList) (fromList xin) cost model ds vs = concatMap (model vs) ds jacobian modelDer ds vs = concatMap (modelDer vs) ds -- | Model-to-residual for association pairs with sigma, to be used with 'fitModel'. resMs :: ([Double] -> x -> [Double]) -> [Double] -> (x, ([Double], Double)) -> [Double] resMs m v = \(x,(ys,s)) -> zipWith (g s) (m v x) ys where g s a b = (a-b)/s -- | Associated derivative for 'resMs'. resDs :: ([Double] -> x -> [[Double]]) -> [Double] -> (x, ([Double], Double)) -> [[Double]] resDs m v = \(x,(_,s)) -> map (map (/s)) (m v x) -- | Model-to-residual for association pairs, to be used with 'fitModel'. It is equivalent -- to 'resMs' with all sigmas = 1. resM :: ([Double] -> x -> [Double]) -> [Double] -> (x, [Double]) -> [Double] resM m v = \(x,ys) -> zipWith g (m v x) ys where g a b = a-b -- | Associated derivative for 'resM'. resD :: ([Double] -> x -> [[Double]]) -> [Double] -> (x, [Double]) -> [[Double]] resD m v = \(x,_) -> m v x hmatrix-0.15.0.0/lib/Numeric/GSL/Vector.hs0000644000000000000000000002600612165764700016204 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.GSL.Vector -- Copyright : (c) Alberto Ruiz 2007 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable (uses FFI) -- -- Low level interface to vector operations. -- ----------------------------------------------------------------------------- module Numeric.GSL.Vector ( sumF, sumR, sumQ, sumC, prodF, prodR, prodQ, prodC, dotF, dotR, dotQ, dotC, FunCodeS(..), toScalarR, toScalarF, toScalarC, toScalarQ, FunCodeV(..), vectorMapR, vectorMapC, vectorMapF, vectorMapQ, FunCodeSV(..), vectorMapValR, vectorMapValC, vectorMapValF, vectorMapValQ, FunCodeVV(..), vectorZipR, vectorZipC, vectorZipF, vectorZipQ, RandDist(..), randomVector ) where import Data.Packed.Internal.Common import Data.Packed.Internal.Signatures import Data.Packed.Internal.Vector import Data.Complex import Foreign.Marshal.Alloc(free) import Foreign.Marshal.Array(newArray) import Foreign.Ptr(Ptr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) fromei x = fromIntegral (fromEnum x) :: CInt data FunCodeV = Sin | Cos | Tan | Abs | ASin | ACos | ATan | Sinh | Cosh | Tanh | ASinh | ACosh | ATanh | Exp | Log | Sign | Sqrt deriving Enum data FunCodeSV = Scale | Recip | AddConstant | Negate | PowSV | PowVS deriving Enum data FunCodeVV = Add | Sub | Mul | Div | Pow | ATan2 deriving Enum data FunCodeS = Norm2 | AbsSum | MaxIdx | Max | MinIdx | Min deriving Enum ------------------------------------------------------------------ -- | sum of elements sumF :: Vector Float -> Float sumF x = unsafePerformIO $ do r <- createVector 1 app2 c_sumF vec x vec r "sumF" return $ r @> 0 -- | sum of elements sumR :: Vector Double -> Double sumR x = unsafePerformIO $ do r <- createVector 1 app2 c_sumR vec x vec r "sumR" return $ r @> 0 -- | sum of elements sumQ :: Vector (Complex Float) -> Complex Float sumQ x = unsafePerformIO $ do r <- createVector 1 app2 c_sumQ vec x vec r "sumQ" return $ r @> 0 -- | sum of elements sumC :: Vector (Complex Double) -> Complex Double sumC x = unsafePerformIO $ do r <- createVector 1 app2 c_sumC vec x vec r "sumC" return $ r @> 0 foreign import ccall unsafe "gsl-aux.h sumF" c_sumF :: TFF foreign import ccall unsafe "gsl-aux.h sumR" c_sumR :: TVV foreign import ccall unsafe "gsl-aux.h sumQ" c_sumQ :: TQVQV foreign import ccall unsafe "gsl-aux.h sumC" c_sumC :: TCVCV -- | product of elements prodF :: Vector Float -> Float prodF x = unsafePerformIO $ do r <- createVector 1 app2 c_prodF vec x vec r "prodF" return $ r @> 0 -- | product of elements prodR :: Vector Double -> Double prodR x = unsafePerformIO $ do r <- createVector 1 app2 c_prodR vec x vec r "prodR" return $ r @> 0 -- | product of elements prodQ :: Vector (Complex Float) -> Complex Float prodQ x = unsafePerformIO $ do r <- createVector 1 app2 c_prodQ vec x vec r "prodQ" return $ r @> 0 -- | product of elements prodC :: Vector (Complex Double) -> Complex Double prodC x = unsafePerformIO $ do r <- createVector 1 app2 c_prodC vec x vec r "prodC" return $ r @> 0 foreign import ccall unsafe "gsl-aux.h prodF" c_prodF :: TFF foreign import ccall unsafe "gsl-aux.h prodR" c_prodR :: TVV foreign import ccall unsafe "gsl-aux.h prodQ" c_prodQ :: TQVQV foreign import ccall unsafe "gsl-aux.h prodC" c_prodC :: TCVCV -- | dot product dotF :: Vector Float -> Vector Float -> Float dotF x y = unsafePerformIO $ do r <- createVector 1 app3 c_dotF vec x vec y vec r "dotF" return $ r @> 0 -- | dot product dotR :: Vector Double -> Vector Double -> Double dotR x y = unsafePerformIO $ do r <- createVector 1 app3 c_dotR vec x vec y vec r "dotR" return $ r @> 0 -- | dot product dotQ :: Vector (Complex Float) -> Vector (Complex Float) -> Complex Float dotQ x y = unsafePerformIO $ do r <- createVector 1 app3 c_dotQ vec x vec y vec r "dotQ" return $ r @> 0 -- | dot product dotC :: Vector (Complex Double) -> Vector (Complex Double) -> Complex Double dotC x y = unsafePerformIO $ do r <- createVector 1 app3 c_dotC vec x vec y vec r "dotC" return $ r @> 0 foreign import ccall unsafe "gsl-aux.h dotF" c_dotF :: TFFF foreign import ccall unsafe "gsl-aux.h dotR" c_dotR :: TVVV foreign import ccall unsafe "gsl-aux.h dotQ" c_dotQ :: TQVQVQV foreign import ccall unsafe "gsl-aux.h dotC" c_dotC :: TCVCVCV ------------------------------------------------------------------ toScalarAux fun code v = unsafePerformIO $ do r <- createVector 1 app2 (fun (fromei code)) vec v vec r "toScalarAux" return (r `at` 0) vectorMapAux fun code v = unsafePerformIO $ do r <- createVector (dim v) app2 (fun (fromei code)) vec v vec r "vectorMapAux" return r vectorMapValAux fun code val v = unsafePerformIO $ do r <- createVector (dim v) pval <- newArray [val] app2 (fun (fromei code) pval) vec v vec r "vectorMapValAux" free pval return r vectorZipAux fun code u v = unsafePerformIO $ do r <- createVector (dim u) app3 (fun (fromei code)) vec u vec v vec r "vectorZipAux" return r --------------------------------------------------------------------- -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarR :: FunCodeS -> Vector Double -> Double toScalarR oper = toScalarAux c_toScalarR (fromei oper) foreign import ccall unsafe "gsl-aux.h toScalarR" c_toScalarR :: CInt -> TVV -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarF :: FunCodeS -> Vector Float -> Float toScalarF oper = toScalarAux c_toScalarF (fromei oper) foreign import ccall unsafe "gsl-aux.h toScalarF" c_toScalarF :: CInt -> TFF -- | obtains different functions of a vector: only norm1, norm2 toScalarC :: FunCodeS -> Vector (Complex Double) -> Double toScalarC oper = toScalarAux c_toScalarC (fromei oper) foreign import ccall unsafe "gsl-aux.h toScalarC" c_toScalarC :: CInt -> TCVV -- | obtains different functions of a vector: only norm1, norm2 toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float toScalarQ oper = toScalarAux c_toScalarQ (fromei oper) foreign import ccall unsafe "gsl-aux.h toScalarQ" c_toScalarQ :: CInt -> TQVF ------------------------------------------------------------------ -- | map of real vectors with given function vectorMapR :: FunCodeV -> Vector Double -> Vector Double vectorMapR = vectorMapAux c_vectorMapR foreign import ccall unsafe "gsl-aux.h mapR" c_vectorMapR :: CInt -> TVV -- | map of complex vectors with given function vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double) vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper) foreign import ccall unsafe "gsl-aux.h mapC" c_vectorMapC :: CInt -> TCVCV -- | map of real vectors with given function vectorMapF :: FunCodeV -> Vector Float -> Vector Float vectorMapF = vectorMapAux c_vectorMapF foreign import ccall unsafe "gsl-aux.h mapF" c_vectorMapF :: CInt -> TFF -- | map of real vectors with given function vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float) vectorMapQ = vectorMapAux c_vectorMapQ foreign import ccall unsafe "gsl-aux.h mapQ" c_vectorMapQ :: CInt -> TQVQV ------------------------------------------------------------------- -- | map of real vectors with given function vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper) foreign import ccall unsafe "gsl-aux.h mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV -- | map of complex vectors with given function vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double) vectorMapValC = vectorMapValAux c_vectorMapValC foreign import ccall unsafe "gsl-aux.h mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TCVCV -- | map of real vectors with given function vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper) foreign import ccall unsafe "gsl-aux.h mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TFF -- | map of complex vectors with given function vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float) vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper) foreign import ccall unsafe "gsl-aux.h mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TQVQV ------------------------------------------------------------------- -- | elementwise operation on real vectors vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double vectorZipR = vectorZipAux c_vectorZipR foreign import ccall unsafe "gsl-aux.h zipR" c_vectorZipR :: CInt -> TVVV -- | elementwise operation on complex vectors vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) vectorZipC = vectorZipAux c_vectorZipC foreign import ccall unsafe "gsl-aux.h zipC" c_vectorZipC :: CInt -> TCVCVCV -- | elementwise operation on real vectors vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float vectorZipF = vectorZipAux c_vectorZipF foreign import ccall unsafe "gsl-aux.h zipF" c_vectorZipF :: CInt -> TFFF -- | elementwise operation on complex vectors vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float) vectorZipQ = vectorZipAux c_vectorZipQ foreign import ccall unsafe "gsl-aux.h zipQ" c_vectorZipQ :: CInt -> TQVQVQV ----------------------------------------------------------------------- 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 from the the mt19937 generator in GSL, with a given seed. Use randomIO to get a random seed. randomVector :: Int -- ^ seed -> RandDist -- ^ distribution -> Int -- ^ vector size -> Vector Double randomVector seed dist n = unsafePerformIO $ do r <- createVector n app1 (c_random_vector (fi seed) ((fi.fromEnum) dist)) vec r "randomVector" return r foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> TV hmatrix-0.15.0.0/lib/Numeric/GSL/gsl-ode.c0000644000000000000000000001226312165764700016104 0ustar0000000000000000 #ifdef GSLODE1 ////////////////////////////// ODE V1 ////////////////////////////////////////// #include typedef struct {int n; int (*f)(double,int, const double*, int, double *); int (*j)(double,int, const double*, int, int, double*);} Tode; int odefunc (double t, const double y[], double f[], void *params) { Tode * P = (Tode*) params; (P->f)(t,P->n,y,P->n,f); return GSL_SUCCESS; } int odejac (double t, const double y[], double *dfdy, double dfdt[], void *params) { Tode * P = ((Tode*) params); (P->j)(t,P->n,y,P->n,P->n,dfdy); int j; for (j=0; j< P->n; j++) dfdt[j] = 0.0; return GSL_SUCCESS; } int ode(int method, double h, double eps_abs, double eps_rel, int f(double, int, const double*, int, double*), int jac(double, int, const double*, int, int, double*), KRVEC(xi), KRVEC(ts), RMAT(sol)) { const gsl_odeiv_step_type * T; switch(method) { case 0 : {T = gsl_odeiv_step_rk2; break; } case 1 : {T = gsl_odeiv_step_rk4; break; } case 2 : {T = gsl_odeiv_step_rkf45; break; } case 3 : {T = gsl_odeiv_step_rkck; break; } case 4 : {T = gsl_odeiv_step_rk8pd; break; } case 5 : {T = gsl_odeiv_step_rk2imp; break; } case 6 : {T = gsl_odeiv_step_rk4imp; break; } case 7 : {T = gsl_odeiv_step_bsimp; break; } case 8 : { printf("Sorry: ODE rk1imp not available in this GSL version\n"); exit(0); } case 9 : { printf("Sorry: ODE msadams not available in this GSL version\n"); exit(0); } case 10: { printf("Sorry: ODE msbdf not available in this GSL version\n"); exit(0); } default: ERROR(BAD_CODE); } gsl_odeiv_step * s = gsl_odeiv_step_alloc (T, xin); gsl_odeiv_control * c = gsl_odeiv_control_y_new (eps_abs, eps_rel); gsl_odeiv_evolve * e = gsl_odeiv_evolve_alloc (xin); Tode P; P.f = f; P.j = jac; P.n = xin; gsl_odeiv_system sys = {odefunc, odejac, xin, &P}; double t = tsp[0]; double* y = (double*)calloc(xin,sizeof(double)); int i,j; for(i=0; i< xin; i++) { y[i] = xip[i]; solp[i] = xip[i]; } for (i = 1; i < tsn ; i++) { double ti = tsp[i]; while (t < ti) { gsl_odeiv_evolve_apply (e, c, s, &sys, &t, ti, &h, y); // if (h < hmin) h = hmin; } for(j=0; j typedef struct {int n; int (*f)(double,int, const double*, int, double *); int (*j)(double,int, const double*, int, int, double*);} Tode; int odefunc (double t, const double y[], double f[], void *params) { Tode * P = (Tode*) params; (P->f)(t,P->n,y,P->n,f); return GSL_SUCCESS; } int odejac (double t, const double y[], double *dfdy, double dfdt[], void *params) { Tode * P = ((Tode*) params); (P->j)(t,P->n,y,P->n,P->n,dfdy); int j; for (j=0; j< P->n; j++) dfdt[j] = 0.0; return GSL_SUCCESS; } int ode(int method, double h, double eps_abs, double eps_rel, int f(double, int, const double*, int, double*), int jac(double, int, const double*, int, int, double*), KRVEC(xi), KRVEC(ts), RMAT(sol)) { const gsl_odeiv2_step_type * T; switch(method) { case 0 : {T = gsl_odeiv2_step_rk2; break; } case 1 : {T = gsl_odeiv2_step_rk4; break; } case 2 : {T = gsl_odeiv2_step_rkf45; break; } case 3 : {T = gsl_odeiv2_step_rkck; break; } case 4 : {T = gsl_odeiv2_step_rk8pd; break; } case 5 : {T = gsl_odeiv2_step_rk2imp; break; } case 6 : {T = gsl_odeiv2_step_rk4imp; break; } case 7 : {T = gsl_odeiv2_step_bsimp; break; } case 8 : {T = gsl_odeiv2_step_rk1imp; break; } case 9 : {T = gsl_odeiv2_step_msadams; break; } case 10: {T = gsl_odeiv2_step_msbdf; break; } default: ERROR(BAD_CODE); } Tode P; P.f = f; P.j = jac; P.n = xin; gsl_odeiv2_system sys = {odefunc, odejac, xin, &P}; gsl_odeiv2_driver * d = gsl_odeiv2_driver_alloc_y_new (&sys, T, h, eps_abs, eps_rel); double t = tsp[0]; double* y = (double*)calloc(xin,sizeof(double)); int i,j; int status; for(i=0; i< xin; i++) { y[i] = xip[i]; solp[i] = xip[i]; } for (i = 1; i < tsn ; i++) { double ti = tsp[i]; status = gsl_odeiv2_driver_apply (d, &t, ti, y); if (status != GSL_SUCCESS) { printf ("error in ode, return value=%d\n", status); break; } // printf ("%.5e %.5e %.5e\n", t, y[0], y[1]); for(j=0; j The example in the GSL manual: @import Numeric.GSL import Numeric.LinearAlgebra(format) import Text.Printf(printf) rosenbrock a b [x,y] = [ a*(1-x), b*(y-x^2) ] disp = putStrLn . format \" \" (printf \"%.3f\") main = do let (sol,path) = root Hybrids 1E-7 30 (rosenbrock 1 10) [-10,-5] print sol disp path \> main [1.0,1.0] 0.000 -10.000 -5.000 11.000 -1050.000 1.000 -3.976 24.827 4.976 90.203 2.000 -3.976 24.827 4.976 90.203 3.000 -3.976 24.827 4.976 90.203 4.000 -1.274 -5.680 2.274 -73.018 5.000 -1.274 -5.680 2.274 -73.018 6.000 0.249 0.298 0.751 2.359 7.000 0.249 0.298 0.751 2.359 8.000 1.000 0.878 -0.000 -1.218 9.000 1.000 0.989 -0.000 -0.108 10.000 1.000 1.000 0.000 0.000 @ -} ----------------------------------------------------------------------------- module Numeric.GSL.Root ( uniRoot, UniRootMethod(..), uniRootJ, UniRootMethodJ(..), root, RootMethod(..), rootJ, RootMethodJ(..), ) where import Data.Packed.Internal import Data.Packed.Matrix import Numeric.GSL.Internal import Foreign.Ptr(FunPtr, freeHaskellFunPtr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) ------------------------------------------------------------------------- data UniRootMethod = Bisection | FalsePos | Brent deriving (Enum, Eq, Show, Bounded) uniRoot :: UniRootMethod -> Double -> Int -> (Double -> Double) -> Double -> Double -> (Double, Matrix Double) uniRoot method epsrel maxit fun xl xu = uniRootGen (fi (fromEnum method)) fun xl xu epsrel maxit uniRootGen m f xl xu epsrel maxit = unsafePerformIO $ do fp <- mkDoublefun f rawpath <- createMIO maxit 4 (c_root m fp epsrel (fi maxit) xl xu) "root" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath [sol] = toLists $ dropRows (it-1) path freeHaskellFunPtr fp return (sol !! 1, path) foreign import ccall safe "root" c_root:: CInt -> FunPtr (Double -> Double) -> Double -> CInt -> Double -> Double -> TM ------------------------------------------------------------------------- data UniRootMethodJ = UNewton | Secant | Steffenson deriving (Enum, Eq, Show, Bounded) uniRootJ :: UniRootMethodJ -> Double -> Int -> (Double -> Double) -> (Double -> Double) -> Double -> (Double, Matrix Double) uniRootJ method epsrel maxit fun dfun x = uniRootJGen (fi (fromEnum method)) fun dfun x epsrel maxit uniRootJGen m f df x epsrel maxit = unsafePerformIO $ do fp <- mkDoublefun f dfp <- mkDoublefun df rawpath <- createMIO maxit 2 (c_rootj m fp dfp epsrel (fi maxit) x) "rootj" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath [sol] = toLists $ dropRows (it-1) path freeHaskellFunPtr fp return (sol !! 1, path) foreign import ccall safe "rootj" c_rootj :: CInt -> FunPtr (Double -> Double) -> FunPtr (Double -> Double) -> Double -> CInt -> Double -> TM ------------------------------------------------------------------------- data RootMethod = Hybrids | Hybrid | DNewton | Broyden deriving (Enum,Eq,Show,Bounded) -- | Nonlinear multidimensional root finding using algorithms that do not require -- any derivative information to be supplied by the user. -- Any derivatives needed are approximated by finite differences. root :: RootMethod -> Double -- ^ maximum residual -> Int -- ^ maximum number of iterations allowed -> ([Double] -> [Double]) -- ^ function to minimize -> [Double] -- ^ starting point -> ([Double], Matrix Double) -- ^ solution vector and optimization path root method epsabs maxit fun xinit = rootGen (fi (fromEnum method)) fun xinit epsabs maxit rootGen m f xi epsabs maxit = unsafePerformIO $ do let xiv = fromList xi n = dim xiv fp <- mkVecVecfun (aux_vTov (checkdim1 n . fromList . f . toList)) rawpath <- vec xiv $ \xiv' -> createMIO maxit (2*n+1) (c_multiroot m fp epsabs (fi maxit) // xiv') "multiroot" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath [sol] = toLists $ dropRows (it-1) path freeHaskellFunPtr fp return (take n $ drop 1 sol, path) foreign import ccall safe "multiroot" c_multiroot:: CInt -> FunPtr TVV -> Double -> CInt -> TVM ------------------------------------------------------------------------- data RootMethodJ = HybridsJ | HybridJ | Newton | GNewton deriving (Enum,Eq,Show,Bounded) -- | Nonlinear multidimensional root finding using both the function and its derivatives. rootJ :: RootMethodJ -> Double -- ^ maximum residual -> Int -- ^ maximum number of iterations allowed -> ([Double] -> [Double]) -- ^ function to minimize -> ([Double] -> [[Double]]) -- ^ Jacobian -> [Double] -- ^ starting point -> ([Double], Matrix Double) -- ^ solution vector and optimization path rootJ method epsabs maxit fun jac xinit = rootJGen (fi (fromEnum method)) fun jac xinit epsabs maxit rootJGen m f jac xi epsabs maxit = unsafePerformIO $ do let xiv = fromList xi n = dim xiv fp <- mkVecVecfun (aux_vTov (checkdim1 n . fromList . f . toList)) jp <- mkVecMatfun (aux_vTom (checkdim2 n . fromLists . jac . toList)) rawpath <- vec xiv $ \xiv' -> createMIO maxit (2*n+1) (c_multirootj m fp jp epsabs (fi maxit) // xiv') "multiroot" let it = round (rawpath @@> (maxit-1,0)) path = takeRows it rawpath [sol] = toLists $ dropRows (it-1) path freeHaskellFunPtr fp freeHaskellFunPtr jp return (take n $ drop 1 sol, path) foreign import ccall safe "multirootj" c_multirootj:: CInt -> FunPtr TVV -> FunPtr TVM -> Double -> CInt -> TVM ------------------------------------------------------- checkdim1 n v | dim v == n = v | otherwise = error $ "Error: "++ show n ++ " components expected in the result of the function supplied to root" checkdim2 n m | rows m == n && cols m == n = m | otherwise = error $ "Error: "++ show n ++ "x" ++ show n ++ " Jacobian expected in rootJ" hmatrix-0.15.0.0/lib/Numeric/GSL/ODE.hs0000644000000000000000000001365312165764700015355 0ustar0000000000000000{- | Module : Numeric.GSL.ODE Copyright : (c) Alberto Ruiz 2010 License : GPL Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Solution of ordinary differential equation (ODE) initial value problems. A simple example: @import Numeric.GSL import Numeric.LinearAlgebra import Graphics.Plot xdot t [x,v] = [v, -0.95*x - 0.1*v] ts = linspace 100 (0,20 :: Double) sol = odeSolve xdot [10,0] ts main = mplot (ts : toColumns sol)@ -} ----------------------------------------------------------------------------- module Numeric.GSL.ODE ( odeSolve, odeSolveV, ODEMethod(..), Jacobian ) where import Data.Packed.Internal import Numeric.GSL.Internal import Foreign.Ptr(FunPtr, nullFunPtr, freeHaskellFunPtr) import Foreign.C.Types import System.IO.Unsafe(unsafePerformIO) ------------------------------------------------------------------------- type Jacobian = Double -> Vector Double -> Matrix Double -- | Stepping functions data ODEMethod = RK2 -- ^ Embedded Runge-Kutta (2, 3) method. | RK4 -- ^ 4th order (classical) Runge-Kutta. The error estimate is obtained by halving the step-size. For more efficient estimate of the error, use the embedded methods. | RKf45 -- ^ Embedded Runge-Kutta-Fehlberg (4, 5) method. This method is a good general-purpose integrator. | RKck -- ^ Embedded Runge-Kutta Cash-Karp (4, 5) method. | RK8pd -- ^ Embedded Runge-Kutta Prince-Dormand (8,9) method. | RK2imp Jacobian -- ^ Implicit 2nd order Runge-Kutta at Gaussian points. | RK4imp Jacobian -- ^ Implicit 4th order Runge-Kutta at Gaussian points. | BSimp Jacobian -- ^ Implicit Bulirsch-Stoer method of Bader and Deuflhard. The method is generally suitable for stiff problems. | RK1imp Jacobian -- ^ Implicit Gaussian first order Runge-Kutta. Also known as implicit Euler or backward Euler method. Error estimation is carried out by the step doubling method. | MSAdams -- ^ A variable-coefficient linear multistep Adams method in Nordsieck form. This stepper uses explicit Adams-Bashforth (predictor) and implicit Adams-Moulton (corrector) methods in P(EC)^m functional iteration mode. Method order varies dynamically between 1 and 12. | MSBDF Jacobian -- ^ A variable-coefficient linear multistep backward differentiation formula (BDF) method in Nordsieck form. This stepper uses the explicit BDF formula as predictor and implicit BDF formula as corrector. A modified Newton iteration method is used to solve the system of non-linear equations. Method order varies dynamically between 1 and 5. The method is generally suitable for stiff problems. -- | A version of 'odeSolveV' with reasonable default parameters and system of equations defined using lists. odeSolve :: (Double -> [Double] -> [Double]) -- ^ xdot(t,x) -> [Double] -- ^ initial conditions -> Vector Double -- ^ desired solution times -> Matrix Double -- ^ solution odeSolve xdot xi ts = odeSolveV RKf45 hi epsAbs epsRel (l2v xdot) (fromList xi) ts where hi = (ts@>1 - ts@>0)/100 epsAbs = 1.49012e-08 epsRel = 1.49012e-08 l2v f = \t -> fromList . f t . toList -- | Evolution of the system with adaptive step-size control. odeSolveV :: ODEMethod -> Double -- ^ initial step size -> Double -- ^ absolute tolerance for the state vector -> Double -- ^ relative tolerance for the state vector -> (Double -> Vector Double -> Vector Double) -- ^ xdot(t,x) -> Vector Double -- ^ initial conditions -> Vector Double -- ^ desired solution times -> Matrix Double -- ^ solution odeSolveV RK2 = odeSolveV' 0 Nothing odeSolveV RK4 = odeSolveV' 1 Nothing odeSolveV RKf45 = odeSolveV' 2 Nothing odeSolveV RKck = odeSolveV' 3 Nothing odeSolveV RK8pd = odeSolveV' 4 Nothing odeSolveV (RK2imp jac) = odeSolveV' 5 (Just jac) odeSolveV (RK4imp jac) = odeSolveV' 6 (Just jac) odeSolveV (BSimp jac) = odeSolveV' 7 (Just jac) odeSolveV (RK1imp jac) = odeSolveV' 8 (Just jac) odeSolveV MSAdams = odeSolveV' 9 Nothing odeSolveV (MSBDF jac) = odeSolveV' 10 (Just jac) odeSolveV' :: CInt -> Maybe (Double -> Vector Double -> Matrix Double) -- ^ optional jacobian -> Double -- ^ initial step size -> Double -- ^ absolute tolerance for the state vector -> Double -- ^ relative tolerance for the state vector -> (Double -> Vector Double -> Vector Double) -- ^ xdot(t,x) -> Vector Double -- ^ initial conditions -> Vector Double -- ^ desired solution times -> Matrix Double -- ^ solution odeSolveV' method mbjac h epsAbs epsRel f xiv ts = unsafePerformIO $ do let n = dim xiv fp <- mkDoubleVecVecfun (\t -> aux_vTov (checkdim1 n . f t)) jp <- case mbjac of Just jac -> mkDoubleVecMatfun (\t -> aux_vTom (checkdim2 n . jac t)) Nothing -> return nullFunPtr sol <- vec xiv $ \xiv' -> vec (checkTimes ts) $ \ts' -> createMIO (dim ts) n (ode_c (method) h epsAbs epsRel fp jp // xiv' // ts' ) "ode" freeHaskellFunPtr fp return sol foreign import ccall safe "ode" ode_c :: CInt -> Double -> Double -> Double -> FunPtr (Double -> TVV) -> FunPtr (Double -> TVM) -> TVVM ------------------------------------------------------- checkdim1 n v | dim v == n = v | otherwise = error $ "Error: "++ show n ++ " components expected in the result of the function supplied to odeSolve" checkdim2 n m | rows m == n && cols m == n = m | otherwise = error $ "Error: "++ show n ++ "x" ++ show n ++ " Jacobian expected in odeSolve" checkTimes ts | dim ts > 1 && all (>0) (zipWith subtract ts' (tail ts')) = ts | otherwise = error "odeSolve requires increasing times" where ts' = toList ts hmatrix-0.15.0.0/lib/Numeric/GSL/Integration.hs0000644000000000000000000001563412165764700017232 0ustar0000000000000000{-# OPTIONS #-} ----------------------------------------------------------------------------- {- | Module : Numeric.GSL.Integration Copyright : (c) Alberto Ruiz 2006 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Numerical integration routines. -} ----------------------------------------------------------------------------- module Numeric.GSL.Integration ( integrateQNG, integrateQAGS, integrateQAGI, integrateQAGIU, integrateQAGIL ) where import Foreign.C.Types import Foreign.Marshal.Alloc(malloc, free) import Foreign.Ptr(Ptr, FunPtr, freeHaskellFunPtr) import Foreign.Storable(peek) import Data.Packed.Internal(check,(//)) import System.IO.Unsafe(unsafePerformIO) {- | conversion of Haskell functions into function pointers that can be used in the C side -} foreign import ccall safe "wrapper" mkfun:: (Double -> Ptr() -> Double) -> IO( FunPtr (Double -> Ptr() -> Double)) -------------------------------------------------------------------- {- | Numerical integration using /gsl_integration_qags/ (adaptive integration with singularities). For example: @\> let quad = integrateQAGS 1E-9 1000 \> let f a x = x**(-0.5) * log (a*x) \> quad (f 1) 0 1 (-3.999999999999974,4.871658632055187e-13)@ -} integrateQAGS :: Double -- ^ precision (e.g. 1E-9) -> Int -- ^ size of auxiliary workspace (e.g. 1000) -> (Double -> Double) -- ^ function to be integrated on the interval (a,b) -> Double -- ^ a -> Double -- ^ b -> (Double, Double) -- ^ result of the integration and error integrateQAGS prec n f a b = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\x _ -> f x) c_integrate_qags fp a b prec (fromIntegral n) r e // check "integrate_qags" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h integrate_qags" c_integrate_qags :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> Double -> CInt -> Ptr Double -> Ptr Double -> IO CInt ----------------------------------------------------------------- {- | Numerical integration using /gsl_integration_qng/ (useful for fast integration of smooth functions). For example: @\> let quad = integrateQNG 1E-6 \> quad (\\x -> 4\/(1+x*x)) 0 1 (3.141592653589793,3.487868498008632e-14)@ -} integrateQNG :: Double -- ^ precision (e.g. 1E-9) -> (Double -> Double) -- ^ function to be integrated on the interval (a,b) -> Double -- ^ a -> Double -- ^ b -> (Double, Double) -- ^ result of the integration and error integrateQNG prec f a b = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\x _ -> f x) c_integrate_qng fp a b prec r e // check "integrate_qng" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h integrate_qng" c_integrate_qng :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> Double -> Ptr Double -> Ptr Double -> IO CInt -------------------------------------------------------------------- {- | Numerical integration using /gsl_integration_qagi/ (integration over the infinite integral -Inf..Inf using QAGS). For example: @\> let quad = integrateQAGI 1E-9 1000 \> let f a x = exp(-a * x^2) \> quad (f 0.5) (2.5066282746310002,6.229215880648858e-11)@ -} integrateQAGI :: Double -- ^ precision (e.g. 1E-9) -> Int -- ^ size of auxiliary workspace (e.g. 1000) -> (Double -> Double) -- ^ function to be integrated on the interval (-Inf,Inf) -> (Double, Double) -- ^ result of the integration and error integrateQAGI prec n f = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\x _ -> f x) c_integrate_qagi fp prec (fromIntegral n) r e // check "integrate_qagi" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h integrate_qagi" c_integrate_qagi :: FunPtr (Double-> Ptr() -> Double) -> Double -> CInt -> Ptr Double -> Ptr Double -> IO CInt -------------------------------------------------------------------- {- | Numerical integration using /gsl_integration_qagiu/ (integration over the semi-infinite integral a..Inf). For example: @\> let quad = integrateQAGIU 1E-9 1000 \> let f a x = exp(-a * x^2) \> quad (f 0.5) 0 (1.2533141373155001,3.114607940324429e-11)@ -} integrateQAGIU :: Double -- ^ precision (e.g. 1E-9) -> Int -- ^ size of auxiliary workspace (e.g. 1000) -> (Double -> Double) -- ^ function to be integrated on the interval (a,Inf) -> Double -- ^ a -> (Double, Double) -- ^ result of the integration and error integrateQAGIU prec n f a = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\x _ -> f x) c_integrate_qagiu fp a prec (fromIntegral n) r e // check "integrate_qagiu" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h integrate_qagiu" c_integrate_qagiu :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> CInt -> Ptr Double -> Ptr Double -> IO CInt -------------------------------------------------------------------- {- | Numerical integration using /gsl_integration_qagil/ (integration over the semi-infinite integral -Inf..b). For example: @\> let quad = integrateQAGIL 1E-9 1000 \> let f a x = exp(-a * x^2) \> quad (f 0.5) 0 (1.2533141373155001,3.114607940324429e-11)@ -} integrateQAGIL :: Double -- ^ precision (e.g. 1E-9) -> Int -- ^ size of auxiliary workspace (e.g. 1000) -> (Double -> Double) -- ^ function to be integrated on the interval (a,Inf) -> Double -- ^ b -> (Double, Double) -- ^ result of the integration and error integrateQAGIL prec n f b = unsafePerformIO $ do r <- malloc e <- malloc fp <- mkfun (\x _ -> f x) c_integrate_qagil fp b prec (fromIntegral n) r e // check "integrate_qagil" vr <- peek r ve <- peek e let result = (vr,ve) free r free e freeHaskellFunPtr fp return result foreign import ccall safe "gsl-aux.h integrate_qagil" c_integrate_qagil :: FunPtr (Double-> Ptr() -> Double) -> Double -> Double -> CInt -> Ptr Double -> Ptr Double -> IO CInt hmatrix-0.15.0.0/lib/Numeric/GSL/Polynomials.hs0000644000000000000000000000331012165764700017241 0ustar0000000000000000{-# LANGUAGE CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- {- | Module : Numeric.GSL.Polynomials Copyright : (c) Alberto Ruiz 2006 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Polynomials. -} ----------------------------------------------------------------------------- module Numeric.GSL.Polynomials ( polySolve ) where import Data.Packed.Internal import Data.Complex import System.IO.Unsafe (unsafePerformIO) #if __GLASGOW_HASKELL__ >= 704 import Foreign.C.Types (CInt(..)) #endif {- | Solution of general polynomial equations, using /gsl_poly_complex_solve/. For example, the three solutions of x^3 + 8 = 0 @\> polySolve [8,0,0,1] [(-1.9999999999999998) :+ 0.0, 1.0 :+ 1.732050807568877, 1.0 :+ (-1.732050807568877)]@ The example in the GSL manual: To find the roots of x^5 -1 = 0: @\> polySolve [-1, 0, 0, 0, 0, 1] [(-0.8090169943749475) :+ 0.5877852522924731, (-0.8090169943749475) :+ (-0.5877852522924731), 0.30901699437494734 :+ 0.9510565162951536, 0.30901699437494734 :+ (-0.9510565162951536), 1.0 :+ 0.0]@ -} polySolve :: [Double] -> [Complex Double] polySolve = toList . polySolve' . fromList polySolve' :: Vector Double -> Vector (Complex Double) polySolve' v | dim v > 1 = unsafePerformIO $ do r <- createVector (dim v-1) app2 c_polySolve vec v vec r "polySolve" return r | otherwise = error "polySolve on a polynomial of degree zero" foreign import ccall unsafe "gsl-aux.h polySolve" c_polySolve:: TVCV hmatrix-0.15.0.0/lib/Numeric/GSL/gsl-aux.c0000644000000000000000000011622012165764700016130 0ustar0000000000000000#include #define RVEC(A) int A##n, double*A##p #define RMAT(A) int A##r, int A##c, double* A##p #define KRVEC(A) int A##n, const double*A##p #define KRMAT(A) int A##r, int A##c, const double* A##p #define CVEC(A) int A##n, gsl_complex*A##p #define CMAT(A) int A##r, int A##c, gsl_complex* A##p #define KCVEC(A) int A##n, const gsl_complex*A##p #define KCMAT(A) int A##r, int A##c, const gsl_complex* A##p #define FVEC(A) int A##n, float*A##p #define FMAT(A) int A##r, int A##c, float* A##p #define KFVEC(A) int A##n, const float*A##p #define KFMAT(A) int A##r, int A##c, const float* A##p #define QVEC(A) int A##n, gsl_complex_float*A##p #define QMAT(A) int A##r, int A##c, gsl_complex_float* A##p #define KQVEC(A) int A##n, const gsl_complex_float*A##p #define KQMAT(A) int A##r, int A##c, const gsl_complex_float* A##p #include #include #include #include #include #include #include #include #include #include #include #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;) #ifdef DBG #define DEBUGMAT(MSG,X) printf(MSG" = \n"); gsl_matrix_fprintf(stdout,X,"%f"); printf("\n"); #else #define DEBUGMAT(MSG,X) #endif #ifdef DBG #define DEBUGVEC(MSG,X) printf(MSG" = \n"); gsl_vector_fprintf(stdout,X,"%f"); printf("\n"); #else #define DEBUGVEC(MSG,X) #endif #define DVVIEW(A) gsl_vector_view A = gsl_vector_view_array(A##p,A##n) #define DMVIEW(A) gsl_matrix_view A = gsl_matrix_view_array(A##p,A##r,A##c) #define CVVIEW(A) gsl_vector_complex_view A = gsl_vector_complex_view_array((double*)A##p,A##n) #define CMVIEW(A) gsl_matrix_complex_view A = gsl_matrix_complex_view_array((double*)A##p,A##r,A##c) #define KDVVIEW(A) gsl_vector_const_view A = gsl_vector_const_view_array(A##p,A##n) #define KDMVIEW(A) gsl_matrix_const_view A = gsl_matrix_const_view_array(A##p,A##r,A##c) #define KCVVIEW(A) gsl_vector_complex_const_view A = gsl_vector_complex_const_view_array((double*)A##p,A##n) #define KCMVIEW(A) gsl_matrix_complex_const_view A = gsl_matrix_complex_const_view_array((double*)A##p,A##r,A##c) #define FVVIEW(A) gsl_vector_float_view A = gsl_vector_float_view_array(A##p,A##n) #define FMVIEW(A) gsl_matrix_float_view A = gsl_matrix_float_view_array(A##p,A##r,A##c) #define QVVIEW(A) gsl_vector_complex_float_view A = gsl_vector_float_complex_view_array((float*)A##p,A##n) #define QMVIEW(A) gsl_matrix_complex_float_view A = gsl_matrix_float_complex_view_array((float*)A##p,A##r,A##c) #define KFVVIEW(A) gsl_vector_float_const_view A = gsl_vector_float_const_view_array(A##p,A##n) #define KFMVIEW(A) gsl_matrix_float_const_view A = gsl_matrix_float_const_view_array(A##p,A##r,A##c) #define KQVVIEW(A) gsl_vector_complex_float_const_view A = gsl_vector_complex_float_const_view_array((float*)A##p,A##n) #define KQMVIEW(A) gsl_matrix_complex_float_const_view A = gsl_matrix_complex_float_const_view_array((float*)A##p,A##r,A##c) #define V(a) (&a.vector) #define M(a) (&a.matrix) #define GCVEC(A) int A##n, gsl_complex*A##p #define KGCVEC(A) int A##n, const gsl_complex*A##p #define GQVEC(A) int A##n, gsl_complex_float*A##p #define KGQVEC(A) int A##n, const gsl_complex_float*A##p #define BAD_SIZE 2000 #define BAD_CODE 2001 #define MEM 2002 #define BAD_FILE 2003 void no_abort_on_error() { gsl_set_error_handler_off(); } 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(KRVEC(x),RVEC(r)) { DEBUGMSG("sumR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumQ(KQVEC(x),QVEC(r)) { DEBUGMSG("sumQ"); REQUIRES(rn==1,BAD_SIZE); int i; gsl_complex_float res; res.dat[0] = 0; res.dat[1] = 0; for (i = 0; i < xn; i++) { res.dat[0] += xp[i].dat[0]; res.dat[1] += xp[i].dat[1]; } rp[0] = res; OK } int sumC(KCVEC(x),CVEC(r)) { DEBUGMSG("sumC"); REQUIRES(rn==1,BAD_SIZE); int i; gsl_complex res; res.dat[0] = 0; res.dat[1] = 0; for (i = 0; i < xn; i++) { res.dat[0] += xp[i].dat[0]; res.dat[1] += xp[i].dat[1]; } 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(KRVEC(x),RVEC(r)) { DEBUGMSG("prodR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodQ(KQVEC(x),QVEC(r)) { DEBUGMSG("prodQ"); REQUIRES(rn==1,BAD_SIZE); int i; gsl_complex_float res; float temp; res.dat[0] = 1; res.dat[1] = 0; for (i = 0; i < xn; i++) { temp = res.dat[0] * xp[i].dat[0] - res.dat[1] * xp[i].dat[1]; res.dat[1] = res.dat[0] * xp[i].dat[1] + res.dat[1] * xp[i].dat[0]; res.dat[0] = temp; } rp[0] = res; OK } int prodC(KCVEC(x),CVEC(r)) { DEBUGMSG("prodC"); REQUIRES(rn==1,BAD_SIZE); int i; gsl_complex res; double temp; res.dat[0] = 1; res.dat[1] = 0; for (i = 0; i < xn; i++) { temp = res.dat[0] * xp[i].dat[0] - res.dat[1] * xp[i].dat[1]; res.dat[1] = res.dat[0] * xp[i].dat[1] + res.dat[1] * xp[i].dat[0]; res.dat[0] = temp; } rp[0] = res; OK } int dotF(KFVEC(x), KFVEC(y), FVEC(r)) { DEBUGMSG("dotF"); REQUIRES(xn==yn,BAD_SIZE); REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("dotF"); KFVVIEW(x); KFVVIEW(y); gsl_blas_sdot(V(x),V(y),rp); OK } int dotR(KRVEC(x), KRVEC(y), RVEC(r)) { DEBUGMSG("dotR"); REQUIRES(xn==yn,BAD_SIZE); REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("dotR"); KDVVIEW(x); KDVVIEW(y); gsl_blas_ddot(V(x),V(y),rp); OK } int dotQ(KQVEC(x), KQVEC(y), QVEC(r)) { DEBUGMSG("dotQ"); REQUIRES(xn==yn,BAD_SIZE); REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("dotQ"); KQVVIEW(x); KQVVIEW(y); gsl_blas_cdotu(V(x),V(y),rp); OK } int dotC(KCVEC(x), KCVEC(y), CVEC(r)) { DEBUGMSG("dotC"); REQUIRES(xn==yn,BAD_SIZE); REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("dotC"); KCVVIEW(x); KCVVIEW(y); gsl_blas_zdotu(V(x),V(y),rp); OK } int toScalarR(int code, KRVEC(x), RVEC(r)) { REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("toScalarR"); KDVVIEW(x); double res; switch(code) { case 0: { res = gsl_blas_dnrm2(V(x)); break; } case 1: { res = gsl_blas_dasum(V(x)); break; } case 2: { res = gsl_vector_max_index(V(x)); break; } case 3: { res = gsl_vector_max(V(x)); break; } case 4: { res = gsl_vector_min_index(V(x)); break; } case 5: { res = gsl_vector_min(V(x)); break; } default: ERROR(BAD_CODE); } rp[0] = res; OK } int toScalarF(int code, KFVEC(x), FVEC(r)) { REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("toScalarF"); KFVVIEW(x); float res; switch(code) { case 0: { res = gsl_blas_snrm2(V(x)); break; } case 1: { res = gsl_blas_sasum(V(x)); break; } case 2: { res = gsl_vector_float_max_index(V(x)); break; } case 3: { res = gsl_vector_float_max(V(x)); break; } case 4: { res = gsl_vector_float_min_index(V(x)); break; } case 5: { res = gsl_vector_float_min(V(x)); break; } default: ERROR(BAD_CODE); } rp[0] = res; OK } int toScalarC(int code, KCVEC(x), RVEC(r)) { REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("toScalarC"); KCVVIEW(x); double res; switch(code) { case 0: { res = gsl_blas_dznrm2(V(x)); break; } case 1: { res = gsl_blas_dzasum(V(x)); break; } default: ERROR(BAD_CODE); } rp[0] = res; OK } int toScalarQ(int code, KQVEC(x), FVEC(r)) { REQUIRES(rn==1,BAD_SIZE); DEBUGMSG("toScalarQ"); KQVVIEW(x); float res; switch(code) { case 0: { res = gsl_blas_scnrm2(V(x)); break; } case 1: { res = gsl_blas_scasum(V(x)); break; } default: ERROR(BAD_CODE); } rp[0] = res; OK } inline double sign(double x) { if(x>0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } inline float float_sign(float x) { if(x>0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } inline gsl_complex complex_abs(gsl_complex z) { gsl_complex r; r.dat[0] = gsl_complex_abs(z); r.dat[1] = 0; return r; } inline gsl_complex complex_signum(gsl_complex z) { gsl_complex r; double mag; if (z.dat[0] == 0 && z.dat[1] == 0) { r.dat[0] = 0; r.dat[1] = 0; } else { mag = gsl_complex_abs(z); r.dat[0] = z.dat[0]/mag; r.dat[1] = z.dat[1]/mag; } return r; } #define OP(C,F) case C: { for(k=0;k1,BAD_SIZE); gsl_poly_complex_workspace * w = gsl_poly_complex_workspace_alloc (an); int res = gsl_poly_complex_solve ((double*)ap, an, w, (double*)zp); CHECK(res,res); gsl_poly_complex_workspace_free (w); OK; } int vector_fscanf(char*filename, RVEC(a)) { DEBUGMSG("gsl_vector_fscanf"); DVVIEW(a); FILE * f = fopen(filename,"r"); CHECK(!f,BAD_FILE); int res = gsl_vector_fscanf(f,V(a)); CHECK(res,res); fclose (f); OK } int vector_fprintf(char*filename, char*fmt, RVEC(a)) { DEBUGMSG("gsl_vector_fprintf"); DVVIEW(a); FILE * f = fopen(filename,"w"); CHECK(!f,BAD_FILE); int res = gsl_vector_fprintf(f,V(a),fmt); CHECK(res,res); fclose (f); OK } int vector_fread(char*filename, RVEC(a)) { DEBUGMSG("gsl_vector_fread"); DVVIEW(a); FILE * f = fopen(filename,"r"); CHECK(!f,BAD_FILE); int res = gsl_vector_fread(f,V(a)); CHECK(res,res); fclose (f); OK } int vector_fwrite(char*filename, RVEC(a)) { DEBUGMSG("gsl_vector_fwrite"); DVVIEW(a); FILE * f = fopen(filename,"w"); CHECK(!f,BAD_FILE); int res = gsl_vector_fwrite(f,V(a)); CHECK(res,res); fclose (f); OK } int matrix_fprintf(char*filename, char*fmt, int ro, RMAT(m)) { DEBUGMSG("matrix_fprintf"); FILE * f = fopen(filename,"w"); CHECK(!f,BAD_FILE); int i,j,sr,sc; if (ro==1) { sr = mc; sc = 1;} else { sr = 1; sc = mr;} #define AT(M,r,c) (M##p[(r)*sr+(c)*sc]) for (i=0; isize,sizeof(double)); int k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } double res = f(x->size,p); free(p); return res; } // this version returns info about intermediate steps int minimize(int method, double f(int, double*), double tolsize, int maxit, KRVEC(xi), KRVEC(sz), RMAT(sol)) { REQUIRES(xin==szn && solr == maxit && solc == 3+xin,BAD_SIZE); DEBUGMSG("minimizeList (nmsimplex)"); gsl_multimin_function my_func; // extract function from pars my_func.f = only_f_aux_min; my_func.n = xin; my_func.params = f; size_t iter = 0; int status; double size; const gsl_multimin_fminimizer_type *T; gsl_multimin_fminimizer *s = NULL; // Initial vertex size vector KDVVIEW(sz); // Starting point KDVVIEW(xi); // Minimizer nmsimplex, without derivatives switch(method) { case 0 : {T = gsl_multimin_fminimizer_nmsimplex; break; } #ifdef GSL110 case 1 : {T = gsl_multimin_fminimizer_nmsimplex; break; } #else case 1 : {T = gsl_multimin_fminimizer_nmsimplex2; break; } #endif default: ERROR(BAD_CODE); } s = gsl_multimin_fminimizer_alloc (T, my_func.n); gsl_multimin_fminimizer_set (s, &my_func, V(xi), V(sz)); do { status = gsl_multimin_fminimizer_iterate (s); size = gsl_multimin_fminimizer_size (s); solp[iter*solc+0] = iter+1; solp[iter*solc+1] = s->fval; solp[iter*solc+2] = size; int k; for(k=0;kx,k); } iter++; if (status) break; status = gsl_multimin_test_size (size, tolsize); } while (status == GSL_CONTINUE && iter < maxit); int i,j; for (i=iter; isize,sizeof(double)); int k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } double res = fdf->f(x->size,p); free(p); return res; } void df_aux_min(const gsl_vector * x, void * pars, gsl_vector * g) { Tfdf * fdf = ((Tfdf*) pars); double* p = (double*)calloc(x->size,sizeof(double)); double* q = (double*)calloc(g->size,sizeof(double)); int k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } fdf->df(x->size,p,g->size,q); for(k=0;ksize;k++) { gsl_vector_set(g,k,q[k]); } free(p); free(q); } void fdf_aux_min(const gsl_vector * x, void * pars, double * f, gsl_vector * g) { *f = f_aux_min(x,pars); df_aux_min(x,pars,g); } int minimizeD(int method, double f(int, double*), int df(int, double*, int, double*), double initstep, double minimpar, double tolgrad, int maxit, KRVEC(xi), RMAT(sol)) { REQUIRES(solr == maxit && solc == 2+xin,BAD_SIZE); DEBUGMSG("minimizeWithDeriv (conjugate_fr)"); gsl_multimin_function_fdf my_func; // extract function from pars my_func.f = f_aux_min; my_func.df = df_aux_min; my_func.fdf = fdf_aux_min; my_func.n = xin; Tfdf stfdf; stfdf.f = f; stfdf.df = df; my_func.params = &stfdf; size_t iter = 0; int status; const gsl_multimin_fdfminimizer_type *T; gsl_multimin_fdfminimizer *s = NULL; // Starting point KDVVIEW(xi); // conjugate gradient fr switch(method) { case 0 : {T = gsl_multimin_fdfminimizer_conjugate_fr; break; } case 1 : {T = gsl_multimin_fdfminimizer_conjugate_pr; break; } case 2 : {T = gsl_multimin_fdfminimizer_vector_bfgs; break; } case 3 : {T = gsl_multimin_fdfminimizer_vector_bfgs2; break; } case 4 : {T = gsl_multimin_fdfminimizer_steepest_descent; break; } default: ERROR(BAD_CODE); } s = gsl_multimin_fdfminimizer_alloc (T, my_func.n); gsl_multimin_fdfminimizer_set (s, &my_func, V(xi), initstep, minimpar); do { status = gsl_multimin_fdfminimizer_iterate (s); solp[iter*solc+0] = iter+1; solp[iter*solc+1] = s->f; int k; for(k=0;kx,k); } iter++; if (status) break; status = gsl_multimin_test_gradient (s->gradient, tolgrad); } while (status == GSL_CONTINUE && iter < maxit); int i,j; for (i=iter; if)(x); } double jf_aux_uni(double x, void * pars) { uniTfjf * fjf = ((uniTfjf*) pars); return (fjf->jf)(x); } void fjf_aux_uni(double x, void * pars, double * f, double * g) { *f = f_aux_uni(x,pars); *g = jf_aux_uni(x,pars); } int rootj(int method, double f(double), double df(double), double epsrel, int maxit, double x, RMAT(sol)) { REQUIRES(solr == maxit && solc == 2,BAD_SIZE); DEBUGMSG("root_fjf"); gsl_function_fdf my_func; // extract function from pars my_func.f = f_aux_uni; my_func.df = jf_aux_uni; my_func.fdf = fjf_aux_uni; uniTfjf stfjf; stfjf.f = f; stfjf.jf = df; my_func.params = &stfjf; size_t iter = 0; int status; const gsl_root_fdfsolver_type *T; gsl_root_fdfsolver *s; // Starting point switch(method) { case 0 : {T = gsl_root_fdfsolver_newton;; break; } case 1 : {T = gsl_root_fdfsolver_secant; break; } case 2 : {T = gsl_root_fdfsolver_steffenson; break; } default: ERROR(BAD_CODE); } s = gsl_root_fdfsolver_alloc (T); gsl_root_fdfsolver_set (s, &my_func, x); do { double x0; status = gsl_root_fdfsolver_iterate (s); x0 = x; x = gsl_root_fdfsolver_root(s); solp[iter*solc+0] = iter+1; solp[iter*solc+1] = x; iter++; if (status) /* check if solver is stuck */ break; status = gsl_root_test_delta (x, x0, 0, epsrel); } while (status == GSL_CONTINUE && iter < maxit); int i; for (i=iter; isize,sizeof(double)); double* q = (double*)calloc(y->size,sizeof(double)); int k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } f(x->size,p,y->size,q); for(k=0;ksize;k++) { gsl_vector_set(y,k,q[k]); } free(p); free(q); return 0; //hmmm } int multiroot(int method, void f(int, double*, int, double*), double epsabs, int maxit, KRVEC(xi), RMAT(sol)) { REQUIRES(solr == maxit && solc == 1+2*xin,BAD_SIZE); DEBUGMSG("root_only_f"); gsl_multiroot_function my_func; // extract function from pars my_func.f = only_f_aux_multiroot; my_func.n = xin; my_func.params = f; size_t iter = 0; int status; const gsl_multiroot_fsolver_type *T; gsl_multiroot_fsolver *s; // Starting point KDVVIEW(xi); switch(method) { case 0 : {T = gsl_multiroot_fsolver_hybrids;; break; } case 1 : {T = gsl_multiroot_fsolver_hybrid; break; } case 2 : {T = gsl_multiroot_fsolver_dnewton; break; } case 3 : {T = gsl_multiroot_fsolver_broyden; break; } default: ERROR(BAD_CODE); } s = gsl_multiroot_fsolver_alloc (T, my_func.n); gsl_multiroot_fsolver_set (s, &my_func, V(xi)); do { status = gsl_multiroot_fsolver_iterate (s); solp[iter*solc+0] = iter+1; int k; for(k=0;kx,k); } for(k=xin;k<2*xin;k++) { solp[iter*solc+k+1] = gsl_vector_get(s->f,k-xin); } iter++; if (status) /* check if solver is stuck */ break; status = gsl_multiroot_test_residual (s->f, epsabs); } while (status == GSL_CONTINUE && iter < maxit); int i,j; for (i=iter; isize,sizeof(double)); double* q = (double*)calloc(y->size,sizeof(double)); int k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } (fjf->f)(x->size,p,y->size,q); for(k=0;ksize;k++) { gsl_vector_set(y,k,q[k]); } free(p); free(q); return 0; } int jf_aux(const gsl_vector * x, void * pars, gsl_matrix * jac) { Tfjf * fjf = ((Tfjf*) pars); double* p = (double*)calloc(x->size,sizeof(double)); double* q = (double*)calloc((jac->size1)*(jac->size2),sizeof(double)); int i,j,k; for(k=0;ksize;k++) { p[k] = gsl_vector_get(x,k); } (fjf->jf)(x->size,p,jac->size1,jac->size2,q); k=0; for(i=0;isize1;i++) { for(j=0;jsize2;j++){ gsl_matrix_set(jac,i,j,q[k++]); } } free(p); free(q); return 0; } int fjf_aux(const gsl_vector * x, void * pars, gsl_vector * f, gsl_matrix * g) { f_aux(x,pars,f); jf_aux(x,pars,g); return 0; } int multirootj(int method, int f(int, double*, int, double*), int jac(int, double*, int, int, double*), double epsabs, int maxit, KRVEC(xi), RMAT(sol)) { REQUIRES(solr == maxit && solc == 1+2*xin,BAD_SIZE); DEBUGMSG("root_fjf"); gsl_multiroot_function_fdf my_func; // extract function from pars my_func.f = f_aux; my_func.df = jf_aux; my_func.fdf = fjf_aux; my_func.n = xin; Tfjf stfjf; stfjf.f = f; stfjf.jf = jac; my_func.params = &stfjf; size_t iter = 0; int status; const gsl_multiroot_fdfsolver_type *T; gsl_multiroot_fdfsolver *s; // Starting point KDVVIEW(xi); switch(method) { case 0 : {T = gsl_multiroot_fdfsolver_hybridsj;; break; } case 1 : {T = gsl_multiroot_fdfsolver_hybridj; break; } case 2 : {T = gsl_multiroot_fdfsolver_newton; break; } case 3 : {T = gsl_multiroot_fdfsolver_gnewton; break; } default: ERROR(BAD_CODE); } s = gsl_multiroot_fdfsolver_alloc (T, my_func.n); gsl_multiroot_fdfsolver_set (s, &my_func, V(xi)); do { status = gsl_multiroot_fdfsolver_iterate (s); solp[iter*solc+0] = iter+1; int k; for(k=0;kx,k); } for(k=xin;k<2*xin;k++) { solp[iter*solc+k+1] = gsl_vector_get(s->f,k-xin); } iter++; if (status) /* check if solver is stuck */ break; status = gsl_multiroot_test_residual (s->f, epsabs); } while (status == GSL_CONTINUE && iter < maxit); int i,j; for (i=iter; if); int k; for(k=0;kx,k); } iter++; if (status) /* check if solver is stuck */ break; status = gsl_multifit_test_delta (s->dx, s->x, epsabs, epsrel); } while (status == GSL_CONTINUE && iter < maxit); int i,j; for (i=iter; iJ, 0.0, M(cov)); gsl_multifit_fdfsolver_free (s); OK } ////////////////////////////////////////////////////// #define RAN(C,F) case C: { for(k=0;k 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 linearSolve' :: Matrix t -> Matrix t -> Matrix t cholSolve' :: Matrix t -> Matrix t -> Matrix t linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t linearSolveLS' :: Matrix t -> Matrix t -> Matrix t eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eigSH'' :: Matrix t -> (Vector Double, Matrix t) eigOnly :: Matrix t -> Vector (Complex Double) eigOnlySH :: Matrix t -> Vector Double cholSH' :: Matrix t -> Matrix t mbCholSH' :: Matrix t -> Maybe (Matrix t) qr' :: Matrix t -> (Matrix t, 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) ?? cholSolve' = cholSolveR linearSolveLS' = linearSolveLSR linearSolveSVD' = linearSolveSVDR Nothing eig' = eigR eigSH'' = eigS eigOnly = eigOnlyR eigOnlySH = eigOnlyS cholSH' = cholS mbCholSH' = mbCholS qr' = unpackQR . qrR hess' = unpackHess hessR schur' = schurR instance Field (Complex Double) where #ifdef NOZGESDD svd' = svdC thinSVD' = thinSVDC #else svd' = svdCd thinSVD' = thinSVDCd #endif sv' = svC luPacked' = luC luSolve' (l_u,perm) = lusC l_u perm linearSolve' = linearSolveC cholSolve' = cholSolveC linearSolveLS' = linearSolveLSC linearSolveSVD' = linearSolveSVDC Nothing eig' = eigC eigOnly = eigOnlyC eigSH'' = eigH eigOnlySH = eigOnlyH cholSH' = cholH mbCholSH' = mbCholH qr' = unpackQR . qrC hess' = unpackHess hessC schur' = schurC -------------------------------------------------------------- square m = rows m == cols m vertical m = rows m >= cols m exactHermitian m = m `equal` ctrans m -------------------------------------------------------------- -- | Full singular value decomposition. svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) svd = {-# SCC "svd" #-} svd' -- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@. -- -- If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> trans v@. thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) thinSVD = {-# SCC "thinSVD" #-} thinSVD' -- | Singular values only. singularValues :: Field t => Matrix t -> Vector Double singularValues = {-# SCC "singularValues" #-} sv' -- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values. -- -- If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> trans 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. 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. 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. leftSV :: Field t => Matrix t -> (Matrix t, Vector Double) leftSV m | vertical m = let (u,s,_) = svd m in (u,s) | otherwise = let (u,s,_) = thinSVD m in (u,s) -------------------------------------------------------------- -- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'. luPacked :: Field t => Matrix t -> (Matrix t, [Int]) luPacked = {-# SCC "luPacked" #-} luPacked' -- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'. luSolve :: Field t => (Matrix t, [Int]) -> Matrix t -> Matrix t luSolve = {-# SCC "luSolve" #-} luSolve' -- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. -- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system. linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t linearSolve = {-# SCC "linearSolve" #-} linearSolve' -- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'. cholSolve :: Field t => Matrix t -> Matrix t -> Matrix t cholSolve = {-# SCC "cholSolve" #-} cholSolve' -- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value. linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD' -- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'. linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS' -------------------------------------------------------------- -- | Eigenvalues and eigenvectors of a general square matrix. -- -- If @(s,v) = eig m@ then @m \<> v == v \<> diag s@ eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eig = {-# SCC "eig" #-} eig' -- | Eigenvalues 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 of a complex hermitian or real symmetric matrix. -- -- If @(s,v) = eigSH m@ then @m == v \<> diag s \<> ctrans v@ eigSH :: Field t => Matrix t -> (Vector Double, Matrix t) eigSH m | exactHermitian m = eigSH' m | otherwise = error "eigSH requires complex hermitian or real symmetric matrix" -- | Eigenvalues of a complex hermitian or real symmetric matrix. eigenvaluesSH :: Field t => Matrix t -> Vector Double eigenvaluesSH m | exactHermitian m = eigenvaluesSH' m | otherwise = error "eigenvaluesSH requires complex hermitian or real symmetric matrix" -------------------------------------------------------------- -- | QR factorization. -- -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. qr :: Field t => Matrix t -> (Matrix t, Matrix t) qr = {-# SCC "qr" #-} qr' -- | RQ factorization. -- -- If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular. rq :: Field t => Matrix t -> (Matrix t, Matrix t) rq m = {-# SCC "rq" #-} (r,q) where (q',r') = qr $ trans $ rev1 m r = rev2 (trans r') q = rev2 (trans q') rev1 = flipud . fliprl rev2 = fliprl . flipud -- | Hessenberg factorization. -- -- If @(p,h) = hess m@ then @m == p \<> h \<> ctrans p@, where p is unitary -- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal). hess :: Field t => Matrix t -> (Matrix t, Matrix t) hess = hess' -- | Schur factorization. -- -- If @(u,s) = schur m@ then @m == u \<> s \<> ctrans u@, where u is unitary -- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is -- upper triangular in 2x2 blocks. -- -- \"Anything that the Jordan decomposition can do, the Schur decomposition -- can do better!\" (Van Loan) schur :: Field t => Matrix t -> (Matrix t, Matrix t) schur = schur' -- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'. mbCholSH :: Field t => Matrix t -> Maybe (Matrix t) mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH' -- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. cholSH :: Field t => Matrix t -> Matrix t cholSH = {-# SCC "cholSH" #-} cholSH' -- | Cholesky factorization of a positive definite hermitian or symmetric matrix. -- -- If @c = chol m@ then @c@ is upper triangular and @m == ctrans c \<> c@. chol :: Field t => Matrix t -> Matrix t chol m | exactHermitian m = cholSH m | otherwise = error "chol requires positive definite complex hermitian or real symmetric matrix" -- | Joint computation of inverse and logarithm of determinant of a square matrix. invlndet :: (Floating t, Field t) => Matrix t -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det)) invlndet m | square m = (im,(ladm,sdm)) | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix" where lp@(lup,perm) = luPacked m s = signlp (rows m) perm dg = toList $ takeDiag $ lup ladm = sum $ map (log.abs) dg sdm = s* product (map signum dg) im = luSolve lp (ident (rows m)) -- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'. det :: Field t => Matrix t -> t det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup) | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix" where (lup,perm) = luPacked m s = signlp (rows m) perm -- | Explicit LU factorization of a general matrix. -- -- If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular, -- u is upper triangular, p is a permutation matrix and s is the signature of the permutation. lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t) lu = luFact . luPacked -- | Inverse of a square matrix. See also 'invlndet'. inv :: Field t => Matrix t -> Matrix t inv m | square m = m `linearSolve` ident (rows m) | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix" -- | Pseudoinverse of a general matrix. pinv :: Field t => Matrix t -> Matrix t pinv m = linearSolveSVD m (ident (rows m)) -- | Numeric rank of a matrix from the SVD decomposition. rankSVD :: Element t => Double -- ^ numeric zero (e.g. 1*'eps') -> Matrix t -- ^ input matrix m -> Vector Double -- ^ 'sv' of m -> Int -- ^ rank of m rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s) -- | Numeric rank of a matrix from its singular values. ranksv :: Double -- ^ numeric zero (e.g. 1*'eps') -> Int -- ^ maximum dimension of the matrix -> [Double] -- ^ singular values -> Int -- ^ rank of m ranksv teps maxdim s = k where g = maximum s tol = fromIntegral maxdim * g * teps s' = filter (>tol) s k = if g > teps then length s' else 0 -- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave). eps :: Double eps = 2.22044604925031e-16 -- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1 peps :: RealFloat x => x peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x) -- | The imaginary unit: @i = 0.0 :+ 1.0@ i :: Complex Double i = 0:+1 ----------------------------------------------------------------------- -- | The nullspace of a matrix from its 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 -> [Vector t] -- ^ list of unitary vectors spanning the 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 = drop k $ toRows $ ctrans 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 = 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 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) ------------------------------------------------------------------------ {- Pseudoinverse of a real matrix with the desired tolerance, expressed as a multiplicative factor of the default tolerance used by GNU-Octave (see 'pinv'). @\> let m = 'fromLists' [[1,0, 0] ,[0,1, 0] ,[0,0,1e-10]] \ -- \> 'pinv' m 1. 0. 0. 0. 1. 0. 0. 0. 10000000000. \ -- \> pinvTol 1E8 m 1. 0. 0. 0. 1. 0. 0. 0. 1.@ -} --pinvTol :: Double -> Matrix Double -> Matrix Double pinvTol t m = v' `mXm` diag s' `mXm` trans u' where (u,s,v) = thinSVDRd m sl@(g:_) = toList s s' = fromList . map rec $ sl rec x = if x < g*tol then 1 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 --------------------------------------------------------------------- -- 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 = join [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. rank :: Field t => Matrix t -> Int rank m = rankSVD eps m (singularValues m) {- expm' m = case diagonalize (complex m) of Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices" where exp = vectorMapC Exp -} diagonalize m = if rank v == n then Just (l,v) else Nothing where n = rows m (l,v) = if exactHermitian m then let (l',v') = eigSH m in (real l', v') else eig m -- | Generic matrix functions for diagonalizable matrices. For instance: -- -- @logm = matFunc log@ -- matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) matFunc f m = case diagonalize m of Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v Nothing -> error "Sorry, matFunc requires a diagonalizable matrix" -------------------------------------------------------------- golubeps :: Integer -> Integer -> Double golubeps p q = a * fromIntegral b / fromIntegral c where a = 2^^(3-p-q) b = fact p * fact q c = fact (p+q) * fact (p+q+1) fact n = product [1..n] epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]] geps delta = head [ k | (k,g) <- epslist, g Matrix t -> Matrix t expm = expGolub expGolub :: ( Fractional t, Element t, Field t , Normed Matrix t , RealFrac (RealOf t) , Floating (RealOf t) ) => Matrix t -> Matrix t expGolub m = iterate msq f !! j where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m a = m */ fromIntegral ((2::Int)^j) q = geps eps -- 7 steps eye = ident (rows m) work (k,c,x,n,d) = (k',c',x',n',d') where k' = k+1 c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k) x' = a <> x n' = n |+| (c' .* x') d' = d |+| (((-1)^k * c') .* x') (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q f = linearSolve df nf msq x = x <> x (<>) = multiply v */ x = scale (recip x) v (.*) = scale (|+|) = add -------------------------------------------------------------- {- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia. It only works with invertible matrices that have a real solution. For diagonalizable matrices you can try @matFunc sqrt@. @m = (2><2) [4,9 ,0,4] :: Matrix Double@ @\>sqrtm m (2><2) [ 2.0, 2.25 , 0.0, 2.0 ]@ -} sqrtm :: Field t => Matrix t -> Matrix t sqrtm = sqrtmInv sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x)) where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a | otherwise = fixedPoint (b:rest) fixedPoint _ = error "fixedpoint with impossible inputs" f (y,z) = (0.5 .* (y |+| inv z), 0.5 .* (inv y |+| z)) (.*) = scale (|+|) = add (|-|) = sub ------------------------------------------------------------------ signlp r vals = foldl f 1 (zip [0..r-1] vals) where f s (a,b) | a /= b = -s | otherwise = s swap (arr,s) (a,b) | a /= b = (arr // [(a, arr!b),(b,arr!a)],-s) | otherwise = (arr,s) fixPerm r vals = (fromColumns $ elems res, sign) where v = [0..r-1] s = toColumns (ident r) (res,sign) = foldl swap (listArray (0,r-1) s, 1) (zip v vals) triang r c h v = (r>=h then v else 1 - v luFact (l_u,perm) | r <= c = (l ,u ,p, s) | otherwise = (l',u',p, s) where r = rows l_u c = cols l_u tu = triang r c 0 1 tl = triang r c 0 0 l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst 1 r) r r u = l_u |*| tu (p,s) = fixPerm r perm l' = (l_u |*| tl) |+| diagRect 0 (konst 1 c) r c u' = takeRows c (l_u |*| tu) (|+|) = add (|*|) = mul --------------------------------------------------------------------------- data NormType = Infinity | PNorm1 | PNorm2 | Frobenius class (RealFloat (RealOf t)) => Normed c t where pnorm :: NormType -> c t -> RealOf t instance Normed Vector Double where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = norm2 instance Normed Vector (Complex Double) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector Float where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector (Complex Float) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Matrix Double where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Double) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix Float where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Float) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten -- | Approximate number of common digits in the maximum element. relativeError :: (Normed c t, Container c t) => c t -> c t -> Int relativeError x y = dig (norm (x `sub` y) / norm x) where norm = pnorm Infinity dig r = round $ -logBase 10 (realToFrac r :: Double) ---------------------------------------------------------------------- -- | Generalized symmetric positive definite eigensystem Av = lBv, -- for A and B symmetric, B positive definite (conditions not checked). geigSH' :: Field t => Matrix t -- ^ A -> Matrix t -- ^ B -> (Vector Double, Matrix t) geigSH' a b = (l,v') where u = cholSH b iu = inv u c = ctrans iu <> a <> iu (l,v) = eigSH' c v' = iu <> v (<>) = mXm hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/LAPACK.hs0000644000000000000000000005504112165764700017741 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.LinearAlgebra.LAPACK -- Copyright : (c) Alberto Ruiz 2006-7 -- License : GPL-style -- -- Maintainer : Alberto Ruiz (aruiz at um dot es) -- Stability : provisional -- Portability : portable (uses FFI) -- -- Functional interface to selected LAPACK functions (). -- ----------------------------------------------------------------------------- module Numeric.LinearAlgebra.LAPACK ( -- * Matrix product multiplyR, multiplyC, multiplyF, multiplyQ, -- * Linear systems linearSolveR, linearSolveC, lusR, lusC, cholSolveR, cholSolveC, linearSolveLSR, linearSolveLSC, linearSolveSVDR, linearSolveSVDC, -- * SVD svR, svRd, svC, svCd, svdR, svdRd, svdC, svdCd, thinSVDR, thinSVDRd, thinSVDC, thinSVDCd, rightSVR, rightSVC, leftSVR, leftSVC, -- * Eigensystems eigR, eigC, eigS, eigS', eigH, eigH', eigOnlyR, eigOnlyC, eigOnlyS, eigOnlyH, -- * LU luR, luC, -- * Cholesky cholS, cholH, mbCholS, mbCholH, -- * QR qrR, qrC, -- * Hessenberg hessR, hessC, -- * Schur schurR, schurC ) where import Data.Packed.Internal import Data.Packed.Matrix import Numeric.Conversion import Numeric.GSL.Vector(vectorMapValR, FunCodeSV(Scale)) import Foreign.Ptr(nullPtr) import Foreign.C.Types import Control.Monad(when) import System.IO.Unsafe(unsafePerformIO) ----------------------------------------------------------------------------------- foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TCMCMCM foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TFMFMFM foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TQMQMQM isT Matrix{order = ColumnMajor} = 0 isT Matrix{order = RowMajor} = 1 tt x@Matrix{order = ColumnMajor} = x tt x@Matrix{order = RowMajor} = trans x multiplyAux f st a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ show (rows a,cols a) ++ " x " ++ show (rows b, cols b) s <- createMatrix ColumnMajor (rows a) (cols b) app3 (f (isT a) (isT b)) mat (tt a) mat (tt b) mat s st return s -- | Matrix product based on BLAS's /dgemm/. multiplyR :: Matrix Double -> Matrix Double -> Matrix Double multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b -- | Matrix product based on BLAS's /zgemm/. multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) multiplyC a b = multiplyAux zgemmc "zgemmc" a b -- | Matrix product based on BLAS's /sgemm/. multiplyF :: Matrix Float -> Matrix Float -> Matrix Float multiplyF a b = multiplyAux sgemmc "sgemmc" a b -- | Matrix product based on BLAS's /cgemm/. multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float) multiplyQ a b = multiplyAux cgemmc "cgemmc" a b ----------------------------------------------------------------------------- foreign import ccall unsafe "svd_l_R" dgesvd :: TMMVM foreign import ccall unsafe "svd_l_C" zgesvd :: TCMCMVCM foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TMMVM foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TCMCMVCM -- | Full SVD of a real matrix using LAPACK's /dgesvd/. svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdR = svdAux dgesvd "svdR" . fmat -- | Full SVD of a real matrix using LAPACK's /dgesdd/. svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdRd = svdAux dgesdd "svdRdd" . fmat -- | Full SVD of a complex matrix using LAPACK's /zgesvd/. svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdC = svdAux zgesvd "svdC" . fmat -- | Full SVD of a complex matrix using LAPACK's /zgesdd/. svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdCd = svdAux zgesdd "svdCdd" . fmat svdAux f st x = unsafePerformIO $ do u <- createMatrix ColumnMajor r r s <- createVector (min r c) v <- createMatrix ColumnMajor c c app4 f mat x mat u vec s mat v st return (u,s,trans v) where r = rows x c = cols x -- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'. thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDR = thinSVDAux dgesvd "thinSVDR" . fmat -- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'. thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDC = thinSVDAux zgesvd "thinSVDC" . fmat -- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'. thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDRd = thinSVDAux dgesdd "thinSVDRdd" . fmat -- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'. thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDCd = thinSVDAux zgesdd "thinSVDCdd" . fmat thinSVDAux f st x = unsafePerformIO $ do u <- createMatrix ColumnMajor r q s <- createVector q v <- createMatrix ColumnMajor q c app4 f mat x mat u vec s mat v st return (u,s,trans v) where r = rows x c = cols x q = min r c -- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'. svR :: Matrix Double -> Vector Double svR = svAux dgesvd "svR" . fmat -- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'. svC :: Matrix (Complex Double) -> Vector Double svC = svAux zgesvd "svC" . fmat -- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'. svRd :: Matrix Double -> Vector Double svRd = svAux dgesdd "svRd" . fmat -- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'. svCd :: Matrix (Complex Double) -> Vector Double svCd = svAux zgesdd "svCd" . fmat svAux f st x = unsafePerformIO $ do s <- createVector q app2 g mat x vec s st return s where r = rows x c = cols x q = min r c g ra ca pa nb pb = f ra ca pa 0 0 nullPtr nb pb 0 0 nullPtr -- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVR :: Matrix Double -> (Vector Double, Matrix Double) rightSVR = rightSVAux dgesvd "rightSVR" . fmat -- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) rightSVC = rightSVAux zgesvd "rightSVC" . fmat rightSVAux f st x = unsafePerformIO $ do s <- createVector q v <- createMatrix ColumnMajor c c app3 g mat x vec s mat v st return (s,trans v) where r = rows x c = cols x q = min r c g ra ca pa = f ra ca pa 0 0 nullPtr -- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVR :: Matrix Double -> (Matrix Double, Vector Double) leftSVR = leftSVAux dgesvd "leftSVR" . fmat -- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double) leftSVC = leftSVAux zgesvd "leftSVC" . fmat leftSVAux f st x = unsafePerformIO $ do u <- createMatrix ColumnMajor r r s <- createVector q app3 g mat x mat u vec s st return (u,s) where r = rows x c = cols x q = min r c g ra ca pa ru cu pu nb pb = f ra ca pa ru cu pu nb pb 0 0 nullPtr ----------------------------------------------------------------------------- foreign import ccall unsafe "eig_l_R" dgeev :: TMMCVM foreign import ccall unsafe "eig_l_C" zgeev :: TCMCMCVCM foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> TMVM foreign import ccall unsafe "eig_l_H" zheev :: CInt -> TCMVCM eigAux f st m = unsafePerformIO $ do l <- createVector r v <- createMatrix ColumnMajor r r app3 g mat m vec l mat v st return (l,v) where r = rows m g ra ca pa = f ra ca pa 0 0 nullPtr -- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) eigC = eigAux zgeev "eigC" . fmat eigOnlyAux f st m = unsafePerformIO $ do l <- createVector r app2 g mat m vec l st return l where r = rows m g ra ca pa nl pl = f ra ca pa 0 0 nullPtr nl pl 0 0 nullPtr -- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double) eigOnlyC = eigOnlyAux zgeev "eigOnlyC" . fmat -- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) eigR m = (s', v'') where (s,v) = eigRaux (fmat m) s' = fixeig1 s v' = toRows $ trans v v'' = fromColumns $ fixeig (toList s') v' eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) eigRaux m = unsafePerformIO $ do l <- createVector r v <- createMatrix ColumnMajor r r app3 g mat m vec l mat v "eigR" return (l,v) where r = rows m g ra ca pa = dgeev ra ca pa 0 0 nullPtr fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s)) where r = dim s fixeig [] _ = [] fixeig [_] [v] = [comp' v] fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs) | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1,scale (-1) v2) : fixeig r vs | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs) where scale = vectorMapValR Scale fixeig _ _ = error "fixeig with impossible inputs" -- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyR :: Matrix Double -> Vector (Complex Double) eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR" . fmat ----------------------------------------------------------------------------- eigSHAux f st m = unsafePerformIO $ do l <- createVector r v <- createMatrix ColumnMajor r r app3 f mat m vec l mat v st return (l,v) where r = rows m -- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order). eigS :: Matrix Double -> (Vector Double, Matrix Double) eigS m = (s', fliprl v) where (s,v) = eigS' (fmat m) s' = fromList . reverse . toList $ s -- | 'eigS' in ascending order eigS' :: Matrix Double -> (Vector Double, Matrix Double) eigS' = eigSHAux (dsyev 1) "eigS'" . fmat -- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order). eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH m = (s', fliprl v) where (s,v) = eigH' (fmat m) s' = fromList . reverse . toList $ s -- | 'eigH' in ascending order eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH' = eigSHAux (zheev 1) "eigH'" . fmat -- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyS :: Matrix Double -> Vector Double eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'" . fmat -- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyH :: Matrix (Complex Double) -> Vector Double eigOnlyH = vrev . fst. eigSHAux (zheev 1) "eigH'" . fmat vrev = flatten . flipud . reshape 1 ----------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveR_l" dgesv :: TMMM foreign import ccall unsafe "linearSolveC_l" zgesv :: TCMCMCM foreign import ccall unsafe "cholSolveR_l" dpotrs :: TMMM foreign import ccall unsafe "cholSolveC_l" zpotrs :: TCMCMCM linearSolveSQAux f st a b | n1==n2 && n1==r = unsafePerformIO $ do s <- createMatrix ColumnMajor r c app3 f mat a mat b mat s st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b c = cols b -- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'. linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveR a b = linearSolveSQAux dgesv "linearSolveR" (fmat a) (fmat b) -- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'. linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveC a b = linearSolveSQAux zgesv "linearSolveC" (fmat a) (fmat b) -- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'. cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double cholSolveR a b = linearSolveSQAux dpotrs "cholSolveR" (fmat a) (fmat b) -- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'. cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) cholSolveC a b = linearSolveSQAux zpotrs "cholSolveC" (fmat a) (fmat b) ----------------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveLSR_l" dgels :: TMMM foreign import ccall unsafe "linearSolveLSC_l" zgels :: TCMCMCM foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> TMMM foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> TCMCMCM linearSolveAux f st a b = unsafePerformIO $ do r <- createMatrix ColumnMajor (max m n) nrhs app3 f mat a mat b mat r st return r where m = rows a n = cols a nrhs = cols b -- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'. linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux dgels "linearSolverLSR" (fmat a) (fmat b) -- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'. linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux zgels "linearSolveLSC" (fmat a) (fmat b) -- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDR :: Maybe Double -- ^ rcond -> Matrix Double -- ^ coefficient matrix -> Matrix Double -- ^ right hand sides (as columns) -> Matrix Double -- ^ solution vectors (as columns) linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (dgelss rcond) "linearSolveSVDR" (fmat a) (fmat b) linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) (fmat a) (fmat b) -- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDC :: Maybe Double -- ^ rcond -> Matrix (Complex Double) -- ^ coefficient matrix -> Matrix (Complex Double) -- ^ right hand sides (as columns) -> Matrix (Complex Double) -- ^ solution vectors (as columns) linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (zgelss rcond) "linearSolveSVDC" (fmat a) (fmat b) linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) (fmat a) (fmat b) ----------------------------------------------------------------------------------- foreign import ccall unsafe "chol_l_H" zpotrf :: TCMCM foreign import ccall unsafe "chol_l_S" dpotrf :: TMM cholAux f st a = do r <- createMatrix ColumnMajor n n app2 f mat a mat r st return r where n = rows a -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/. cholH :: Matrix (Complex Double) -> Matrix (Complex Double) cholH = unsafePerformIO . cholAux zpotrf "cholH" . fmat -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/. cholS :: Matrix Double -> Matrix Double cholS = unsafePerformIO . cholAux dpotrf "cholS" . fmat -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version). mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double)) mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH" . fmat -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version). mbCholS :: Matrix Double -> Maybe (Matrix Double) mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS" . fmat ----------------------------------------------------------------------------------- foreign import ccall unsafe "qr_l_R" dgeqr2 :: TMVM foreign import ccall unsafe "qr_l_C" zgeqr2 :: TCMCVCM -- | QR factorization of a real matrix, using LAPACK's /dgeqr2/. qrR :: Matrix Double -> (Matrix Double, Vector Double) qrR = qrAux dgeqr2 "qrR" . fmat -- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/. qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) qrC = qrAux zgeqr2 "qrC" . fmat qrAux f st a = unsafePerformIO $ do r <- createMatrix ColumnMajor m n tau <- createVector mn app3 f mat a vec tau mat r st return (r,tau) where m = rows a n = cols a mn = min m n ----------------------------------------------------------------------------------- foreign import ccall unsafe "hess_l_R" dgehrd :: TMVM foreign import ccall unsafe "hess_l_C" zgehrd :: TCMCVCM -- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/. hessR :: Matrix Double -> (Matrix Double, Vector Double) hessR = hessAux dgehrd "hessR" . fmat -- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/. hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) hessC = hessAux zgehrd "hessC" . fmat hessAux f st a = unsafePerformIO $ do r <- createMatrix ColumnMajor m n tau <- createVector (mn-1) app3 f mat a vec tau mat r st return (r,tau) where m = rows a n = cols a mn = min m n ----------------------------------------------------------------------------------- foreign import ccall unsafe "schur_l_R" dgees :: TMMM foreign import ccall unsafe "schur_l_C" zgees :: TCMCMCM -- | Schur factorization of a square real matrix, using LAPACK's /dgees/. schurR :: Matrix Double -> (Matrix Double, Matrix Double) schurR = schurAux dgees "schurR" . fmat -- | Schur factorization of a square complex matrix, using LAPACK's /zgees/. schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) schurC = schurAux zgees "schurC" . fmat schurAux f st a = unsafePerformIO $ do u <- createMatrix ColumnMajor n n s <- createMatrix ColumnMajor n n app3 f mat a mat u mat s st return (u,s) where n = rows a ----------------------------------------------------------------------------------- foreign import ccall unsafe "lu_l_R" dgetrf :: TMVM foreign import ccall unsafe "lu_l_C" zgetrf :: TCMVCM -- | LU factorization of a general real matrix, using LAPACK's /dgetrf/. luR :: Matrix Double -> (Matrix Double, [Int]) luR = luAux dgetrf "luR" . fmat -- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/. luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int]) luC = luAux zgetrf "luC" . fmat luAux f st a = unsafePerformIO $ do lu <- createMatrix ColumnMajor n m piv <- createVector (min n m) app3 f mat a vec piv mat lu st return (lu, map (pred.round) (toList piv)) where n = rows a m = cols a ----------------------------------------------------------------------------------- type TW a = CInt -> PD -> a type TQ a = CInt -> CInt -> PC -> a foreign import ccall unsafe "luS_l_R" dgetrs :: TMVMM foreign import ccall unsafe "luS_l_C" zgetrs :: TQ (TW (TQ (TQ (IO CInt)))) -- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/. lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv (fmat b) -- | Solve a real linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/. lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double) lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv (fmat b) lusAux f st a piv b | n1==n2 && n2==n =unsafePerformIO $ do x <- createMatrix ColumnMajor n m app4 f mat a vec piv' mat b mat x st return x | otherwise = error $ st ++ " on LU factorization of nonsquare matrix" where n1 = rows a n2 = cols a n = rows b m = cols b piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/Util.hs0000644000000000000000000001465512165764700017731 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Util Copyright : (c) Alberto Ruiz 2013 License : GPL Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional -} ----------------------------------------------------------------------------- module Numeric.LinearAlgebra.Util( -- * Convenience functions size, disp, zeros, ones, diagl, row, col, (&),(!), (¦), (#), (?),(¿), rand, randn, cross, norm, unitary, mt, pairwiseD2, rowOuters, null1, null1sym, -- * Convolution -- ** 1D corr, conv, corrMin, -- ** 2D corr2, conv2, separable, -- * Tools for the Kronecker product -- -- | (see A. Fusiello, A matter of notation: Several uses of the Kronecker product in -- 3d computer vision, Pattern Recognition Letters 28 (15) (2007) 2127-2132) -- -- | @`vec` (a \<> x \<> b) == ('trans' b ` 'kronecker' ` a) \<> 'vec' x@ vec, vech, dup, vtrans ) where import Numeric.Container import Numeric.LinearAlgebra.Algorithms hiding (i) import Numeric.Matrix() import Numeric.Vector() import System.Random(randomIO) import Numeric.LinearAlgebra.Util.Convolution disp :: Int -> Matrix Double -> IO () -- ^ show a matrix with given number of digits after the decimal point disp n = putStrLn . dispf n -- | 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 randn :: Int -> Int -> IO (Matrix Double) randn = randm Gaussian -- | create a real diagonal matrix from a list 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 = join [a,b] -- | horizontal concatenation of real matrices infixl 3 ! (!) :: Matrix Double -> Matrix Double -> Matrix Double a ! b = fromBlocks [[a,b]] -- | (00A6) horizontal concatenation of real matrices infixl 3 ¦ (¦) :: Matrix Double -> Matrix Double -> Matrix Double a ¦ b = fromBlocks [[a,b]] -- | vertical concatenation of real matrices (#) :: Matrix Double -> Matrix Double -> Matrix Double infixl 2 # a # b = fromBlocks [[a],[b]] -- | create a single row real matrix from a list row :: [Double] -> Matrix Double row = asRow . fromList -- | create a single column real matrix from a list col :: [Double] -> Matrix Double col = asColumn . fromList -- | extract selected rows infixl 9 ? (?) :: Element t => Matrix t -> [Int] -> Matrix t (?) = flip extractRows -- | (00BF) extract selected columns infixl 9 ¿ (¿) :: Element t => Matrix t -> [Int] -> Matrix t m ¿ ks = trans . extractRows ks . trans $ m cross :: Vector Double -> Vector Double -> Vector Double -- ^ cross product (for three-element real vectors) cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3] | otherwise = error $ "cross ("++show x++") ("++show y++")" where [x1,x2,x3] = toList x [y1,y2,y3] = toList y z1 = x2*y3-x3*y2 z2 = x3*y1-x1*y3 z3 = x1*y2-x2*y1 norm :: Vector Double -> Double -- ^ 2-norm of real vector norm = pnorm PNorm2 -- | Obtains a vector in the same direction with 2-norm=1 unitary :: Vector Double -> Vector Double unitary v = v / scalar (norm v) -- | (rows &&& cols) size :: Matrix t -> (Int, Int) size m = (rows m, cols m) -- | trans . inv mt :: Matrix Double -> Matrix Double mt = trans . inv ---------------------------------------------------------------------- -- | 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 = constant 1 k x2 = x * x <> oc y2 = y * y <> oc ok = cols x == cols y -------------------------------------------------------------------------------- -- | outer products of rows rowOuters :: Matrix Double -> Matrix Double -> Matrix Double rowOuters a b = a' * b' where a' = kronecker a (ones 1 (cols b)) b' = kronecker (ones 1 (cols a)) b -------------------------------------------------------------------------------- -- | solution of overconstrained homogeneous linear system null1 :: Matrix Double -> Vector Double null1 = last . toColumns . snd . rightSV -- | solution of overconstrained homogeneous symmetric linear system null1sym :: Matrix Double -> Vector Double null1sym = last . toColumns . snd . eigSH' -------------------------------------------------------------------------------- vec :: Element t => Matrix t -> Vector t -- ^ stacking of columns vec = flatten . trans vech :: Element t => Matrix t -> Vector t -- ^ half-vectorization (of the lower triangular part) vech m = join . zipWith f [0..] . toColumns $ m where f k v = subVector k (dim v - k) v dup :: (Num t, Num (Vector t), Element t) => Int -> Matrix t -- ^ duplication matrix (@'dup' k \<> 'vech' m == 'vec' m@, for symmetric m of 'dim' k) dup k = trans $ fromRows $ map f es where rs = zip [0..] (toRows (ident (k^(2::Int)))) es = [(i,j) | j <- [0..k-1], i <- [0..k-1], i>=j ] f (i,j) | i == j = g (k*j + i) | otherwise = g (k*j + i) + g (k*i + j) g j = v where Just v = lookup j rs vtrans :: Element t => Int -> Matrix t -> Matrix t -- ^ generalized \"vector\" transposition: @'vtrans' 1 == 'trans'@, and @'vtrans' ('rows' m) m == 'asColumn' ('vec' m)@ vtrans p m | r == 0 = fromBlocks . map (map asColumn . takesV (replicate q p)) . toColumns $ m | otherwise = error $ "vtrans " ++ show p ++ " of matrix with " ++ show (rows m) ++ " rows" where (q,r) = divMod (rows m) p hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/LAPACK/0000755000000000000000000000000012165764700017400 5ustar0000000000000000hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.h0000644000000000000000000000401112165764700021573 0ustar0000000000000000/* * We have copied the definitions in f2c.h required * to compile clapack.h, modified to support both * 32 and 64 bit http://opengrok.creo.hu/dragonfly/xref/src/contrib/gcc-3.4/libf2c/readme.netlib http://www.ibm.com/developerworks/library/l-port64.html */ #ifdef _LP64 typedef int integer; typedef unsigned int uinteger; typedef int logical; typedef long longint; /* system-dependent */ typedef unsigned long ulongint; /* system-dependent */ #else typedef long int integer; typedef unsigned long int uinteger; typedef long int logical; typedef long long longint; /* system-dependent */ typedef unsigned long long ulongint; /* system-dependent */ #endif typedef char *address; typedef short int shortint; typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; typedef short int shortlogical; typedef char logical1; typedef char integer1; typedef logical (*L_fp)(); typedef short ftnlen; /********************************************************/ #define FVEC(A) int A##n, float*A##p #define DVEC(A) int A##n, double*A##p #define QVEC(A) int A##n, complex*A##p #define CVEC(A) int A##n, doublecomplex*A##p #define PVEC(A) int A##n, void* A##p, int A##s #define FMAT(A) int A##r, int A##c, float* A##p #define DMAT(A) int A##r, int A##c, double* A##p #define QMAT(A) int A##r, int A##c, complex* A##p #define CMAT(A) int A##r, int A##c, doublecomplex* A##p #define PMAT(A) int A##r, int A##c, void* A##p, int A##s #define KFVEC(A) int A##n, const float*A##p #define KDVEC(A) int A##n, const double*A##p #define KQVEC(A) int A##n, const complex*A##p #define KCVEC(A) int A##n, const doublecomplex*A##p #define KPVEC(A) int A##n, const void* A##p, int A##s #define KFMAT(A) int A##r, int A##c, const float* A##p #define KDMAT(A) int A##r, int A##c, const double* A##p #define KQMAT(A) int A##r, int A##c, const complex* A##p #define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p #define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/LAPACK/lapack-aux.c0000644000000000000000000011457412165764700021606 0ustar0000000000000000#include #include #include #include #include #include "lapack-aux.h" #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) // #define DBGL #ifdef DBGL #define DEBUGMSG(M) printf("\nLAPACK "M"\n"); #else #define DEBUGMSG(M) #endif #define OK return 0; // #ifdef DBGL // #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL); // #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;); // #else // #define DEBUGMSG(M) // #define OK return 0; // #endif #define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \ for(q=0;q=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveR_l"); double*AC = (double*)malloc(n*n*sizeof(double)); memcpy(AC,ap,n*n*sizeof(double)); memcpy(xp,bp,n*nhrs*sizeof(double)); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; dgesv_ (&n,&nhrs, AC, &n, ipiv, xp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); free(AC); OK } //////////////////// general complex linear system //////////// /* Subroutine */ int zgesv_(integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer * info); int linearSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) { integer n = ar; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveC_l"); doublecomplex*AC = (doublecomplex*)malloc(n*n*sizeof(doublecomplex)); memcpy(AC,ap,n*n*sizeof(doublecomplex)); memcpy(xp,bp,n*nhrs*sizeof(doublecomplex)); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; zgesv_ (&n,&nhrs, AC, &n, ipiv, xp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); free(AC); OK } //////// symmetric positive definite real linear system using Cholesky //////////// /* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * info); int cholSolveR_l(KDMAT(a),KDMAT(b),DMAT(x)) { integer n = ar; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveR_l"); memcpy(xp,bp,n*nhrs*sizeof(double)); integer res; dpotrs_ ("U", &n,&nhrs, (double*)ap, &n, xp, &n, &res); CHECK(res,res); OK } //////// Hermitian positive definite real linear system using Cholesky //////////// /* Subroutine */ int zpotrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info); int cholSolveC_l(KCMAT(a),KCMAT(b),CMAT(x)) { integer n = ar; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveC_l"); memcpy(xp,bp,n*nhrs*sizeof(doublecomplex)); integer res; zpotrs_ ("U", &n,&nhrs, (doublecomplex*)ap, &n, xp, &n, &res); CHECK(res,res); OK } //////////////////// least squares real linear system //////////// /* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer * nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info); int linearSolveLSR_l(KDMAT(a),KDMAT(b),DMAT(x)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = xr; REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE); DEBUGMSG("linearSolveLSR_l"); double*AC = (double*)malloc(m*n*sizeof(double)); memcpy(AC,ap,m*n*sizeof(double)); if (m>=n) { memcpy(xp,bp,m*nrhs*sizeof(double)); } else { int k; for(k = 0; k0) { return SINGULAR; } CHECK(res,res); free(work); free(AC); OK } //////////////////// least squares complex linear system //////////// /* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info); int linearSolveLSC_l(KCMAT(a),KCMAT(b),CMAT(x)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = xr; REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE); DEBUGMSG("linearSolveLSC_l"); doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex)); memcpy(AC,ap,m*n*sizeof(doublecomplex)); if (m>=n) { memcpy(xp,bp,m*nrhs*sizeof(doublecomplex)); } else { int k; for(k = 0; k0) { return SINGULAR; } CHECK(res,res); free(work); free(AC); OK } //////////////////// least squares real linear system using SVD //////////// /* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info); int linearSolveSVDR_l(double rcond,KDMAT(a),KDMAT(b),DMAT(x)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = xr; REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE); DEBUGMSG("linearSolveSVDR_l"); double*AC = (double*)malloc(m*n*sizeof(double)); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); memcpy(AC,ap,m*n*sizeof(double)); if (m>=n) { memcpy(xp,bp,m*nrhs*sizeof(double)); } else { int k; for(k = 0; k0) { return NOCONVER; } CHECK(res,res); free(work); free(S); free(AC); OK } //////////////////// least squares complex linear system using SVD //////////// // not in clapack.h int zgelss_(integer *m, integer *n, integer *nhrs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer* rank, doublecomplex *work, integer* lwork, doublereal* rwork, integer *info); int linearSolveSVDC_l(double rcond, KCMAT(a),KCMAT(b),CMAT(x)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = xr; REQUIRES(m>=1 && n>=1 && ar==br && xr==MAX(m,n) && xc == bc, BAD_SIZE); DEBUGMSG("linearSolveSVDC_l"); doublecomplex*AC = (doublecomplex*)malloc(m*n*sizeof(doublecomplex)); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double)); memcpy(AC,ap,m*n*sizeof(doublecomplex)); if (m>=n) { memcpy(xp,bp,m*nrhs*sizeof(doublecomplex)); } else { int k; for(k = 0; k0) { return NOCONVER; } CHECK(res,res); free(work); free(RWORK); free(S); free(AC); OK } //////////////////// Cholesky factorization ///////////////////////// /* Subroutine */ int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info); int chol_l_H(KCMAT(a),CMAT(l)) { integer n = ar; REQUIRES(n>=1 && ac == n && lr==n && lc==n,BAD_SIZE); DEBUGMSG("chol_l_H"); memcpy(lp,ap,n*n*sizeof(doublecomplex)); char uplo = 'U'; integer res; zpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); doublecomplex zero = {0.,0.}; int r,c; for (r=0; r=1 && ac == n && lr==n && lc==n,BAD_SIZE); DEBUGMSG("chol_l_S"); memcpy(lp,ap,n*n*sizeof(double)); char uplo = 'U'; integer res; dpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); int r,c; for (r=0; r=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_R"); double *WORK = (double*)malloc(n*sizeof(double)); CHECK(!WORK,MEM); memcpy(rp,ap,m*n*sizeof(double)); integer res; dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } /* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info); int qr_l_C(KCMAT(a), CVEC(tau), CMAT(r)) { integer m = ar; integer n = ac; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && rr== m && rc == n && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_C"); doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex)); CHECK(!WORK,MEM); memcpy(rp,ap,m*n*sizeof(doublecomplex)); integer res; zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } //////////////////// Hessenberg factorization ///////////////////////// /* Subroutine */ int dgehrd_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); int hess_l_R(KDMAT(a), DVEC(tau), DMAT(r)) { integer m = ar; integer n = ac; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_R"); integer lwork = 5*n; // fixme double *WORK = (double*)malloc(lwork*sizeof(double)); CHECK(!WORK,MEM); memcpy(rp,ap,m*n*sizeof(double)); integer res; integer one = 1; dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } /* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info); int hess_l_C(KCMAT(a), CVEC(tau), CMAT(r)) { integer m = ar; integer n = ac; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && rr== m && rc == n && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_C"); integer lwork = 5*n; // fixme doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); CHECK(!WORK,MEM); memcpy(rp,ap,m*n*sizeof(doublecomplex)); integer res; integer one = 1; zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } //////////////////// Schur factorization ///////////////////////// /* Subroutine */ int dgees_(char *jobvs, char *sort, L_fp select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info); int schur_l_R(KDMAT(a), DMAT(u), DMAT(s)) { integer m = ar; integer n = ac; REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE); DEBUGMSG("schur_l_R"); int k; //printf("---------------------------\n"); //printf("%p: ",ap); for(k=0;k0) { return NOCONVER; } CHECK(res,res); free(WR); free(WI); free(BWORK); free(WORK); OK } /* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info); int schur_l_C(KCMAT(a), CMAT(u), CMAT(s)) { integer m = ar; integer n = ac; REQUIRES(m>=1 && n==m && ur==n && uc==n && sr==n && sc==n, BAD_SIZE); DEBUGMSG("schur_l_C"); memcpy(sp,ap,n*n*sizeof(doublecomplex)); integer lwork = 6*n; // fixme doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex)); // W not really required in this call logical *BWORK = (logical*)malloc(n*sizeof(logical)); double *RWORK = (double*)malloc(n*sizeof(double)); integer res; integer sdim; zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W, up,&n, WORK,&lwork,RWORK,BWORK,&res); if(res>0) { return NOCONVER; } CHECK(res,res); free(W); free(BWORK); free(WORK); OK } //////////////////// LU factorization ///////////////////////// /* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer * lda, integer *ipiv, integer *info); int lu_l_R(KDMAT(a), DVEC(ipiv), DMAT(r)) { integer m = ar; integer n = ac; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_R"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); memcpy(rp,ap,m*n*sizeof(double)); integer res; dgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // fixme } CHECK(res,res); int k; for (k=0; k=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_C"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); memcpy(rp,ap,m*n*sizeof(doublecomplex)); integer res; zgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // fixme } CHECK(res,res); int k; for (k=0; k0; } OK } int stepD(DVEC(x),DVEC(y)) { DEBUGMSG("stepD") int k; for(k=0;k0; } OK } //////////////////// cond ///////////////////////// int condF(FVEC(x),FVEC(y),FVEC(lt),FVEC(eq),FVEC(gt),FVEC(r)) { REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE); DEBUGMSG("condF") int k; for(k=0;kyp[k]?gtp[k]:eqp[k]); } OK } int condD(DVEC(x),DVEC(y),DVEC(lt),DVEC(eq),DVEC(gt),DVEC(r)) { REQUIRES(xn==yn && xn==ltn && xn==eqn && xn==gtn && xn==rn ,BAD_SIZE); DEBUGMSG("condD") int k; for(k=0;kyp[k]?gtp[k]:eqp[k]); } OK } hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/Util/0000755000000000000000000000000012165764700017362 5ustar0000000000000000hmatrix-0.15.0.0/lib/Numeric/LinearAlgebra/Util/Convolution.hs0000644000000000000000000000637612165764700022251 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Util.Convolution Copyright : (c) Alberto Ruiz 2012 License : GPL Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional -} ----------------------------------------------------------------------------- module Numeric.LinearAlgebra.Util.Convolution( corr, conv, corrMin, corr2, conv2, separable ) where import Numeric.LinearAlgebra vectSS :: Element t => Int -> Vector t -> Matrix t vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ] corr :: 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 <= dim v = vectSS (dim ker) v <> ker | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")" conv :: (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 = corr ker' v' where ker' = (flatten.fliprl.asRow) ker v' | dim ker > 1 = join [z,v,z] | otherwise = v z = constant 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 = 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 corr2 :: Product a => Matrix a -> Matrix a -> Matrix a -- ^ 2D correlation corr2 ker mat = dims . concatMap (map ((<.> 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) conv2 :: (Num a, Product a) => Matrix a -> Matrix a -> Matrix a -- ^ 2D convolution conv2 k m = corr2 (fliprl . flipud $ k) pm where pm | r == 0 && c == 0 = m | r == 0 = fromBlocks [[z3,m,z3]] | c == 0 = fromBlocks [[z2],[m],[z2]] | otherwise = fromBlocks [[z1,z2,z1] ,[z3, m,z3] ,[z1,z2,z1]] r = rows k - 1 c = cols k - 1 h = rows m w = cols m z1 = konst' 0 (r,c) z2 = konst' 0 (r,w) z3 = konst' 0 (h,c) -- TODO: could be simplified using future empty arrays 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.15.0.0/lib/Graphics/0000755000000000000000000000000012165764700014113 5ustar0000000000000000hmatrix-0.15.0.0/lib/Graphics/Plot.hs0000644000000000000000000001363612165764700015376 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Graphics.Plot -- Copyright : (c) Alberto Ruiz 2005-8 -- License : GPL-style -- -- Maintainer : Alberto Ruiz (aruiz at um dot es) -- Stability : provisional -- Portability : uses gnuplot and ImageMagick -- -- This module is deprecated. It can be replaced by improved drawing tools -- available in the plot\\plot-gtk packages by Vivian McPhail or Gnuplot by Henning Thielemann. ----------------------------------------------------------------------------- module Graphics.Plot( mplot, plot, parametricPlot, splot, mesh, meshdom, matrixToPGM, imshow, gnuplotX, gnuplotpdf, gnuplotWin ) where import Numeric.Container import Data.List(intersperse) import System.Process (system) -- | From vectors x and y, it generates a pair of matrices to be used as x and y arguments for matrix functions. meshdom :: Vector Double -> Vector Double -> (Matrix Double , Matrix Double) meshdom r1 r2 = (outer r1 (constant 1 (dim r2)), outer (constant 1 (dim r1)) r2) {- | Draws a 3D surface representation of a real matrix. > > mesh $ build (10,10) (\\i j -> i + (j-5)^2) In certain versions you can interactively rotate the graphic using the mouse. -} mesh :: Matrix Double -> IO () mesh m = gnuplotX (command++dat) where command = "splot "++datafollows++" matrix with lines\n" dat = prep $ toLists m {- | Draws the surface represented by the function f in the desired ranges and number of points, internally using 'mesh'. > > let f x y = cos (x + y) > > splot f (0,pi) (0,2*pi) 50 -} splot :: (Matrix Double->Matrix Double->Matrix Double) -> (Double,Double) -> (Double,Double) -> Int -> IO () splot f rx ry n = mesh z where (x,y) = meshdom (linspace n rx) (linspace n ry) z = f x y {- | plots several vectors against the first one > > let t = linspace 100 (-3,3) in mplot [t, sin t, exp (-t^2)] -} mplot :: [Vector Double] -> IO () mplot m = gnuplotX (commands++dats) where commands = if length m == 1 then command1 else commandmore command1 = "plot "++datafollows++" with lines\n" ++ dat commandmore = "plot " ++ plots ++ "\n" plots = concat $ intersperse ", " (map cmd [2 .. length m]) cmd k = datafollows++" using 1:"++show k++" with lines" dat = prep $ toLists $ fromColumns m dats = concat (replicate (length m-1) dat) {- | Draws a list of functions over a desired range and with a desired number of points > > plot [sin, cos, sin.(3*)] (0,2*pi) 1000 -} plot :: [Vector Double->Vector Double] -> (Double,Double) -> Int -> IO () plot fs rx n = mplot (x: mapf fs x) where x = linspace n rx mapf gs y = map ($ y) gs {- | Draws a parametric curve. For instance, to draw a spiral we can do something like: > > parametricPlot (\t->(t * sin t, t * cos t)) (0,10*pi) 1000 -} parametricPlot :: (Vector Double->(Vector Double,Vector Double)) -> (Double, Double) -> Int -> IO () parametricPlot f rt n = mplot [fx, fy] where t = linspace n rt (fx,fy) = f t -- | writes a matrix to pgm image file matrixToPGM :: Matrix Double -> String matrixToPGM m = header ++ unlines (map unwords ll) where c = cols m r = rows m header = "P2 "++show c++" "++show r++" "++show (round maxgray :: Int)++"\n" maxgray = 255.0 maxval = maxElement m minval = minElement m scale' = if maxval == minval then 0.0 else maxgray / (maxval - minval) f x = show ( round ( scale' *(x - minval) ) :: Int ) ll = map (map f) (toLists m) -- | imshow shows a representation of a matrix as a gray level image using ImageMagick's display. imshow :: Matrix Double -> IO () imshow m = do _ <- system $ "echo \""++ matrixToPGM m ++"\"| display -antialias -resize 300 - &" return () ---------------------------------------------------- gnuplotX :: String -> IO () gnuplotX command = do { _ <- system cmdstr; return()} where cmdstr = "echo \""++command++"\" | gnuplot -persist" datafollows = "\\\"-\\\"" prep = (++"e\n\n") . unlines . map (unwords . map show) gnuplotpdf :: String -> String -> [([[Double]], String)] -> IO () gnuplotpdf title command ds = gnuplot (prelude ++ command ++" "++ draw) >> postproc where prelude = "set terminal epslatex color; set output '"++title++".tex';" (dats,defs) = unzip ds draw = concat (intersperse ", " (map ("\"-\" "++) defs)) ++ "\n" ++ concatMap pr dats postproc = do _ <- system $ "epstopdf "++title++".eps" mklatex _ <- system $ "pdflatex "++title++"aux.tex > /dev/null" _ <- system $ "pdfcrop "++title++"aux.pdf > /dev/null" _ <- system $ "mv "++title++"aux-crop.pdf "++title++".pdf" _ <- system $ "rm "++title++"aux.* "++title++".eps "++title++".tex" return () mklatex = writeFile (title++"aux.tex") $ "\\documentclass{article}\n"++ "\\usepackage{graphics}\n"++ "\\usepackage{nopageno}\n"++ "\\usepackage{txfonts}\n"++ "\\renewcommand{\\familydefault}{phv}\n"++ "\\usepackage[usenames]{color}\n"++ "\\begin{document}\n"++ "\\begin{center}\n"++ " \\input{./"++title++".tex}\n"++ "\\end{center}\n"++ "\\end{document}" pr = (++"e\n") . unlines . map (unwords . map show) gnuplot cmd = do writeFile "gnuplotcommand" cmd _ <- system "gnuplot gnuplotcommand" _ <- system "rm gnuplotcommand" return () gnuplotWin :: String -> String -> [([[Double]], String)] -> IO () gnuplotWin title command ds = gnuplot (prelude ++ command ++" "++ draw) where (dats,defs) = unzip ds draw = concat (intersperse ", " (map ("\"-\" "++) defs)) ++ "\n" ++ concatMap pr dats pr = (++"e\n") . unlines . map (unwords . map show) prelude = "set title \""++title++"\";" gnuplot cmd = do writeFile "gnuplotcommand" cmd _ <- system "gnuplot -persist gnuplotcommand" _ <- system "rm gnuplotcommand" return () hmatrix-0.15.0.0/lib/Data/0000755000000000000000000000000012165764700013224 5ustar0000000000000000hmatrix-0.15.0.0/lib/Data/Packed.hs0000644000000000000000000000134112165764700014746 0ustar0000000000000000----------------------------------------------------------------------------- {- | Module : Data.Packed Copyright : (c) Alberto Ruiz 2006-2010 License : GPL-style Maintainer : Alberto Ruiz (aruiz at um dot es) Stability : provisional Portability : uses ffi Types for dense 'Vector' and 'Matrix' of 'Storable' elements. -} ----------------------------------------------------------------------------- module Data.Packed ( module Data.Packed.Vector, module Data.Packed.Matrix, -- module Numeric.Conversion, -- module Data.Packed.Random, -- module Data.Complex ) where import Data.Packed.Vector import Data.Packed.Matrix --import Data.Packed.Random --import Data.Complex --import Numeric.Conversionhmatrix-0.15.0.0/lib/Data/Packed/0000755000000000000000000000000012165764700014413 5ustar0000000000000000hmatrix-0.15.0.0/lib/Data/Packed/Internal.hs0000644000000000000000000000140212165764700016520 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal -- Copyright : (c) Alberto Ruiz 2007 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- Reexports all internal modules -- ----------------------------------------------------------------------------- -- #hide module Data.Packed.Internal ( module Data.Packed.Internal.Common, module Data.Packed.Internal.Signatures, module Data.Packed.Internal.Vector, module Data.Packed.Internal.Matrix, ) where import Data.Packed.Internal.Common import Data.Packed.Internal.Signatures import Data.Packed.Internal.Vector import Data.Packed.Internal.Matrix hmatrix-0.15.0.0/lib/Data/Packed/Vector.hs0000644000000000000000000000506212165764700016214 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Vector -- Copyright : (c) Alberto Ruiz 2007-10 -- License : GPL -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- 1D arrays suitable for numeric computations using external libraries. -- -- This module provides basic functions for manipulation of structure. -- ----------------------------------------------------------------------------- module Data.Packed.Vector ( Vector, fromList, (|>), toList, buildVector, dim, (@>), subVector, takesV, join, mapVector, mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith, mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_, foldLoop, foldVector, foldVectorG, foldVectorWithIndex ) where import Data.Packed.Internal.Vector import Foreign.Storable ------------------------------------------------------------------- #ifdef BINARY import Data.Binary import Control.Monad(replicateM) -- 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 = do let d = dim v mapM_ (\i -> put $ v @> i) [0..(d-1)] getVector d = do xs <- replicateM d get return $! fromList xs instance (Binary a, Storable a) => Binary (Vector a) where put v = do let d = dim v put d mapM_ putVector $! takesV (chunks d) v get = do d <- get vs <- mapM getVector $ chunks d return $! join vs #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.15.0.0/lib/Data/Packed/Development.hs0000644000000000000000000000157612165764700017242 0ustar0000000000000000 ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Development -- Copyright : (c) Alberto Ruiz 2009 -- License : GPL -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- The library can be easily extended with additional foreign functions -- using the tools in this module. Illustrative usage examples can be found -- in the @examples\/devel@ folder included in the package. -- ----------------------------------------------------------------------------- module Data.Packed.Development ( createVector, createMatrix, vec, mat, app1, app2, app3, app4, app5, app6, app7, app8, app9, app10, MatrixOrder(..), orderOf, cmat, fmat, unsafeFromForeignPtr, unsafeToForeignPtr, check, (//), at', atM' ) where import Data.Packed.Internal hmatrix-0.15.0.0/lib/Data/Packed/Foreign.hs0000644000000000000000000000620112165764700016337 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 Data.Packed.Foreign ( app , appVector, appVectorLen , appMatrix, appMatrixLen, appMatrixRaw, appMatrixRawLen , unsafeMatrixToVector, unsafeMatrixToForeignPtr ) where import Data.Packed.Internal import qualified Data.Vector.Storable as S import Foreign (Ptr, ForeignPtr, Storable) import Foreign.C.Types (CInt) import GHC.Base (IO(..), realWorld#) {-# INLINE unsafeInlinePerformIO #-} -- | If we use unsafePerformIO, it may not get inlined, so in a function that returns IO (which are all safe uses of app* in this module), there would be -- unecessary calls to unsafePerformIO or its internals. unsafeInlinePerformIO :: IO a -> a unsafeInlinePerformIO (IO f) = case f realWorld# of (# _, x #) -> x {-# INLINE app #-} -- | Only useful since it is left associated with a precedence of 1, unlike 'Prelude.$', which is right associative. -- e.g. -- -- @ -- someFunction -- \`appMatrixLen\` m -- \`appVectorLen\` v -- \`app\` other -- \`app\` arguments -- \`app\` go here -- @ -- -- One could also write: -- -- @ -- (someFunction -- \`appMatrixLen\` m -- \`appVectorLen\` v) -- other -- arguments -- (go here) -- @ -- app :: (a -> b) -> a -> b app f = f {-# INLINE appVector #-} appVector :: Storable a => (Ptr a -> b) -> Vector a -> b appVector f x = unsafeInlinePerformIO (S.unsafeWith x (return . f)) {-# INLINE appVectorLen #-} appVectorLen :: Storable a => (CInt -> Ptr a -> b) -> Vector a -> b appVectorLen f x = unsafeInlinePerformIO (S.unsafeWith x (return . f (fromIntegral (S.length x)))) {-# INLINE appMatrix #-} appMatrix :: Element a => (Ptr a -> b) -> Matrix a -> b appMatrix f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f)) {-# INLINE appMatrixLen #-} appMatrixLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b appMatrixLen f x = unsafeInlinePerformIO (S.unsafeWith (flatten x) (return . f r c)) where r = fromIntegral (rows x) c = fromIntegral (cols x) {-# INLINE appMatrixRaw #-} appMatrixRaw :: Storable a => (Ptr a -> b) -> Matrix a -> b appMatrixRaw f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f)) {-# INLINE appMatrixRawLen #-} appMatrixRawLen :: Element a => (CInt -> CInt -> Ptr a -> b) -> Matrix a -> b appMatrixRawLen f x = unsafeInlinePerformIO (S.unsafeWith (xdat x) (return . f r c)) where r = fromIntegral (rows x) c = fromIntegral (cols x) infixl 1 `app` infixl 1 `appVector` infixl 1 `appMatrix` infixl 1 `appMatrixRaw` {-# INLINE unsafeMatrixToVector #-} -- | This will disregard the order of the matrix, and simply return it as-is. -- If the order of the matrix is RowMajor, this function is identical to 'flatten'. unsafeMatrixToVector :: Matrix a -> Vector a unsafeMatrixToVector = xdat {-# INLINE unsafeMatrixToForeignPtr #-} unsafeMatrixToForeignPtr :: Storable a => Matrix a -> (ForeignPtr a, Int) unsafeMatrixToForeignPtr m = S.unsafeToForeignPtr0 (xdat m) hmatrix-0.15.0.0/lib/Data/Packed/Matrix.hs0000644000000000000000000003227312165764700016222 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Matrix -- Copyright : (c) Alberto Ruiz 2007-10 -- License : GPL -- -- 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 Data.Packed.Matrix ( Matrix, Element, rows,cols, (><), trans, reshape, flatten, fromLists, toLists, buildMatrix, (@@>), asRow, asColumn, fromRows, toRows, fromColumns, toColumns, fromBlocks, diagBlock, toBlocks, toBlocksEvery, repmat, flipud, fliprl, subMatrix, takeRows, dropRows, takeColumns, dropColumns, extractRows, diagRect, takeDiag, mapMatrix, mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_, liftMatrix, liftMatrix2, liftMatrix2Auto,fromArray2D ) where import Data.Packed.Internal import qualified Data.Packed.ST as ST import Data.Array import Data.List(transpose,intersperse) import Foreign.Storable(Storable) import Control.Monad(liftM) ------------------------------------------------------------------- #ifdef BINARY import Data.Binary import Control.Monad(replicateM) instance (Binary a, Element a, Storable a) => Binary (Matrix a) where put m = do let r = rows m let c = cols m put r put c mapM_ (\i -> mapM_ (\j -> put $ m @@> (i,j)) [0..(c-1)]) [0..(r-1)] get = do r <- get c <- get xs <- replicateM r $ replicateM c get return $ fromLists xs #endif ------------------------------------------------------------------- instance (Show a, Element a) => (Show (Matrix a)) where show m = (sizes++) . dsp . map (map show) . toLists $ m where sizes = "("++show (rows m)++"><"++show (cols m)++")\n" dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse ", " ------------------------------------------------------------------ instance (Element a, Read a) => Read (Matrix a) where readsPrec _ s = [((rs>' $ dims breakAt c l = (a++[c],tail b) where (a,b) = break (==c) l ------------------------------------------------------------------ -- | creates a matrix from a vertical list of matrices joinVert :: Element t => [Matrix t] -> Matrix t joinVert ms = case common cols ms of Nothing -> error "(impossible) joinVert on matrices with different number of columns" Just c -> reshape c $ join (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 {- | Creates 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: @\> let disp = putStr . dispf 2 \> let vector xs = fromList xs :: Vector Double \> let diagl = diag . vector \> let rowm = asRow . vector \> disp $ fromBlocks [[ident 5, 7, rowm[10,20]], [3, diagl[1,2,3], 0]] 8x10 1 0 0 0 0 7 7 7 10 20 0 1 0 0 0 7 7 7 10 20 0 0 1 0 0 7 7 7 10 20 0 0 0 1 0 7 7 7 10 20 0 0 0 0 1 7 7 7 10 20 3 3 3 3 3 1 0 0 0 0 3 3 3 3 3 0 2 0 0 0 3 3 3 3 3 0 0 3 0 0@ -} fromBlocks :: Element t => [[Matrix t]] -> Matrix t fromBlocks = fromBlocksRaw . adaptBlocks fromBlocksRaw mms = joinVert . map joinHoriz $ mms adaptBlocks ms = ms' where bc = case common length ms of Just c -> c Nothing -> error "fromBlocks requires rectangular [[Matrix]]" rs = map (compatdim . map rows) ms cs = map (compatdim . map cols) (transpose ms) szs = sequence [rs,cs] ms' = splitEvery bc $ zipWith g szs (concat ms) g [Just nr,Just nc] m | nr == r && nc == c = m | r == 1 && c == 1 = reshape 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 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 = fromRows . reverse . toRows $ m -- | Reverse columns fliprl :: Element t => Matrix t -> Matrix t fliprl m = fromColumns . reverse . toColumns $ m ------------------------------------------------------------ {- | creates a rectangular diagonal matrix: @> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double (4><5) [ 10.0, 7.0, 7.0, 7.0, 7.0 , 7.0, 20.0, 7.0, 7.0, 7.0 , 7.0, 7.0, 30.0, 7.0, 7.0 , 7.0, 7.0, 7.0, 7.0, 7.0 ]@ -} diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t diagRect z v r c = ST.runSTMatrix $ do m <- ST.newMatrix z r c let d = min r c `min` (dim v) mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1] return m -- | extracts the diagonal from a rectangular matrix takeDiag :: (Element t) => Matrix t -> Vector t takeDiag m = fromList [flatten m `at` (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]] ------------------------------------------------------------ {- | An easy way to create a matrix: @\> (2><3)[1..6] (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. The input list is explicitly truncated, so that it can safely be used with lists that are too long (like infinite lists). Example: @\> (2><3)[1..] (2><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 ]@ -} (><) :: (Storable a) => Int -> Int -> [a] -> Matrix a r >< c = f where f l | dim v == r*c = matrixFromVector RowMajor c v | otherwise = error $ "inconsistent list size = " ++show (dim v) ++" in ("++show r++"><"++show c++")" where v = fromList $ take (r*c) l ---------------------------------------------------------------- -- | Creates a matrix with the first n rows of another matrix takeRows :: Element t => Int -> Matrix t -> Matrix t takeRows n mt = subMatrix (0,0) (n, cols mt) mt -- | Creates a copy of a matrix without the first n rows dropRows :: Element t => Int -> Matrix t -> Matrix t dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt -- |Creates a matrix with the first n columns of another matrix takeColumns :: Element t => Int -> Matrix t -> Matrix t takeColumns n mt = subMatrix (0,0) (rows mt, n) mt -- | Creates a copy of a matrix without the first n columns dropColumns :: Element t => Int -> Matrix t -> Matrix t dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt ---------------------------------------------------------------- {- | Creates a 'Matrix' from a list of lists (considered as rows). @\> fromLists [[1,2],[3,4],[5,6]] (3><2) [ 1.0, 2.0 , 3.0, 4.0 , 5.0, 6.0 ]@ -} fromLists :: Element t => [[t]] -> Matrix t fromLists = fromRows . map fromList -- | creates a 1-row matrix from a vector asRow :: Storable a => Vector a -> Matrix a asRow v = reshape (dim v) v -- | creates a 1-column matrix from a vector 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 = fromRows $ extract (toRows m) l where extract l' is = [l'!!i |i<-is] {- | creates matrix by repetition of a matrix a given number of rows and columns @> repmat (ident 2) 2 3 :: Matrix Double (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 = fromBlocks $ splitEvery c $ replicate (r*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 lM f m1 m2 = reshape (max (cols m1) (cols m2)) (f (flatten m1) (flatten m2)) compat' :: Matrix a -> Matrix b -> Bool compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2 where s1 = size m1 s2 = size m2 ------------------------------------------------------------ toBlockRows [r] m | r == rows m = [m] toBlockRows rs m = map (reshape (cols m)) (takesV szs (flatten m)) where szs = map (* cols m) rs 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 = map (toBlockCols cs) . toBlockRows rs $ m -- | 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 = 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) {- | @ghci> mapMatrixWithIndexM_ (\\(i,j) v -> printf \"m[%.0f,%.0f] = %.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 {- | @ghci> mapMatrixWithIndexM (\\(i,j) v -> Just $ 100*v + 10*i + 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 {- | @ghci> mapMatrixWithIndex (\\(i,j) v -> 100*v + 10*i + j) (ident 3:: Matrix Double) (3><3) [ 100.0, 1.0, 2.0 , 10.0, 111.0, 12.0 , 20.0, 21.0, 122.0 ]@ -} mapMatrixWithIndex :: (Element a, Storable b) => ((Int, Int) -> a -> b) -> Matrix a -> Matrix b mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m where c = cols m mapMatrix :: (Storable a, Storable b) => (a -> b) -> Matrix a -> Matrix b mapMatrix f = liftMatrix (mapVector f) hmatrix-0.15.0.0/lib/Data/Packed/Random.hs0000644000000000000000000000321612165764700016171 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Vector -- Copyright : (c) Alberto Ruiz 2009 -- License : GPL -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Random vectors and matrices. -- ----------------------------------------------------------------------------- module Data.Packed.Random ( Seed, RandDist(..), randomVector, gaussianSample, uniformSample ) where import Numeric.GSL.Vector import Data.Packed import Numeric.ContainerBoot import Numeric.LinearAlgebra.Algorithms type Seed = Int -- | 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 hmatrix-0.15.0.0/lib/Data/Packed/ST.hs0000644000000000000000000001474012165764700015303 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.ST -- Copyright : (c) Alberto Ruiz 2008 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable -- -- In-place manipulation inside the ST monad. -- See examples/inplace.hs in the distribution. -- ----------------------------------------------------------------------------- module Data.Packed.ST ( -- * Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- * Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix, -- * Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector, unsafeThawVector, unsafeFreezeVector, newUndefinedMatrix, unsafeReadMatrix, unsafeWriteMatrix, unsafeThawMatrix, unsafeFreezeMatrix ) where import Data.Packed.Internal import Control.Monad.ST(ST, runST) import Foreign.Storable(Storable, peekElemOff, pokeElemOff) #if MIN_VERSION_base(4,4,0) import Control.Monad.ST.Unsafe(unsafeIOToST) #else import Control.Monad.ST(unsafeIOToST) #endif {-# INLINE ioReadV #-} ioReadV :: Storable t => Vector t -> Int -> IO t ioReadV v k = unsafeWith v $ \s -> peekElemOff s k {-# INLINE ioWriteV #-} ioWriteV :: Storable t => Vector t -> Int -> t -> IO () ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x newtype STVector s t = STVector (Vector t) thawVector :: Storable t => Vector t -> ST s (STVector s t) thawVector = unsafeIOToST . fmap STVector . cloneVector unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t) unsafeThawVector = unsafeIOToST . return . STVector runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t runSTVector st = runST (st >>= unsafeFreezeVector) {-# INLINE unsafeReadVector #-} unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x {-# INLINE unsafeWriteVector #-} unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s () unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k {-# INLINE modifyVector #-} modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s () modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s1 t -> ST s2 a liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x freezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t) freezeVector v = liftSTVector id v unsafeFreezeVector :: (Storable t) => STVector s1 t -> ST s2 (Vector t) unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x {-# INLINE safeIndexV #-} safeIndexV f (STVector v) k | k < 0 || k>= dim v = error $ "out of range error in vector (dim=" ++show (dim v)++", pos="++show k++")" | otherwise = f (STVector v) k {-# INLINE readVector #-} readVector :: Storable t => STVector s t -> Int -> ST s t readVector = safeIndexV unsafeReadVector {-# INLINE writeVector #-} writeVector :: Storable t => STVector s t -> Int -> t -> ST s () writeVector = safeIndexV unsafeWriteVector newUndefinedVector :: Storable t => Int -> ST s (STVector s t) newUndefinedVector = unsafeIOToST . fmap STVector . createVector {-# INLINE newVector #-} newVector :: Storable t => t -> Int -> ST s (STVector s t) newVector x n = do v <- newUndefinedVector n let go (-1) = return v go !k = unsafeWriteVector v k x >> go (k-1 :: Int) go (n-1) ------------------------------------------------------------------------- {-# INLINE ioReadM #-} ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t ioReadM (Matrix _ nc cv RowMajor) r c = ioReadV cv (r*nc+c) ioReadM (Matrix nr _ fv ColumnMajor) r c = ioReadV fv (c*nr+r) {-# INLINE ioWriteM #-} ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO () ioWriteM (Matrix _ nc cv RowMajor) r c val = ioWriteV cv (r*nc+c) val ioWriteM (Matrix nr _ fv ColumnMajor) r c val = ioWriteV fv (c*nr+r) val newtype STMatrix s t = STMatrix (Matrix t) thawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t) thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t) unsafeThawMatrix = unsafeIOToST . return . STMatrix runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t runSTMatrix st = runST (st >>= unsafeFreezeMatrix) {-# INLINE unsafeReadMatrix #-} unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r {-# INLINE unsafeWriteMatrix #-} unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c {-# INLINE modifyMatrix #-} modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s () modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c liftSTMatrix :: (Storable t) => (Matrix t -> a) -> STMatrix s1 t -> ST s2 a liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x unsafeFreezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t) unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x freezeMatrix :: (Storable t) => STMatrix s1 t -> ST s2 (Matrix t) freezeMatrix m = liftSTMatrix id m cloneMatrix (Matrix r c d o) = cloneVector d >>= return . (\d' -> Matrix r c d' o) {-# INLINE safeIndexM #-} safeIndexM f (STMatrix m) r c | r<0 || r>=rows m || c<0 || c>=cols m = error $ "out of range error in matrix (size=" ++show (rows m,cols m)++", pos="++show (r,c)++")" | otherwise = f (STMatrix m) r c {-# INLINE readMatrix #-} readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t readMatrix = safeIndexM unsafeReadMatrix {-# INLINE writeMatrix #-} writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () writeMatrix = safeIndexM unsafeWriteMatrix newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t) newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c {-# NOINLINE newMatrix #-} newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t) newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c) hmatrix-0.15.0.0/lib/Data/Packed/Internal/0000755000000000000000000000000012165764700016167 5ustar0000000000000000hmatrix-0.15.0.0/lib/Data/Packed/Internal/Vector.hs0000644000000000000000000004365512165764700020002 0ustar0000000000000000{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Vector -- Copyright : (c) Alberto Ruiz 2007 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable (uses FFI) -- -- Vector implementation -- ----------------------------------------------------------------------------- module Data.Packed.Internal.Vector ( Vector, dim, fromList, toList, (|>), join, (@>), safe, at, at', subVector, takesV, mapVector, mapVectorWithIndex, zipVectorWith, unzipVectorWith, mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_, foldVector, foldVectorG, foldLoop, foldVectorWithIndex, createVector, vec, asComplex, asReal, float2DoubleV, double2FloatV, stepF, stepD, condF, condD, conjugateQ, conjugateC, fwriteVector, freadVector, fprintfVector, fscanfVector, cloneVector, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith ) where import Data.Packed.Internal.Common import Data.Packed.Internal.Signatures import Foreign.Marshal.Alloc(free) import Foreign.Marshal.Array(peekArray, pokeArray, copyArray, advancePtr) import Foreign.ForeignPtr(ForeignPtr, castForeignPtr) import Foreign.Ptr(Ptr) import Foreign.Storable(Storable, peekElemOff, pokeElemOff, sizeOf) import Foreign.C.String import Foreign.C.Types import Data.Complex import Control.Monad(when) import System.IO.Unsafe(unsafePerformIO) #if __GLASGOW_HASKELL__ >= 605 import GHC.ForeignPtr (mallocPlainForeignPtrBytes) #else import Foreign.ForeignPtr (mallocForeignPtrBytes) #endif import GHC.Base #if __GLASGOW_HASKELL__ < 612 import GHC.IOBase hiding (liftIO) #endif import qualified Data.Vector.Storable as Vector import Data.Vector.Storable(Vector, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) -- | Number of elements dim :: (Storable t) => Vector t -> Int dim = Vector.length -- C-Haskell vector adapter -- vec :: Adapt (CInt -> Ptr t -> r) (Vector t) r vec :: (Storable t) => Vector t -> (((CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b vec x f = unsafeWith x $ \p -> do let v g = do g (fi $ dim x) p f v {-# INLINE vec #-} -- allocates memory for a new vector createVector :: Storable a => Int -> IO (Vector a) createVector n = do when (n <= 0) $ error ("trying to createVector of dim "++show n) fp <- doMalloc undefined return $ unsafeFromForeignPtr fp 0 n where -- -- Use the much cheaper Haskell heap allocated storage -- for foreign pointer space we control -- doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc dummy = do #if __GLASGOW_HASKELL__ >= 605 mallocPlainForeignPtrBytes (n * sizeOf dummy) #else mallocForeignPtrBytes (n * sizeOf dummy) #endif {- | creates a Vector from a list: @> fromList [2,3,5,7] 4 |> [2.0,3.0,5.0,7.0]@ -} fromList :: Storable a => [a] -> Vector a fromList l = unsafePerformIO $ do v <- createVector (length l) unsafeWith v $ \ p -> pokeArray p l return v 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) {- | An alternative to 'fromList' with explicit dimension. The input list is explicitly truncated if it is too long, so it may safely be used, for instance, with infinite lists. This is the format used in the instances for Show (Vector a). -} (|>) :: (Storable a) => Int -> [a] -> Vector a infixl 9 |> n |> l = if length l' == n then fromList l' else error "list too short for |>" where l' = take n l -- | access to Vector elements without range checking at' :: Storable a => Vector a -> Int -> a at' v n = safeRead v $ flip peekElemOff n {-# INLINE at' #-} -- -- turn off bounds checking with -funsafe at configure time. -- ghc will optimise away the salways true case at compile time. -- #if defined(UNSAFE) safe :: Bool safe = False #else safe = True #endif -- | access to Vector elements with range checking. at :: Storable a => Vector a -> Int -> a at v n | safe = if n >= 0 && n < dim v then at' v n else error "vector index out of range" | otherwise = at' v n {-# INLINE at #-} {- | takes a number of consecutive elements from a Vector @> subVector 2 3 (fromList [1..10]) 3 |> [3.0,4.0,5.0]@ -} subVector :: Storable t => Int -- ^ index of the starting element -> Int -- ^ number of elements to extract -> Vector t -- ^ source -> Vector t -- ^ result subVector = Vector.slice {- | Reads a vector position: @> fromList [0..9] \@\> 7 7.0@ -} (@>) :: Storable t => Vector t -> Int -> t infixl 9 @> (@>) = at {- | creates a new Vector by joining a list of Vectors @> join [fromList [1..5], constant 1 3] 8 |> [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]@ -} join :: Storable t => [Vector t] -> Vector t join [] = error "joining zero vectors" join [v] = v join 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)) [3 |> [1.0,2.0,3.0],4 |> [4.0,5.0,6.0,7.0]]@ -} takesV :: Storable t => [Int] -> Vector t -> [Vector t] takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w) | otherwise = go ms w where go [] _ = [] go (n:ns) v = subVector 0 n v : go ns (subVector n (dim v - n) v) --------------------------------------------------------------- -- | transforms a complex vector into a real vector with alternating real and imaginary parts asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n) where (fp,i,n) = unsafeToForeignPtr v -- | transforms a real vector into a complex vector with alternating real and imaginary parts asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a) asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2) where (fp,i,n) = unsafeToForeignPtr v --------------------------------------------------------------- float2DoubleV :: Vector Float -> Vector Double float2DoubleV v = unsafePerformIO $ do r <- createVector (dim v) app2 c_float2double vec v vec r "float2double" return r double2FloatV :: Vector Double -> Vector Float double2FloatV v = unsafePerformIO $ do r <- createVector (dim v) app2 c_double2float vec v vec r "double2float2" return r foreign import ccall unsafe "float2double" c_float2double:: TFV foreign import ccall unsafe "double2float" c_double2float:: TVF --------------------------------------------------------------- stepF :: Vector Float -> Vector Float stepF v = unsafePerformIO $ do r <- createVector (dim v) app2 c_stepF vec v vec r "stepF" return r stepD :: Vector Double -> Vector Double stepD v = unsafePerformIO $ do r <- createVector (dim v) app2 c_stepD vec v vec r "stepD" return r foreign import ccall unsafe "stepF" c_stepF :: TFF foreign import ccall unsafe "stepD" c_stepD :: TVV --------------------------------------------------------------- condF :: Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float condF x y l e g = unsafePerformIO $ do r <- createVector (dim x) app6 c_condF vec x vec y vec l vec e vec g vec r "condF" return r condD :: Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double condD x y l e g = unsafePerformIO $ do r <- createVector (dim x) app6 c_condD vec x vec y vec l vec e vec g vec r "condD" return r foreign import ccall unsafe "condF" c_condF :: CInt -> PF -> CInt -> PF -> CInt -> PF -> TFFF foreign import ccall unsafe "condD" c_condD :: CInt -> PD -> CInt -> PD -> CInt -> PD -> TVVV -------------------------------------------------------------------------------- conjugateAux fun x = unsafePerformIO $ do v <- createVector (dim x) app2 fun vec x vec v "conjugateAux" return v conjugateQ :: Vector (Complex Float) -> Vector (Complex Float) conjugateQ = conjugateAux c_conjugateQ foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TQVQV conjugateC :: Vector (Complex Double) -> Vector (Complex Double) conjugateC = conjugateAux c_conjugateC foreign import ccall unsafe "conjugateC" c_conjugateC :: TCVCV -------------------------------------------------------------------------------- cloneVector :: Storable t => Vector t -> IO (Vector t) cloneVector v = do let n = dim v r <- createVector n let f _ s _ d = copyArray d s n >> return 0 app2 f vec v vec r "cloneVector" return r ------------------------------------------------------------------ -- | map on Vectors mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b mapVector f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f x) go (k-1) go (dim v -1) return w {-# INLINE mapVector #-} -- | zipWith for Vectors zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c zipVectorWith f u v = unsafePerformIO $ do let n = min (dim u) (dim v) w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do x <- peekElemOff pu k y <- peekElemOff pv k pokeElemOff pw k (f x y) go (k-1) go (n -1) return w {-# INLINE zipVectorWith #-} -- | unzipWith for Vectors unzipVectorWith :: (Storable (a,b), Storable c, Storable d) => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d) unzipVectorWith f u = unsafePerformIO $ do let n = dim u v <- createVector n w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do z <- peekElemOff pu k let (x,y) = f z pokeElemOff pv k x pokeElemOff pw k y go (k-1) go (n-1) return (v,w) {-# INLINE unzipVectorWith #-} foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b foldVector f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f y s) go (dim v -1) x {-# INLINE foldVector #-} -- the zero-indexed index is passed to the folding function foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b foldVectorWithIndex f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f k y s) go (dim v -1) x {-# INLINE foldVectorWithIndex #-} foldLoop f s0 d = go (d - 1) s0 where go 0 s = f (0::Int) s go !j !s = go (j - 1) (f j s) foldVectorG f s0 v = foldLoop g s0 (dim v) where g !k !s = f k (at' v) s {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) {-# INLINE foldVectorG #-} ------------------------------------------------------------------- -- | monadic map over Vectors -- the monad @m@ must be strict mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b) mapVectorM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorM #-} -- | monadic map over Vectors mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m () mapVectorM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f x mapVectorM' (k+1) t {-# INLINE mapVectorM_ #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function -- the monad @m@ must be strict mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b) mapVectorWithIndexM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorWithIndexM #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m () mapVectorWithIndexM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f k x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f k x mapVectorM' (k+1) t {-# INLINE mapVectorWithIndexM_ #-} mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b --mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b]) mapVectorWithIndex f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f k x) go (k-1) go (dim v -1) return w {-# INLINE mapVectorWithIndex #-} ------------------------------------------------------------------- -- | Loads a vector from an ASCII file (the number of elements must be known in advance). fscanfVector :: FilePath -> Int -> IO (Vector Double) fscanfVector filename n = do charname <- newCString filename res <- createVector n app1 (gsl_vector_fscanf charname) vec res "gsl_vector_fscanf" free charname return res foreign import ccall unsafe "vector_fscanf" gsl_vector_fscanf:: Ptr CChar -> TV -- | Saves the elements of a vector, with a given format (%f, %e, %g), to an ASCII file. fprintfVector :: FilePath -> String -> Vector Double -> IO () fprintfVector filename fmt v = do charname <- newCString filename charfmt <- newCString fmt app1 (gsl_vector_fprintf charname charfmt) vec v "gsl_vector_fprintf" free charname free charfmt foreign import ccall unsafe "vector_fprintf" gsl_vector_fprintf :: Ptr CChar -> Ptr CChar -> TV -- | Loads a vector from a binary file (the number of elements must be known in advance). freadVector :: FilePath -> Int -> IO (Vector Double) freadVector filename n = do charname <- newCString filename res <- createVector n app1 (gsl_vector_fread charname) vec res "gsl_vector_fread" free charname return res foreign import ccall unsafe "vector_fread" gsl_vector_fread:: Ptr CChar -> TV -- | Saves the elements of a vector to a binary file. fwriteVector :: FilePath -> Vector Double -> IO () fwriteVector filename v = do charname <- newCString filename app1 (gsl_vector_fwrite charname) vec v "gsl_vector_fwrite" free charname foreign import ccall unsafe "vector_fwrite" gsl_vector_fwrite :: Ptr CChar -> TV hmatrix-0.15.0.0/lib/Data/Packed/Internal/Matrix.hs0000644000000000000000000004023612165764700017774 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Matrix -- Copyright : (c) Alberto Ruiz 2007 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable (uses FFI) -- -- Internal matrix representation -- ----------------------------------------------------------------------------- -- #hide module Data.Packed.Internal.Matrix( Matrix(..), rows, cols, cdat, fdat, MatrixOrder(..), orderOf, createMatrix, mat, cmat, fmat, toLists, flatten, reshape, Element(..), trans, fromRows, toRows, fromColumns, toColumns, matrixFromVector, subMatrix, liftMatrix, liftMatrix2, (@@>), atM', saveMatrix, singleton, size, shSize, conformVs, conformMs, conformVTo, conformMTo ) where import Data.Packed.Internal.Common import Data.Packed.Internal.Signatures import Data.Packed.Internal.Vector import Foreign.Marshal.Alloc(alloca, free) import Foreign.Marshal.Array(newArray) import Foreign.Ptr(Ptr, castPtr) import Foreign.Storable(Storable, peekElemOff, pokeElemOff, poke, sizeOf) import Data.Complex(Complex) import Foreign.C.Types import Foreign.C.String(newCString) import System.IO.Unsafe(unsafePerformIO) import Control.DeepSeq ----------------------------------------------------------------- {- Design considerations for the Matrix Type ----------------------------------------- - we must easily handle both row major and column major order, for bindings to LAPACK and GSL/C - we'd like to simplify redundant matrix transposes: - Some of them arise from the order requirements of some functions - some functions (matrix product) admit transposed arguments - maybe we don't really need this kind of simplification: - more complex code - some computational overhead - only appreciable gain in code with a lot of redundant transpositions and cheap matrix computations - we could carry both the matrix and its (lazily computed) transpose. This may save some transpositions, but it is necessary to keep track of the data which is actually computed to be used by functions like the matrix product which admit both orders. - but if we need the transposed data and it is not in the structure, we must make sure that we touch the same foreignptr that is used in the computation. - a reasonable solution is using two constructors for a matrix. Transposition just "flips" the constructor. Actual data transposition is not done if followed by a matrix product or another transpose. -} data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq) transOrder RowMajor = ColumnMajor transOrder ColumnMajor = RowMajor {- | Matrix representation suitable for GSL and LAPACK computations. The elements are stored in a continuous memory array. -} data Matrix t = Matrix { irows :: {-# UNPACK #-} !Int , icols :: {-# UNPACK #-} !Int , xdat :: {-# UNPACK #-} !(Vector t) , order :: !MatrixOrder } -- RowMajor: preferred by C, fdat may require a transposition -- ColumnMajor: preferred by LAPACK, cdat may require a transposition cdat = xdat fdat = xdat rows :: Matrix t -> Int rows = irows cols :: Matrix t -> Int cols = icols orderOf :: Matrix t -> MatrixOrder orderOf = order -- | Matrix transpose. trans :: Matrix t -> Matrix t trans Matrix {irows = r, icols = c, xdat = d, order = o } = Matrix { irows = c, icols = r, xdat = d, order = transOrder o} cmat :: (Element t) => Matrix t -> Matrix t cmat m@Matrix{order = RowMajor} = m cmat Matrix {irows = r, icols = c, xdat = d, order = ColumnMajor } = Matrix { irows = r, icols = c, xdat = transdata r d c, order = RowMajor} fmat :: (Element t) => Matrix t -> Matrix t fmat m@Matrix{order = ColumnMajor} = m fmat Matrix {irows = r, icols = c, xdat = d, order = RowMajor } = Matrix { irows = r, icols = c, xdat = transdata c d r, order = ColumnMajor} -- C-Haskell matrix adapter -- mat :: Adapt (CInt -> CInt -> Ptr t -> r) (Matrix t) r mat :: (Storable t) => Matrix t -> (((CInt -> CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b mat a f = unsafeWith (xdat a) $ \p -> do let m g = do g (fi (rows a)) (fi (cols a)) p f m -- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose. -- -- @\> flatten ('ident' 3) -- 9 |> [1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0]@ flatten :: Element t => Matrix t -> Vector t flatten = xdat . cmat type Mt t s = Int -> Int -> Ptr t -> s -- not yet admitted by my haddock version -- infixr 6 ::> -- type t ::> s = Mt t s -- | the inverse of 'Data.Packed.Matrix.fromLists' toLists :: (Element t) => Matrix t -> [[t]] toLists m = splitEvery (cols m) . toList . flatten $ m -- | Create a matrix from a list of vectors. -- All vectors must have the same dimension, -- or dimension 1, which is are automatically expanded. fromRows :: Element t => [Vector t] -> Matrix t fromRows vs = case compatdim (map dim vs) of Nothing -> error "fromRows applied to [] or to vectors with different sizes" Just c -> reshape c . join . map (adapt c) $ vs where adapt c v | 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 = toRows' 0 where v = flatten m r = rows m c = cols m toRows' k | k == r*c = [] | otherwise = subVector k c v : toRows' (k+c) -- | Creates a matrix from a list of vectors, as columns fromColumns :: Element t => [Vector t] -> Matrix t fromColumns m = trans . fromRows $ m -- | Creates a list of vectors from the columns of a matrix toColumns :: Element t => Matrix t -> [Vector t] toColumns m = toRows . trans $ m -- | Reads a matrix position. (@@>) :: Storable t => Matrix t -> (Int,Int) -> t infixl 9 @@> m@Matrix {irows = r, icols = c} @@> (i,j) | safe = if i<0 || i>=r || j<0 || j>=c then error "matrix indexing out of range" else atM' m i j | otherwise = atM' m i j {-# INLINE (@@>) #-} -- Unsafe matrix access without range checking atM' Matrix {icols = c, xdat = v, order = RowMajor} i j = v `at'` (i*c+j) atM' Matrix {irows = r, xdat = v, order = ColumnMajor} i j = v `at'` (j*r+i) {-# INLINE atM' #-} ------------------------------------------------------------------ matrixFromVector o c v = Matrix { irows = r, icols = c, xdat = v, order = o } where (d,m) = dim v `quotRem` c r | m==0 = d | otherwise = error "matrixFromVector" -- 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 c p) {- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = trans . reshape r@ where r is the desired number of rows.) @\> reshape 4 ('fromList' [1..12]) (3><4) [ 1.0, 2.0, 3.0, 4.0 , 5.0, 6.0, 7.0, 8.0 , 9.0, 10.0, 11.0, 12.0 ]@ -} reshape :: Storable t => Int -> Vector t -> Matrix t reshape c v = matrixFromVector RowMajor c v singleton x = reshape 1 (fromList [x]) -- | application of a vector function on the flattened matrix elements liftMatrix :: (Storable a, Storable b) => (Vector a -> Vector b) -> Matrix a -> Matrix b liftMatrix f Matrix { icols = c, xdat = d, order = o } = matrixFromVector o c (f d) -- | application of a vector function on the flattened matrices elements liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t liftMatrix2 f m1 m2 | not (compat m1 m2) = error "nonconformant matrices in liftMatrix2" | otherwise = case orderOf m1 of RowMajor -> matrixFromVector RowMajor (cols m1) (f (xdat m1) (flatten m2)) ColumnMajor -> matrixFromVector ColumnMajor (cols m1) (f (xdat m1) ((xdat.fmat) m2)) compat :: Matrix a -> Matrix b -> Bool compat m1 m2 = rows m1 == rows m2 && cols m1 == cols m2 ------------------------------------------------------------------ {- | Supported matrix elements. This class provides optimized internal operations for selected element types. It provides unoptimised defaults for any 'Storable' type, so you can create instances simply as: @instance Element Foo@. -} class (Storable a) => Element a where subMatrixD :: (Int,Int) -- ^ (r0,c0) starting position -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix -> Matrix a -> Matrix a subMatrixD = subMatrix' transdata :: Int -> Vector a -> Int -> Vector a transdata = transdataP -- transdata' constantD :: a -> Int -> Vector a constantD = constantP -- constant' instance Element Float where transdata = transdataAux ctransF constantD = constantAux cconstantF instance Element Double where transdata = transdataAux ctransR constantD = constantAux cconstantR instance Element (Complex Float) where transdata = transdataAux ctransQ constantD = constantAux cconstantQ instance Element (Complex Double) where transdata = transdataAux ctransC constantD = constantAux cconstantC ------------------------------------------------------------------- transdata' :: Storable a => Int -> Vector a -> Int -> Vector a transdata' c1 v c2 = if noneed then v else unsafePerformIO $ do w <- createVector (r2*c2) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) _ = return () go !i (-1) = go (i-1) (c1-1) go !i !j = do x <- peekElemOff p (i*c1+j) pokeElemOff q (j*c2+i) x go i (j-1) go (r1-1) (c1-1) return w where r1 = dim v `div` c1 r2 = dim v `div` c2 noneed = r1 == 1 || c1 == 1 -- {-# SPECIALIZE transdata' :: Int -> Vector Double -> Int -> Vector Double #-} -- {-# SPECIALIZE transdata' :: Int -> Vector (Complex Double) -> Int -> Vector (Complex Double) #-} -- I don't know how to specialize... -- The above pragmas only seem to work on top level defs -- Fortunately everything seems to work using the above class -- C versions, still a little faster: transdataAux fun c1 d c2 = if noneed then d else unsafePerformIO $ do v <- createVector (dim d) unsafeWith d $ \pd -> unsafeWith v $ \pv -> fun (fi r1) (fi c1) pd (fi r2) (fi c2) pv // check "transdataAux" return v where r1 = dim d `div` c1 r2 = dim d `div` c2 noneed = r1 == 1 || c1 == 1 transdataP :: Storable a => Int -> Vector a -> Int -> Vector a transdataP c1 d c2 = if noneed then d else unsafePerformIO $ do v <- createVector (dim d) unsafeWith d $ \pd -> unsafeWith v $ \pv -> ctransP (fi r1) (fi c1) (castPtr pd) (fi sz) (fi r2) (fi c2) (castPtr pv) (fi sz) // check "transdataP" return v where r1 = dim d `div` c1 r2 = dim d `div` c2 sz = sizeOf (d @> 0) noneed = r1 == 1 || c1 == 1 foreign import ccall unsafe "transF" ctransF :: TFMFM foreign import ccall unsafe "transR" ctransR :: TMM foreign import ccall unsafe "transQ" ctransQ :: TQMQM foreign import ccall unsafe "transC" ctransC :: TCMCM foreign import ccall unsafe "transP" ctransP :: CInt -> CInt -> Ptr () -> CInt -> CInt -> CInt -> Ptr () -> CInt -> IO CInt ---------------------------------------------------------------------- constant' v n = unsafePerformIO $ do w <- createVector n unsafeWith w $ \p -> do let go (-1) = return () go !k = pokeElemOff p k v >> go (k-1) go (n-1) return w -- C versions constantAux fun x n = unsafePerformIO $ do v <- createVector n px <- newArray [x] app1 (fun px) vec v "constantAux" free px return v constantF :: Float -> Int -> Vector Float constantF = constantAux cconstantF foreign import ccall unsafe "constantF" cconstantF :: Ptr Float -> TF constantR :: Double -> Int -> Vector Double constantR = constantAux cconstantR foreign import ccall unsafe "constantR" cconstantR :: Ptr Double -> TV constantQ :: Complex Float -> Int -> Vector (Complex Float) constantQ = constantAux cconstantQ foreign import ccall unsafe "constantQ" cconstantQ :: Ptr (Complex Float) -> TQV constantC :: Complex Double -> Int -> Vector (Complex Double) constantC = constantAux cconstantC foreign import ccall unsafe "constantC" cconstantC :: Ptr (Complex Double) -> TCV constantP :: Storable a => a -> Int -> Vector a constantP a n = unsafePerformIO $ do let sz = sizeOf a v <- createVector n unsafeWith v $ \p -> do alloca $ \k -> do poke k a cconstantP (castPtr k) (fi n) (castPtr p) (fi sz) // check "constantP" return v foreign import ccall unsafe "constantP" cconstantP :: Ptr () -> CInt -> Ptr () -> CInt -> IO CInt ---------------------------------------------------------------------- -- | Extracts a submatrix from a matrix. subMatrix :: Element a => (Int,Int) -- ^ (r0,c0) starting position -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix -> Matrix a -- ^ input matrix -> Matrix a -- ^ result subMatrix (r0,c0) (rt,ct) m | 0 <= r0 && 0 < rt && r0+rt <= (rows m) && 0 <= c0 && 0 < ct && c0+ct <= (cols m) = subMatrixD (r0,c0) (rt,ct) m | otherwise = error $ "wrong subMatrix "++ show ((r0,c0),(rt,ct))++" of "++show(rows m)++"x"++ show (cols m) subMatrix'' (r0,c0) (rt,ct) c v = unsafePerformIO $ do w <- createVector (rt*ct) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) _ = return () go !i (-1) = go (i-1) (ct-1) go !i !j = do x <- peekElemOff p ((i+r0)*c+j+c0) pokeElemOff q (i*ct+j) x go i (j-1) go (rt-1) (ct-1) return w subMatrix' (r0,c0) (rt,ct) (Matrix { icols = c, xdat = v, order = RowMajor}) = Matrix rt ct (subMatrix'' (r0,c0) (rt,ct) c v) RowMajor subMatrix' (r0,c0) (rt,ct) m = trans $ subMatrix' (c0,r0) (ct,rt) (trans m) -------------------------------------------------------------------------- -- | Saves a matrix as 2D ASCII table. saveMatrix :: FilePath -> String -- ^ format (%f, %g, %e) -> Matrix Double -> IO () saveMatrix filename fmt m = do charname <- newCString filename charfmt <- newCString fmt let o = if orderOf m == RowMajor then 1 else 0 app1 (matrix_fprintf charname charfmt o) mat m "matrix_fprintf" free charname free charfmt foreign import ccall unsafe "matrix_fprintf" matrix_fprintf :: Ptr CChar -> Ptr CChar -> CInt -> TM ---------------------------------------------------------------------- conformMs ms = map (conformMTo (r,c)) ms where r = maximum (map rows ms) c = maximum (map cols ms) conformVs vs = map (conformVTo n) vs where n = maximum (map dim vs) conformMTo (r,c) m | size m == (r,c) = m | size m == (1,1) = reshape c (constantD (m@@>(0,0)) (r*c)) | size m == (r,1) = repCols c m | size m == (1,c) = repRows r m | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to (" ++ show r ++ "><"++ show c ++")" conformVTo n v | dim v == n = v | dim v == 1 = constantD (v@>0) n | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n repRows n x = fromRows (replicate n (flatten x)) repCols n x = fromColumns (replicate n (flatten x)) size m = (rows m, cols m) shSize m = "(" ++ show (rows m) ++"><"++ show (cols m)++")" ---------------------------------------------------------------------- instance (Storable t, NFData t) => NFData (Matrix t) where rnf m | d > 0 = rnf (v @> 0) | otherwise = () where d = dim v v = xdat m hmatrix-0.15.0.0/lib/Data/Packed/Internal/Common.hs0000644000000000000000000001622212165764700017756 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Common -- Copyright : (c) Alberto Ruiz 2007 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable (uses FFI) -- -- Development utilities. -- ----------------------------------------------------------------------------- -- #hide module Data.Packed.Internal.Common( Adapt, app1, app2, app3, app4, app5, app6, app7, app8, app9, app10, (//), check, mbCatch, splitEvery, common, compatdim, fi, table ) where import Foreign import Control.Monad(when) import Foreign.C.String(peekCString) import Foreign.C.Types import Foreign.Storable.Complex() import Data.List(transpose,intersperse) import Control.Exception as E -- | @splitEvery 3 [1..9] == [[1,2,3],[4,5,6],[7,8,9]]@ splitEvery :: Int -> [a] -> [[a]] splitEvery _ [] = [] splitEvery k l = take k l : splitEvery k (drop k l) -- | obtains the common value of a property of a list common :: (Eq a) => (b->a) -> [b] -> Maybe a common f = commonval . map f where commonval :: (Eq a) => [a] -> Maybe a commonval [] = Nothing commonval [a] = Just a commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing -- | common value with \"adaptable\" 1 compatdim :: [Int] -> Maybe Int compatdim [] = Nothing compatdim [a] = Just a compatdim (a:b:xs) = if a==b || a==1 || b==1 then compatdim (max a b:xs) else Nothing -- | Formatting tool table :: String -> [[String]] -> String table sep as = unlines . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse sep -- | postfix function application (@flip ($)@) (//) :: x -> (x -> y) -> y infixl 0 // (//) = flip ($) -- | specialized fromIntegral fi :: Int -> CInt fi = fromIntegral -- hmm.. ww2 w1 o1 w2 o2 f = w1 o1 $ w2 o2 . f ww3 w1 o1 w2 o2 w3 o3 f = w1 o1 $ ww2 w2 o2 w3 o3 . f ww4 w1 o1 w2 o2 w3 o3 w4 o4 f = w1 o1 $ ww3 w2 o2 w3 o3 w4 o4 . f ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 f = w1 o1 $ ww4 w2 o2 w3 o3 w4 o4 w5 o5 . f ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 f = w1 o1 $ ww5 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 . f ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 f = w1 o1 $ ww6 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 . f ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 f = w1 o1 $ ww7 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 . f ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 f = w1 o1 $ ww8 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 . f ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 f = w1 o1 $ ww9 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 . f type Adapt f t r = t -> ((f -> r) -> IO()) -> IO() type Adapt1 f t1 = Adapt f t1 (IO CInt) -> t1 -> String -> IO() type Adapt2 f t1 r1 t2 = Adapt f t1 r1 -> t1 -> Adapt1 r1 t2 type Adapt3 f t1 r1 t2 r2 t3 = Adapt f t1 r1 -> t1 -> Adapt2 r1 t2 r2 t3 type Adapt4 f t1 r1 t2 r2 t3 r3 t4 = Adapt f t1 r1 -> t1 -> Adapt3 r1 t2 r2 t3 r3 t4 type Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 = Adapt f t1 r1 -> t1 -> Adapt4 r1 t2 r2 t3 r3 t4 r4 t5 type Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 = Adapt f t1 r1 -> t1 -> Adapt5 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 type Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 = Adapt f t1 r1 -> t1 -> Adapt6 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 type Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 = Adapt f t1 r1 -> t1 -> Adapt7 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 type Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 = Adapt f t1 r1 -> t1 -> Adapt8 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 type Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 = Adapt f t1 r1 -> t1 -> Adapt9 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 app1 :: f -> Adapt1 f t1 app2 :: f -> Adapt2 f t1 r1 t2 app3 :: f -> Adapt3 f t1 r1 t2 r2 t3 app4 :: f -> Adapt4 f t1 r1 t2 r2 t3 r3 t4 app5 :: f -> Adapt5 f t1 r1 t2 r2 t3 r3 t4 r4 t5 app6 :: f -> Adapt6 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 app7 :: f -> Adapt7 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 app8 :: f -> Adapt8 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 app9 :: f -> Adapt9 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 app10 :: f -> Adapt10 f t1 r1 t2 r2 t3 r3 t4 r4 t5 r5 t6 r6 t7 r7 t8 r8 t9 r9 t10 app1 f w1 o1 s = w1 o1 $ \a1 -> f // a1 // check s app2 f w1 o1 w2 o2 s = ww2 w1 o1 w2 o2 $ \a1 a2 -> f // a1 // a2 // check s app3 f w1 o1 w2 o2 w3 o3 s = ww3 w1 o1 w2 o2 w3 o3 $ \a1 a2 a3 -> f // a1 // a2 // a3 // check s app4 f w1 o1 w2 o2 w3 o3 w4 o4 s = ww4 w1 o1 w2 o2 w3 o3 w4 o4 $ \a1 a2 a3 a4 -> f // a1 // a2 // a3 // a4 // check s app5 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 s = ww5 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 $ \a1 a2 a3 a4 a5 -> f // a1 // a2 // a3 // a4 // a5 // check s app6 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 s = ww6 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 $ \a1 a2 a3 a4 a5 a6 -> f // a1 // a2 // a3 // a4 // a5 // a6 // check s app7 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 s = ww7 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 $ \a1 a2 a3 a4 a5 a6 a7 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // check s app8 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 s = ww8 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 $ \a1 a2 a3 a4 a5 a6 a7 a8 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // check s app9 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 s = ww9 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 $ \a1 a2 a3 a4 a5 a6 a7 a8 a9 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // check s app10 f w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 s = ww10 w1 o1 w2 o2 w3 o3 w4 o4 w5 o5 w6 o6 w7 o7 w8 o8 w9 o9 w10 o10 $ \a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 -> f // a1 // a2 // a3 // a4 // a5 // a6 // a7 // a8 // a9 // a10 // check s -- GSL error codes are <= 1024 -- | error codes for the auxiliary functions required by the wrappers errorCode :: CInt -> String errorCode 2000 = "bad size" errorCode 2001 = "bad function code" errorCode 2002 = "memory problem" errorCode 2003 = "bad file" errorCode 2004 = "singular" errorCode 2005 = "didn't converge" errorCode 2006 = "the input matrix is not positive definite" errorCode 2007 = "not yet supported in this OS" errorCode n = "code "++show n -- | clear the fpu foreign import ccall unsafe "asm_finit" finit :: IO () -- | check the error code check :: String -> IO CInt -> IO () check msg f = do #if FINIT finit #endif err <- f when (err/=0) $ if err > 1024 then (error (msg++": "++errorCode err)) -- our errors else do -- GSL errors ps <- gsl_strerror err s <- peekCString ps error (msg++": "++s) return () -- | description of GSL error codes foreign import ccall unsafe "gsl_strerror" gsl_strerror :: CInt -> IO (Ptr CChar) -- | 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 hmatrix-0.15.0.0/lib/Data/Packed/Internal/Signatures.hs0000644000000000000000000000622112165764700020650 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Signatures -- Copyright : (c) Alberto Ruiz 2009 -- License : GPL-style -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- Portability : portable (uses FFI) -- -- Signatures of the C functions. -- ----------------------------------------------------------------------------- module Data.Packed.Internal.Signatures where import Foreign.Ptr(Ptr) import Data.Complex(Complex) import Foreign.C.Types(CInt) type PF = Ptr Float -- type PD = Ptr Double -- type PQ = Ptr (Complex Float) -- type PC = Ptr (Complex Double) -- type TF = CInt -> PF -> IO CInt -- type TFF = CInt -> PF -> TF -- type TFV = CInt -> PF -> TV -- type TVF = CInt -> PD -> TF -- type TFFF = CInt -> PF -> TFF -- type TV = CInt -> PD -> IO CInt -- type TVV = CInt -> PD -> TV -- type TVVV = CInt -> PD -> TVV -- type TFM = CInt -> CInt -> PF -> IO CInt -- type TFMFM = CInt -> CInt -> PF -> TFM -- type TFMFMFM = CInt -> CInt -> PF -> TFMFM -- type TM = CInt -> CInt -> PD -> IO CInt -- type TMM = CInt -> CInt -> PD -> TM -- type TVMM = CInt -> PD -> TMM -- type TMVMM = CInt -> CInt -> PD -> TVMM -- type TMMM = CInt -> CInt -> PD -> TMM -- type TVM = CInt -> PD -> TM -- type TVVM = CInt -> PD -> TVM -- type TMV = CInt -> CInt -> PD -> TV -- type TMMV = CInt -> CInt -> PD -> TMV -- type TMVM = CInt -> CInt -> PD -> TVM -- type TMMVM = CInt -> CInt -> PD -> TMVM -- type TCM = CInt -> CInt -> PC -> IO CInt -- type TCVCM = CInt -> PC -> TCM -- type TCMCVCM = CInt -> CInt -> PC -> TCVCM -- type TMCMCVCM = CInt -> CInt -> PD -> TCMCVCM -- type TCMCMCVCM = CInt -> CInt -> PC -> TCMCVCM -- type TCMCM = CInt -> CInt -> PC -> TCM -- type TVCM = CInt -> PD -> TCM -- type TCMVCM = CInt -> CInt -> PC -> TVCM -- type TCMCMVCM = CInt -> CInt -> PC -> TCMVCM -- type TCMCMCM = CInt -> CInt -> PC -> TCMCM -- type TCV = CInt -> PC -> IO CInt -- type TCVCV = CInt -> PC -> TCV -- type TCVCVCV = CInt -> PC -> TCVCV -- type TCVV = CInt -> PC -> TV -- type TQV = CInt -> PQ -> IO CInt -- type TQVQV = CInt -> PQ -> TQV -- type TQVQVQV = CInt -> PQ -> TQVQV -- type TQVF = CInt -> PQ -> TF -- type TQM = CInt -> CInt -> PQ -> IO CInt -- type TQMQM = CInt -> CInt -> PQ -> TQM -- type TQMQMQM = CInt -> CInt -> PQ -> TQMQM -- type TCMCV = CInt -> CInt -> PC -> TCV -- type TVCV = CInt -> PD -> TCV -- type TCVM = CInt -> PC -> TM -- type TMCVM = CInt -> CInt -> PD -> TCVM -- type TMMCVM = CInt -> CInt -> PD -> TMCVM --