hmatrix-0.19.0.0/src/0000755000000000000000000000000013223170642012370 5ustar0000000000000000hmatrix-0.19.0.0/src/Internal/0000755000000000000000000000000013267060772014156 5ustar0000000000000000hmatrix-0.19.0.0/src/Internal/C/0000755000000000000000000000000013223170642014326 5ustar0000000000000000hmatrix-0.19.0.0/src/Numeric/0000755000000000000000000000000013260621005013765 5ustar0000000000000000hmatrix-0.19.0.0/src/Numeric/LinearAlgebra/0000755000000000000000000000000013260621005016455 5ustar0000000000000000hmatrix-0.19.0.0/src/Numeric/LinearAlgebra.hs0000644000000000000000000001412113260621005017010 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra Copyright : (c) Alberto Ruiz 2006-15 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- module Numeric.LinearAlgebra ( -- * Basic types and data manipulation -- | This package works with 2D ('Matrix') and 1D ('Vector') -- arrays of real ('R') or complex ('C') double precision numbers. -- Single precision and machine integers are also supported for -- basic arithmetic and data manipulation. module Numeric.LinearAlgebra.Data, -- * Numeric classes -- | -- The standard numeric classes are defined elementwise (commonly referred to -- as the Hadamard product or the Schur product): -- -- >>> vector [1,2,3] * vector [3,0,-2] -- fromList [3.0,0.0,-6.0] -- -- >>> matrix 3 [1..9] * ident 3 -- (3><3) -- [ 1.0, 0.0, 0.0 -- , 0.0, 5.0, 0.0 -- , 0.0, 0.0, 9.0 ] -- * Autoconformable dimensions -- | -- In most operations, single-element vectors and matrices -- (created from numeric literals or using 'scalar'), and matrices -- with just one row or column, automatically -- expand to match the dimensions of the other operand: -- -- >>> 5 + 2*ident 3 :: Matrix Double -- (3><3) -- [ 7.0, 5.0, 5.0 -- , 5.0, 7.0, 5.0 -- , 5.0, 5.0, 7.0 ] -- -- >>> (4><3) [1..] + row [10,20,30] -- (4><3) -- [ 11.0, 22.0, 33.0 -- , 14.0, 25.0, 36.0 -- , 17.0, 28.0, 39.0 -- , 20.0, 31.0, 42.0 ] -- -- * Products -- ** Dot dot, (<.>), -- ** Matrix-vector (#>), (<#), (!#>), -- ** Matrix-matrix (<>), -- | The matrix product is also implemented in the "Data.Monoid" instance, where -- single-element matrices (created from numeric literals or using 'scalar') -- are used for scaling. -- -- >>> import Data.Monoid as M -- >>> let m = matrix 3 [1..6] -- >>> m M.<> 2 M.<> diagl[0.5,1,0] -- (2><3) -- [ 1.0, 4.0, 0.0 -- , 4.0, 10.0, 0.0 ] -- -- 'mconcat' uses 'optimiseMult' to get the optimal association order. -- ** Other outer, kronecker, cross, scale, add, sumElements, prodElements, -- * Linear systems -- ** General (<\>), linearSolveLS, linearSolveSVD, -- ** Determined linearSolve, luSolve, luPacked, luSolve', luPacked', -- ** Symmetric indefinite ldlSolve, ldlPacked, -- ** Positive definite cholSolve, -- ** Triangular UpLo(..), triSolve, -- ** Tridiagonal triDiagSolve, -- ** Sparse cgSolve, cgSolve', -- * Inverse and pseudoinverse inv, pinv, pinvTol, -- * Determinant and rank rcond, rank, det, invlndet, -- * Norms Normed(..), norm_Frob, norm_nuclear, -- * Nullspace and range orth, nullspace, null1, null1sym, -- * Singular value decomposition svd, thinSVD, compactSVD, compactSVDTol, singularValues, leftSV, rightSV, -- * Eigendecomposition eig, eigSH, eigenvalues, eigenvaluesSH, geigSH, -- * QR qr, thinQR, rq, thinRQ, qrRaw, qrgr, -- * Cholesky chol, mbChol, -- * LU lu, luFact, -- * Hessenberg hess, -- * Schur schur, -- * Matrix functions expm, sqrtm, matFunc, -- * Correlation and convolution corr, conv, corrMin, corr2, conv2, -- * Random arrays Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample, -- * Misc meanCov, rowOuters, pairwiseD2, normalize, peps, relativeError, magnit, haussholder, optimiseMult, udot, nullspaceSVD, orthSVD, ranksv, iC, sym, mTm, trustSym, unSym, -- * Auxiliary classes Element, Container, Product, Numeric, LSDiv, Herm, Complexable, RealElement, RealOf, ComplexOf, SingleOf, DoubleOf, IndexOf, Field, Linear(), Additive(), Transposable, LU(..), LDL(..), QR(..), CGState(..), Testable(..) ) where import Numeric.LinearAlgebra.Data import Numeric.Matrix() import Numeric.Vector() import Internal.Matrix import Internal.Container hiding ((<>)) import Internal.Numeric hiding (mul) import Internal.Algorithms hiding (linearSolve,Normed,orth,luPacked',linearSolve',luSolve',ldlPacked') import qualified Internal.Algorithms as A import Internal.Util import Internal.Random import Internal.Sparse((!#>)) import Internal.CG import Internal.Conversion #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif {- | dense matrix product >>> let a = (3><5) [1..] >>> a (3><5) [ 1.0, 2.0, 3.0, 4.0, 5.0 , 6.0, 7.0, 8.0, 9.0, 10.0 , 11.0, 12.0, 13.0, 14.0, 15.0 ] >>> let b = (5><2) [1,3, 0,2, -1,5, 7,7, 6,0] >>> b (5><2) [ 1.0, 3.0 , 0.0, 2.0 , -1.0, 5.0 , 7.0, 7.0 , 6.0, 0.0 ] >>> a <> b (3><2) [ 56.0, 50.0 , 121.0, 135.0 , 186.0, 220.0 ] -} (<>) :: Numeric t => Matrix t -> Matrix t -> Matrix t (<>) = mXm infixr 8 <> {- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. @ a = (2><2) [ 1.0, 2.0 , 3.0, 5.0 ] @ @ b = (2><3) [ 6.0, 1.0, 10.0 , 15.0, 3.0, 26.0 ] @ >>> linearSolve a b Just (2><3) [ -1.4802973661668753e-15, 0.9999999999999997, 1.999999999999997 , 3.000000000000001, 1.6653345369377348e-16, 4.000000000000002 ] >>> let Just x = it >>> disp 5 x 2x3 -0.00000 1.00000 2.00000 3.00000 0.00000 4.00000 >>> a <> x (2><3) [ 6.0, 1.0, 10.0 , 15.0, 3.0, 26.0 ] -} linearSolve m b = A.mbLinearSolve m b -- | return an orthonormal basis of the null space of a matrix. See also 'nullspaceSVD'. nullspace m = nullspaceSVD (Left (1*eps)) m (rightSV m) -- | return an orthonormal basis of the range space of a matrix. See also 'orthSVD'. orth m = orthSVD (Left (1*eps)) m (leftSV m) hmatrix-0.19.0.0/src/Numeric/LinearAlgebra/Devel.hs0000644000000000000000000000412413223170642020056 0ustar0000000000000000-------------------------------------------------------------------------------- {- | Module : Numeric.HMatrix.Devel Copyright : (c) Alberto Ruiz 2014 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional The library can be easily extended using the tools in this module. -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Devel( -- * FFI tools -- | See @examples/devel@ in the repository. createVector, createMatrix, TransArray(..), MatrixOrder(..), orderOf, cmat, fmat, matrixFromVector, unsafeFromForeignPtr, unsafeToForeignPtr, check, (//), (#|), at', atM', fi, ti, -- * ST -- | In-place manipulation inside the ST monad. -- See @examples/inplace.hs@ in the repository. -- ** Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- ** Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix, mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..), -- ** Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector, unsafeThawVector, unsafeFreezeVector, newUndefinedMatrix, unsafeReadMatrix, unsafeWriteMatrix, unsafeThawMatrix, unsafeFreezeMatrix, -- * Special maps and zips mapVectorWithIndex, zipVector, zipVectorWith, unzipVector, unzipVectorWith, mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_, foldLoop, foldVector, foldVectorG, foldVectorWithIndex, mapMatrixWithIndex, mapMatrixWithIndexM, mapMatrixWithIndexM_, liftMatrix, liftMatrix2, liftMatrix2Auto, -- * Sparse representation CSR(..), fromCSR, mkCSR, GMatrix(..), -- * Misc toByteString, fromByteString, showInternal, reorderVector ) where import Internal.Devel import Internal.ST import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Sparse hmatrix-0.19.0.0/src/Numeric/LinearAlgebra/Data.hs0000644000000000000000000000513213223170642017670 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} -------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.Data Copyright : (c) Alberto Ruiz 2015 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional This module provides functions for creation and manipulation of vectors and matrices, IO, and other utilities. -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.Data( -- * Elements R,C,I,Z,type(./.), -- * Vector {- | 1D arrays are storable vectors directly reexported from the vector package. -} fromList, toList, (|>), vector, range, idxs, -- * Matrix {- | The main data type of hmatrix is a 2D dense array defined on top of a storable vector. The internal representation is suitable for direct interface with standard numeric libraries. -} (><), matrix, tr, tr', -- * Dimensions size, rows, cols, -- * Conversion from\/to lists fromLists, toLists, row, col, -- * Conversions vector\/matrix flatten, reshape, asRow, asColumn, fromRows, toRows, fromColumns, toColumns, -- * Indexing atIndex, Indexable(..), -- * Construction scalar, Konst(..), Build(..), assoc, accum, linspace, -- ones, zeros, -- * Diagonal ident, diag, diagl, diagRect, takeDiag, -- * Vector extraction subVector, takesV, vjoin, -- * Matrix extraction Extractor(..), (??), (?), (¿), fliprl, flipud, subMatrix, takeRows, dropRows, takeColumns, dropColumns, remap, -- * Block matrix fromBlocks, (|||), (===), diagBlock, repmat, toBlocks, toBlocksEvery, -- * Mapping functions conj, cmap, cmod, step, cond, -- * Find elements find, maxIndex, minIndex, maxElement, minElement, sortVector, sortIndex, -- * Sparse AssocMatrix, toDense, mkSparse, mkDiagR, mkDense, -- * IO disp, loadMatrix, loadMatrix', saveMatrix, latexFormat, dispf, disps, dispcf, format, dispDots, dispBlanks, dispShort, -- * Element conversion Convert(..), roundVector, fromInt,toInt,fromZ,toZ, -- * Misc arctan2, separable, fromArray2D, module Data.Complex, Mod, Vector, Matrix, GMatrix, nRows, nCols ) where import Internal.Vector import Internal.Vectorized import Internal.Matrix hiding (size) import Internal.Element import Internal.IO import Internal.Numeric import Internal.Container import Internal.Util hiding ((&)) import Data.Complex import Internal.Sparse import Internal.Modular hmatrix-0.19.0.0/src/Numeric/LinearAlgebra/HMatrix.hs0000644000000000000000000000174013260621005020367 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- {- | Module : Numeric.LinearAlgebra.HMatrix Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional compatibility with previous version, to be removed -} -------------------------------------------------------------------------------- module Numeric.LinearAlgebra.HMatrix ( module Numeric.LinearAlgebra, (¦),(——),ℝ,ℂ,(<·>),app,mul, cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH' ) where import Numeric.LinearAlgebra import Internal.Util import Internal.Algorithms(cholSH, mbCholSH, eigSH', eigenvaluesSH', geigSH') #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif infixr 8 <·> (<·>) :: Numeric t => Vector t -> Vector t -> t (<·>) = dot app :: Numeric t => Matrix t -> Vector t -> Vector t app m v = m #> v mul :: Numeric t => Matrix t -> Matrix t -> Matrix t mul a b = a <> b hmatrix-0.19.0.0/src/Numeric/LinearAlgebra/Static.hs0000644000000000000000000006024613260621005020250 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {- | Module : Numeric.LinearAlgebra.Static Copyright : (c) Alberto Ruiz 2014 License : BSD3 Stability : experimental Experimental interface with statically checked dimensions. See code examples at http://dis.um.es/~alberto/hmatrix/static.html. -} module Numeric.LinearAlgebra.Static( -- * Vector ℝ, R, vec2, vec3, vec4, (&), (#), split, headTail, vector, linspace, range, dim, -- * Matrix L, Sq, build, row, col, (|||),(===), splitRows, splitCols, unrow, uncol, tr, eye, diag, blockAt, matrix, -- * Complex ℂ, C, M, Her, her, 𝑖, -- * Products (<>),(#>),(<.>), -- * Linear Systems linSolve, (<\>), -- * Factorizations svd, withCompactSVD, svdTall, svdFlat, Eigen(..), withNullspace, withOrth, qr, chol, -- * Norms Normed(..), -- * Random arrays Seed, RandDist(..), randomVector, rand, randn, gaussianSample, uniformSample, -- * Misc mean, meanCov, Disp(..), Domain(..), withVector, withMatrix, exactLength, exactDims, toRows, toColumns, withRows, withColumns, Sized(..), Diag(..), Sym, sym, mTm, unSym, (<·>) ) where import GHC.TypeLits import Numeric.LinearAlgebra hiding ( (<>),(#>),(<.>),Konst(..),diag, disp,(===),(|||), row,col,vector,matrix,linspace,toRows,toColumns, (<\>),fromList,takeDiag,svd,eig,eigSH, eigenvalues,eigenvaluesSH,build, qr,size,dot,chol,range,R,C,sym,mTm,unSym, randomVector,rand,randn,gaussianSample,uniformSample,meanCov) import qualified Numeric.LinearAlgebra as LA import qualified Numeric.LinearAlgebra.Devel as LA import Data.Proxy(Proxy(..)) import Internal.Static import Control.Arrow((***)) import Text.Printf import Data.Type.Equality ((:~:)(Refl)) import qualified Data.Bifunctor as BF (first) #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif ud1 :: R n -> Vector ℝ ud1 (R (Dim v)) = v infixl 4 & (&) :: forall n . (KnownNat n, 1 <= n) => R n -> ℝ -> R (n+1) u & x = u # (konst x :: R 1) infixl 4 # (#) :: forall n m . (KnownNat n, KnownNat m) => R n -> R m -> R (n+m) (R u) # (R v) = R (vconcat u v) vec2 :: ℝ -> ℝ -> R 2 vec2 a b = R (gvec2 a b) vec3 :: ℝ -> ℝ -> ℝ -> R 3 vec3 a b c = R (gvec3 a b c) vec4 :: ℝ -> ℝ -> ℝ -> ℝ -> R 4 vec4 a b c d = R (gvec4 a b c d) vector :: KnownNat n => [ℝ] -> R n vector = fromList matrix :: (KnownNat m, KnownNat n) => [ℝ] -> L m n matrix = fromList linspace :: forall n . KnownNat n => (ℝ,ℝ) -> R n linspace (a,b) = v where v = mkR (LA.linspace (size v) (a,b)) range :: forall n . KnownNat n => R n range = v where v = mkR (LA.linspace d (1,fromIntegral d)) d = size v dim :: forall n . KnownNat n => R n dim = v where v = mkR (scalar (fromIntegral $ size v)) -------------------------------------------------------------------------------- ud2 :: L m n -> Matrix ℝ ud2 (L (Dim (Dim x))) = x -------------------------------------------------------------------------------- diag :: KnownNat n => R n -> Sq n diag = diagR 0 eye :: KnownNat n => Sq n eye = diag 1 -------------------------------------------------------------------------------- blockAt :: forall m n . (KnownNat m, KnownNat n) => ℝ -> Int -> Int -> Matrix Double -> L m n blockAt x r c a = res where z = scalar x z1 = LA.konst x (r,c) z2 = LA.konst x (max 0 (m'-(ra+r)), max 0 (n'-(ca+c))) ra = min (rows a) . max 0 $ m'-r ca = min (cols a) . max 0 $ n'-c sa = subMatrix (0,0) (ra, ca) a (m',n') = size res res = mkL $ fromBlocks [[z1,z,z],[z,sa,z],[z,z,z2]] -------------------------------------------------------------------------------- row :: R n -> L 1 n row = mkL . asRow . ud1 --col :: R n -> L n 1 col v = tr . row $ v unrow :: L 1 n -> R n unrow = mkR . head . LA.toRows . ud2 --uncol :: L n 1 -> R n uncol v = unrow . tr $ v infixl 2 === (===) :: (KnownNat r1, KnownNat r2, KnownNat c) => L r1 c -> L r2 c -> L (r1+r2) c a === b = mkL (extract a LA.=== extract b) infixl 3 ||| -- (|||) :: (KnownNat r, KnownNat c1, KnownNat c2) => L r c1 -> L r c2 -> L r (c1+c2) a ||| b = tr (tr a === tr b) type Sq n = L n n --type CSq n = CL n n type GL = forall n m . (KnownNat n, KnownNat m) => L m n type GSq = forall n . KnownNat n => Sq n isKonst :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ,(Int,Int)) isKonst s@(unwrap -> x) | singleM x = Just (x `atIndex` (0,0), (size s)) | otherwise = Nothing isKonstC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ,(Int,Int)) isKonstC s@(unwrap -> x) | singleM x = Just (x `atIndex` (0,0), (size s)) | otherwise = Nothing infixr 8 <> (<>) :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n (<>) = mulR infixr 8 #> (#>) :: (KnownNat m, KnownNat n) => L m n -> R n -> R m (#>) = appR infixr 8 <·> (<·>) :: KnownNat n => R n -> R n -> ℝ (<·>) = dotR infixr 8 <.> (<.>) :: KnownNat n => R n -> R n -> ℝ (<.>) = dotR -------------------------------------------------------------------------------- class Diag m d | m -> d where takeDiag :: m -> d instance KnownNat n => Diag (L n n) (R n) where takeDiag x = mkR (LA.takeDiag (extract x)) instance KnownNat n => Diag (M n n) (C n) where takeDiag x = mkC (LA.takeDiag (extract x)) -------------------------------------------------------------------------------- linSolve :: (KnownNat m, KnownNat n) => L m m -> L m n -> Maybe (L m n) linSolve (extract -> a) (extract -> b) = fmap mkL (LA.linearSolve a b) (<\>) :: (KnownNat m, KnownNat n, KnownNat r) => L m n -> L m r -> L n r (extract -> a) <\> (extract -> b) = mkL (a LA.<\> b) svd :: (KnownNat m, KnownNat n) => L m n -> (L m m, R n, L n n) svd (extract -> m) = (mkL u, mkR s', mkL v) where (u,s,v) = LA.svd m s' = vjoin [s, z] z = LA.konst 0 (max 0 (cols m - LA.size s)) svdTall :: (KnownNat m, KnownNat n, n <= m) => L m n -> (L m n, R n, L n n) svdTall (extract -> m) = (mkL u, mkR s, mkL v) where (u,s,v) = LA.thinSVD m svdFlat :: (KnownNat m, KnownNat n, m <= n) => L m n -> (L m m, R m, L n m) svdFlat (extract -> m) = (mkL u, mkR s, mkL v) where (u,s,v) = LA.thinSVD m -------------------------------------------------------------------------------- class Eigen m l v | m -> l, m -> v where eigensystem :: m -> (l,v) eigenvalues :: m -> l newtype Sym n = Sym (Sq n) deriving Show sym :: KnownNat n => Sq n -> Sym n sym m = Sym $ (m + tr m)/2 mTm :: (KnownNat m, KnownNat n) => L m n -> Sym n mTm x = Sym (tr x <> x) unSym :: Sym n -> Sq n unSym (Sym x) = x 𝑖 :: Sized ℂ s c => s 𝑖 = konst iC newtype Her n = Her (M n n) her :: KnownNat n => M n n -> Her n her m = Her $ (m + LA.tr m)/2 instance (KnownNat n) => Disp (Sym n) where disp n (Sym x) = do let a = extract x let su = LA.dispf n a printf "Sym %d" (cols a) >> putStr (dropWhile (/='\n') $ su) instance (KnownNat n) => Disp (Her n) where disp n (Her x) = do let a = extract x let su = LA.dispcf n a printf "Her %d" (cols a) >> putStr (dropWhile (/='\n') $ su) instance KnownNat n => Eigen (Sym n) (R n) (L n n) where eigenvalues (Sym (extract -> m)) = mkR . LA.eigenvaluesSH . LA.trustSym $ m eigensystem (Sym (extract -> m)) = (mkR l, mkL v) where (l,v) = LA.eigSH . LA.trustSym $ m instance KnownNat n => Eigen (Sq n) (C n) (M n n) where eigenvalues (extract -> m) = mkC . LA.eigenvalues $ m eigensystem (extract -> m) = (mkC l, mkM v) where (l,v) = LA.eig m chol :: KnownNat n => Sym n -> Sq n chol (extract . unSym -> m) = mkL $ LA.chol $ LA.trustSym m -------------------------------------------------------------------------------- withNullspace :: forall m n z . (KnownNat m, KnownNat n) => L m n -> (forall k . (KnownNat k) => L n k -> z) -> z withNullspace (LA.nullspace . extract -> a) f = case someNatVal $ fromIntegral $ cols a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k) withOrth :: forall m n z . (KnownNat m, KnownNat n) => L m n -> (forall k. (KnownNat k) => L n k -> z) -> z withOrth (LA.orth . extract -> a) f = case someNatVal $ fromIntegral $ cols a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL a :: L n k) withCompactSVD :: forall m n z . (KnownNat m, KnownNat n) => L m n -> (forall k . (KnownNat k) => (L m k, R k, L n k) -> z) -> z withCompactSVD (LA.compactSVD . extract -> (u,s,v)) f = case someNatVal $ fromIntegral $ LA.size s of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy k)) -> f (mkL u :: L m k, mkR s :: R k, mkL v :: L n k) -------------------------------------------------------------------------------- qr :: (KnownNat m, KnownNat n) => L m n -> (L m m, L m n) qr (extract -> x) = (mkL q, mkL r) where (q,r) = LA.qr x -- use qrRaw? -------------------------------------------------------------------------------- split :: forall p n . (KnownNat p, KnownNat n, p<=n) => R n -> (R p, R (n-p)) split (extract -> v) = ( mkR (subVector 0 p' v) , mkR (subVector p' (LA.size v - p') v) ) where p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int headTail :: (KnownNat n, 1<=n) => R n -> (ℝ, R (n-1)) headTail = ((!0) . extract *** id) . split splitRows :: forall p m n . (KnownNat p, KnownNat m, KnownNat n, p<=m) => L m n -> (L p n, L (m-p) n) splitRows (extract -> x) = ( mkL (takeRows p' x) , mkL (dropRows p' x) ) where p' = fromIntegral . natVal $ (undefined :: Proxy p) :: Int splitCols :: forall p m n. (KnownNat p, KnownNat m, KnownNat n, KnownNat (n-p), p<=n) => L m n -> (L m p, L m (n-p)) splitCols = (tr *** tr) . splitRows . tr toRows :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R n] toRows (LA.toRows . extract -> vs) = map mkR vs withRows :: forall n z . KnownNat n => [R n] -> (forall m . KnownNat m => L m n -> z) -> z withRows (LA.fromRows . map extract -> m) f = case someNatVal $ fromIntegral $ LA.rows m of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> f (mkL m :: L m n) toColumns :: forall m n . (KnownNat m, KnownNat n) => L m n -> [R m] toColumns (LA.toColumns . extract -> vs) = map mkR vs withColumns :: forall m z . KnownNat m => [R m] -> (forall n . KnownNat n => L m n -> z) -> z withColumns (LA.fromColumns . map extract -> m) f = case someNatVal $ fromIntegral $ LA.cols m of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy n)) -> f (mkL m :: L m n) -------------------------------------------------------------------------------- build :: forall m n . (KnownNat n, KnownNat m) => (ℝ -> ℝ -> ℝ) -> L m n build f = r where r = mkL $ LA.build (size r) f -------------------------------------------------------------------------------- withVector :: forall z . Vector ℝ -> (forall n . (KnownNat n) => R n -> z) -> z withVector v f = case someNatVal $ fromIntegral $ LA.size v of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> f (mkR v :: R m) -- | Useful for constraining two dependently typed vectors to match each -- other in length when they are unknown at compile-time. exactLength :: forall n m . (KnownNat n, KnownNat m) => R m -> Maybe (R n) exactLength v = do Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy m) return $ mkR (unwrap v) withMatrix :: forall z . Matrix ℝ -> (forall m n . (KnownNat m, KnownNat n) => L m n -> z) -> z withMatrix a f = case someNatVal $ fromIntegral $ rows a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy m)) -> case someNatVal $ fromIntegral $ cols a of Nothing -> error "static/dynamic mismatch" Just (SomeNat (_ :: Proxy n)) -> f (mkL a :: L m n) -- | Useful for constraining two dependently typed matrices to match each -- other in dimensions when they are unknown at compile-time. exactDims :: forall n m j k . (KnownNat n, KnownNat m, KnownNat j, KnownNat k) => L m n -> Maybe (L j k) exactDims m = do Refl <- sameNat (Proxy :: Proxy m) (Proxy :: Proxy j) Refl <- sameNat (Proxy :: Proxy n) (Proxy :: Proxy k) return $ mkL (unwrap m) randomVector :: forall n . KnownNat n => Seed -> RandDist -> R n randomVector s d = mkR (LA.randomVector s d (fromInteger (natVal (Proxy :: Proxy n))) ) rand :: forall m n . (KnownNat m, KnownNat n) => IO (L m n) rand = mkL <$> LA.rand (fromInteger (natVal (Proxy :: Proxy m))) (fromInteger (natVal (Proxy :: Proxy n))) randn :: forall m n . (KnownNat m, KnownNat n) => IO (L m n) randn = mkL <$> LA.randn (fromInteger (natVal (Proxy :: Proxy m))) (fromInteger (natVal (Proxy :: Proxy n))) gaussianSample :: forall m n . (KnownNat m, KnownNat n) => Seed -> R n -> Sym n -> L m n gaussianSample s (extract -> mu) (Sym (extract -> sigma)) = mkL $ LA.gaussianSample s (fromInteger (natVal (Proxy :: Proxy m))) mu (LA.trustSym sigma) uniformSample :: forall m n . (KnownNat m, KnownNat n) => Seed -> R n -- ^ minimums of each row -> R n -- ^ maximums of each row -> L m n uniformSample s (extract -> mins) (extract -> maxs) = mkL $ LA.uniformSample s (fromInteger (natVal (Proxy :: Proxy m))) (zip (LA.toList mins) (LA.toList maxs)) meanCov :: forall m n . (KnownNat m, KnownNat n, 1 <= m) => L m n -> (R n, Sym n) meanCov (extract -> vs) = mkR *** (Sym . mkL . LA.unSym) $ LA.meanCov vs -------------------------------------------------------------------------------- class Domain field vec mat | mat -> vec field, vec -> mat field, field -> mat vec where mul :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => mat m k -> mat k n -> mat m n app :: forall m n . (KnownNat m, KnownNat n) => mat m n -> vec n -> vec m dot :: forall n . (KnownNat n) => vec n -> vec n -> field cross :: vec 3 -> vec 3 -> vec 3 diagR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => field -> vec k -> mat m n dvmap :: forall n. KnownNat n => (field -> field) -> vec n -> vec n dmmap :: forall n m. (KnownNat m, KnownNat n) => (field -> field) -> mat n m -> mat n m outer :: forall n m. (KnownNat m, KnownNat n) => vec n -> vec m -> mat n m zipWithVector :: forall n. KnownNat n => (field -> field -> field) -> vec n -> vec n -> vec n det :: forall n. KnownNat n => mat n n -> field invlndet :: forall n. KnownNat n => mat n n -> (mat n n, (field, field)) expm :: forall n. KnownNat n => mat n n -> mat n n sqrtm :: forall n. KnownNat n => mat n n -> mat n n inv :: forall n. KnownNat n => mat n n -> mat n n instance Domain ℝ R L where mul = mulR app = appR dot = dotR cross = crossR diagR = diagRectR dvmap = mapR dmmap = mapL outer = outerR zipWithVector = zipWithR det = detL invlndet = invlndetL expm = expmL sqrtm = sqrtmL inv = invL instance Domain ℂ C M where mul = mulC app = appC dot = dotC cross = crossC diagR = diagRectC dvmap = mapC dmmap = mapM' outer = outerC zipWithVector = zipWithC det = detM invlndet = invlndetM expm = expmM sqrtm = sqrtmM inv = invM -------------------------------------------------------------------------------- mulR :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => L m k -> L k n -> L m n mulR (isKonst -> Just (a,(_,k))) (isKonst -> Just (b,_)) = konst (a * b * fromIntegral k) mulR (isDiag -> Just (0,a,_)) (isDiag -> Just (0,b,_)) = diagR 0 (mkR v :: R k) where v = a' * b' n = min (LA.size a) (LA.size b) a' = subVector 0 n a b' = subVector 0 n b mulR (isDiag -> Just (0,a,_)) (extract -> b) = mkL (asColumn a * takeRows (LA.size a) b) mulR (extract -> a) (isDiag -> Just (0,b,_)) = mkL (takeColumns (LA.size b) a * asRow b) mulR a b = mkL (extract a LA.<> extract b) appR :: (KnownNat m, KnownNat n) => L m n -> R n -> R m appR (isDiag -> Just (0, w, _)) v = mkR (w * subVector 0 (LA.size w) (extract v)) appR m v = mkR (extract m LA.#> extract v) dotR :: KnownNat n => R n -> R n -> ℝ dotR (extract -> u) (extract -> v) = LA.dot u v crossR :: R 3 -> R 3 -> R 3 crossR (extract -> x) (extract -> y) = vec3 z1 z2 z3 where z1 = x!1*y!2-x!2*y!1 z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 outerR :: (KnownNat m, KnownNat n) => R n -> R m -> L n m outerR (extract -> x) (extract -> y) = mkL (LA.outer x y) mapR :: KnownNat n => (ℝ -> ℝ) -> R n -> R n mapR f (unwrap -> v) = mkR (LA.cmap f v) zipWithR :: KnownNat n => (ℝ -> ℝ -> ℝ) -> R n -> R n -> R n zipWithR f (extract -> x) (extract -> y) = mkR (LA.zipVectorWith f x y) mapL :: (KnownNat n, KnownNat m) => (ℝ -> ℝ) -> L n m -> L n m mapL f = overMatL' (LA.cmap f) detL :: KnownNat n => Sq n -> ℝ detL = LA.det . unwrap invlndetL :: KnownNat n => Sq n -> (L n n, (ℝ, ℝ)) invlndetL = BF.first mkL . LA.invlndet . unwrap expmL :: KnownNat n => Sq n -> Sq n expmL = overMatL' LA.expm sqrtmL :: KnownNat n => Sq n -> Sq n sqrtmL = overMatL' LA.sqrtm invL :: KnownNat n => Sq n -> Sq n invL = overMatL' LA.inv -------------------------------------------------------------------------------- mulC :: forall m k n. (KnownNat m, KnownNat k, KnownNat n) => M m k -> M k n -> M m n mulC (isKonstC -> Just (a,(_,k))) (isKonstC -> Just (b,_)) = konst (a * b * fromIntegral k) mulC (isDiagC -> Just (0,a,_)) (isDiagC -> Just (0,b,_)) = diagR 0 (mkC v :: C k) where v = a' * b' n = min (LA.size a) (LA.size b) a' = subVector 0 n a b' = subVector 0 n b mulC (isDiagC -> Just (0,a,_)) (extract -> b) = mkM (asColumn a * takeRows (LA.size a) b) mulC (extract -> a) (isDiagC -> Just (0,b,_)) = mkM (takeColumns (LA.size b) a * asRow b) mulC a b = mkM (extract a LA.<> extract b) appC :: (KnownNat m, KnownNat n) => M m n -> C n -> C m appC (isDiagC -> Just (0, w, _)) v = mkC (w * subVector 0 (LA.size w) (extract v)) appC m v = mkC (extract m LA.#> extract v) dotC :: KnownNat n => C n -> C n -> ℂ dotC (extract -> u) (extract -> v) = LA.dot u v crossC :: C 3 -> C 3 -> C 3 crossC (extract -> x) (extract -> y) = mkC (LA.fromList [z1, z2, z3]) where z1 = x!1*y!2-x!2*y!1 z2 = x!2*y!0-x!0*y!2 z3 = x!0*y!1-x!1*y!0 outerC :: (KnownNat m, KnownNat n) => C n -> C m -> M n m outerC (extract -> x) (extract -> y) = mkM (LA.outer x y) mapC :: KnownNat n => (ℂ -> ℂ) -> C n -> C n mapC f (unwrap -> v) = mkC (LA.cmap f v) zipWithC :: KnownNat n => (ℂ -> ℂ -> ℂ) -> C n -> C n -> C n zipWithC f (extract -> x) (extract -> y) = mkC (LA.zipVectorWith f x y) mapM' :: (KnownNat n, KnownNat m) => (ℂ -> ℂ) -> M n m -> M n m mapM' f = overMatM' (LA.cmap f) detM :: KnownNat n => M n n -> ℂ detM = LA.det . unwrap invlndetM :: KnownNat n => M n n -> (M n n, (ℂ, ℂ)) invlndetM = BF.first mkM . LA.invlndet . unwrap expmM :: KnownNat n => M n n -> M n n expmM = overMatM' LA.expm sqrtmM :: KnownNat n => M n n -> M n n sqrtmM = overMatM' LA.sqrtm invM :: KnownNat n => M n n -> M n n invM = overMatM' LA.inv -------------------------------------------------------------------------------- diagRectR :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℝ -> R k -> L m n diagRectR x v | m' == 1 = mkL (LA.diagRect x ev m' n') | m'*n' > 0 = r | otherwise = matrix [] where r = mkL (asRow (vjoin [scalar x, ev, zeros])) ev = extract v zeros = LA.konst x (max 0 ((min m' n') - LA.size ev)) (m',n') = size r diagRectC :: forall m n k . (KnownNat m, KnownNat n, KnownNat k) => ℂ -> C k -> M m n diagRectC x v | m' == 1 = mkM (LA.diagRect x ev m' n') | m'*n' > 0 = r | otherwise = fromList [] where r = mkM (asRow (vjoin [scalar x, ev, zeros])) ev = extract v zeros = LA.konst x (max 0 ((min m' n') - LA.size ev)) (m',n') = size r -------------------------------------------------------------------------------- mean :: (KnownNat n, 1<=n) => R n -> ℝ mean v = v <·> (1/dim) test :: (Bool, IO ()) test = (ok,info) where ok = extract (eye :: Sq 5) == ident 5 && (unwrap .unSym) (mTm sm :: Sym 3) == tr ((3><3)[1..]) LA.<> (3><3)[1..] && unwrap (tm :: L 3 5) == LA.matrix 5 [1..15] && thingS == thingD && precS == precD && withVector (LA.vector [1..15]) sumV == sumElements (LA.fromList [1..15]) info = do print $ u print $ v print (eye :: Sq 3) print $ ((u & 5) + 1) <·> v print (tm :: L 2 5) print (tm <> sm :: L 2 3) print thingS print thingD print precS print precD print $ withVector (LA.vector [1..15]) sumV splittest sumV w = w <·> konst 1 u = vec2 3 5 𝕧 x = vector [x] :: R 1 v = 𝕧 2 & 4 & 7 tm :: GL tm = lmat 0 [1..] lmat :: forall m n . (KnownNat m, KnownNat n) => ℝ -> [ℝ] -> L m n lmat z xs = r where r = mkL . reshape n' . LA.fromList . take (m'*n') $ xs ++ repeat z (m',n') = size r sm :: GSq sm = lmat 0 [1..] thingS = (u & 1) <·> tr q #> q #> v where q = tm :: L 10 3 thingD = vjoin [ud1 u, 1] LA.<.> tr m LA.#> m LA.#> ud1 v where m = LA.matrix 3 [1..30] precS = (1::Double) + (2::Double) * ((1 :: R 3) * (u & 6)) <·> konst 2 #> v precD = 1 + 2 * vjoin[ud1 u, 6] LA.<.> LA.konst 2 (LA.size (ud1 u) +1, LA.size (ud1 v)) LA.#> ud1 v splittest = do let v = range :: R 7 a = snd (split v) :: R 4 print $ a print $ snd . headTail . snd . headTail $ v print $ first (vec3 1 2 3) print $ second (vec3 1 2 3) print $ third (vec3 1 2 3) print $ (snd $ splitRows eye :: L 4 6) where first v = fst . headTail $ v second v = first . snd . headTail $ v third v = first . snd . headTail . snd . headTail $ v instance (KnownNat n', KnownNat m') => Testable (L n' m') where checkT _ = test -------------------------------------------------------------------------------- instance KnownNat n => Normed (R n) where norm_0 v = norm_0 (extract v) norm_1 v = norm_1 (extract v) norm_2 v = norm_2 (extract v) norm_Inf v = norm_Inf (extract v) instance (KnownNat m, KnownNat n) => Normed (L m n) where norm_0 m = norm_0 (extract m) norm_1 m = norm_1 (extract m) norm_2 m = norm_2 (extract m) norm_Inf m = norm_Inf (extract m) mkSym f = Sym . f . unSym mkSym2 f x y = Sym (f (unSym x) (unSym y)) instance KnownNat n => Num (Sym n) where (+) = mkSym2 (+) (*) = mkSym2 (*) (-) = mkSym2 (-) abs = mkSym abs signum = mkSym signum negate = mkSym negate fromInteger = Sym . fromInteger instance KnownNat n => Fractional (Sym n) where fromRational = Sym . fromRational (/) = mkSym2 (/) instance KnownNat n => Floating (Sym n) where sin = mkSym sin cos = mkSym cos tan = mkSym tan asin = mkSym asin acos = mkSym acos atan = mkSym atan sinh = mkSym sinh cosh = mkSym cosh tanh = mkSym tanh asinh = mkSym asinh acosh = mkSym acosh atanh = mkSym atanh exp = mkSym exp log = mkSym log sqrt = mkSym sqrt (**) = mkSym2 (**) pi = Sym pi instance KnownNat n => Additive (Sym n) where add = (+) instance KnownNat n => Transposable (Sym n) (Sym n) where tr = id tr' = id instance KnownNat n => Transposable (Her n) (Her n) where tr = id tr' (Her m) = Her (tr' m) hmatrix-0.19.0.0/src/Internal/Vector.hs0000644000000000000000000003643113260621005015744 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Internal.Vector -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- module Internal.Vector( I,Z,R,C, fi,ti, Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith, createVector, avec, inlinePerformIO, toList, dim, (@>), at', (|>), vjoin, subVector, takesV, idxs, buildVector, asReal, asComplex, toByteString,fromByteString, zipVector, unzipVector, zipVectorWith, unzipVectorWith, foldVector, foldVectorG, foldVectorWithIndex, foldLoop, mapVector, mapVectorM, mapVectorM_, mapVectorWithIndex, mapVectorWithIndexM, mapVectorWithIndexM_ ) where import Foreign.Marshal.Array import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable import Foreign.C.Types(CInt) import Data.Int(Int64) import Data.Complex import System.IO.Unsafe(unsafePerformIO) import GHC.ForeignPtr(mallocPlainForeignPtrBytes) import GHC.Base(realWorld#, IO(IO), when) import qualified Data.Vector.Storable as Vector import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) import Data.Binary import Data.Binary.Put import Control.Monad(replicateM) import qualified Data.ByteString.Internal as BS import Data.Vector.Storable.Internal(updPtr) type I = CInt type Z = Int64 type R = Double type C = Complex Double -- | specialized fromIntegral fi :: Int -> CInt fi = fromIntegral -- | specialized fromIntegral ti :: CInt -> Int ti = fromIntegral -- | Number of elements dim :: (Storable t) => Vector t -> Int dim = Vector.length {-# INLINE dim #-} -- C-Haskell vector adapter {-# INLINE avec #-} avec :: Storable a => Vector a -> (f -> IO r) -> ((CInt -> Ptr a -> f) -> IO r) avec v f g = unsafeWith v $ \ptr -> f (g (fromIntegral (Vector.length v)) ptr) -- allocates memory for a new vector createVector :: Storable a => Int -> IO (Vector a) createVector n = do when (n < 0) $ error ("trying to createVector of negative dim: "++show n) fp <- doMalloc undefined return $ unsafeFromForeignPtr fp 0 n where -- -- Use the much cheaper Haskell heap allocated storage -- for foreign pointer space we control -- doMalloc :: Storable b => b -> IO (ForeignPtr b) doMalloc dummy = do mallocPlainForeignPtrBytes (n * sizeOf dummy) {- | creates a Vector from a list: @> fromList [2,3,5,7] 4 |> [2.0,3.0,5.0,7.0]@ -} safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c safeRead v = inlinePerformIO . unsafeWith v {-# INLINE safeRead #-} inlinePerformIO :: IO a -> a inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r {-# INLINE inlinePerformIO #-} {- extracts the Vector elements to a list >>> toList (linspace 5 (1,10)) [1.0,3.25,5.5,7.75,10.0] -} toList :: Storable a => Vector a -> [a] toList v = safeRead v $ peekArray (dim v) {- | Create a vector from a list of elements and explicit dimension. The input list is truncated if it is too long, so it may safely be used, for instance, with infinite lists. >>> 5 |> [1..] fromList [1.0,2.0,3.0,4.0,5.0] -} (|>) :: (Storable a) => Int -> [a] -> Vector a infixl 9 |> n |> l | length l' == n = fromList l' | otherwise = error "list too short for |>" where l' = take n l -- | Create a vector of indexes, useful for matrix extraction using '(??)' idxs :: [Int] -> Vector I idxs js = fromList (map fromIntegral js) :: Vector I {- | takes a number of consecutive elements from a Vector >>> subVector 2 3 (fromList [1..10]) fromList [3.0,4.0,5.0] -} subVector :: Storable t => Int -- ^ index of the starting element -> Int -- ^ number of elements to extract -> Vector t -- ^ source -> Vector t -- ^ result subVector = Vector.slice {-# INLINE subVector #-} {- | Reads a vector position: >>> fromList [0..9] @> 7 7.0 -} (@>) :: Storable t => Vector t -> Int -> t infixl 9 @> v @> n | n >= 0 && n < dim v = at' v n | otherwise = error "vector index out of range" {-# INLINE (@>) #-} -- | access to Vector elements without range checking at' :: Storable a => Vector a -> Int -> a at' v n = safeRead v $ flip peekElemOff n {-# INLINE at' #-} {- | concatenate a list of vectors >>> vjoin [fromList [1..5::Double], konst 1 3] fromList [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0] -} vjoin :: Storable t => [Vector t] -> Vector t vjoin [] = fromList [] vjoin [v] = v vjoin as = unsafePerformIO $ do let tot = sum (map dim as) r <- createVector tot unsafeWith r $ \ptr -> joiner as tot ptr return r where joiner [] _ _ = return () joiner (v:cs) _ p = do let n = dim v unsafeWith v $ \pb -> copyArray p pb n joiner cs 0 (advancePtr p n) {- | Extract consecutive subvectors of the given sizes. >>> takesV [3,4] (linspace 10 (1,10::Double)) [fromList [1.0,2.0,3.0],fromList [4.0,5.0,6.0,7.0]] -} takesV :: Storable t => [Int] -> Vector t -> [Vector t] takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w) | otherwise = go ms w where go [] _ = [] go (n:ns) v = subVector 0 n v : go ns (subVector n (dim v - n) v) --------------------------------------------------------------- -- | transforms a complex vector into a real vector with alternating real and imaginary parts asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n) where (fp,i,n) = unsafeToForeignPtr v -- | transforms a real vector into a complex vector with alternating real and imaginary parts asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a) asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2) where (fp,i,n) = unsafeToForeignPtr v -------------------------------------------------------------------------------- -- | map on Vectors mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b mapVector f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f x) go (k-1) go (dim v -1) return w {-# INLINE mapVector #-} -- | zipWith for Vectors zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c zipVectorWith f u v = unsafePerformIO $ do let n = min (dim u) (dim v) w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do x <- peekElemOff pu k y <- peekElemOff pv k pokeElemOff pw k (f x y) go (k-1) go (n -1) return w {-# INLINE zipVectorWith #-} -- | unzipWith for Vectors unzipVectorWith :: (Storable (a,b), Storable c, Storable d) => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d) unzipVectorWith f u = unsafePerformIO $ do let n = dim u v <- createVector n w <- createVector n unsafeWith u $ \pu -> unsafeWith v $ \pv -> unsafeWith w $ \pw -> do let go (-1) = return () go !k = do z <- peekElemOff pu k let (x,y) = f z pokeElemOff pv k x pokeElemOff pw k y go (k-1) go (n-1) return (v,w) {-# INLINE unzipVectorWith #-} foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b foldVector f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f y s) go (dim v -1) x {-# INLINE foldVector #-} -- the zero-indexed index is passed to the folding function foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b foldVectorWithIndex f x v = unsafePerformIO $ unsafeWith v $ \p -> do let go (-1) s = return s go !k !s = do y <- peekElemOff p k go (k-1::Int) (f k y s) go (dim v -1) x {-# INLINE foldVectorWithIndex #-} foldLoop :: (Int -> t -> t) -> t -> Int -> t foldLoop f s0 d = go (d - 1) s0 where go 0 s = f (0::Int) s go !j !s = go (j - 1) (f j s) foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t foldVectorG f s0 v = foldLoop g s0 (dim v) where g !k !s = f k (safeRead v . flip peekElemOff) s {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) {-# INLINE foldVectorG #-} ------------------------------------------------------------------- -- | monadic map over Vectors -- the monad @m@ must be strict mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b) mapVectorM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorM #-} -- | monadic map over Vectors mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m () mapVectorM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f x mapVectorM' (k+1) t {-# INLINE mapVectorM_ #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function -- the monad @m@ must be strict mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b) mapVectorWithIndexM f v = do w <- return $! unsafePerformIO $! createVector (dim v) mapVectorM' w 0 (dim v -1) return w where mapVectorM' w' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k y <- f k x _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y mapVectorM' w' (k+1) t {-# INLINE mapVectorWithIndexM #-} -- | monadic map over Vectors with the zero-indexed index passed to the mapping function mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m () mapVectorWithIndexM_ f v = do mapVectorM' 0 (dim v -1) where mapVectorM' !k !t | k == t = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k f k x | otherwise = do x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k _ <- f k x mapVectorM' (k+1) t {-# INLINE mapVectorWithIndexM_ #-} mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b --mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b]) mapVectorWithIndex f v = unsafePerformIO $ do w <- createVector (dim v) unsafeWith v $ \p -> unsafeWith w $ \q -> do let go (-1) = return () go !k = do x <- peekElemOff p k pokeElemOff q k (f k x) go (k-1) go (dim v -1) return w {-# INLINE mapVectorWithIndex #-} -------------------------------------------------------------------------------- -- a 64K cache, with a Double taking 13 bytes in Bytestring, -- implies a chunk size of 5041 chunk :: Int chunk = 5000 chunks :: Int -> [Int] chunks d = let c = d `div` chunk m = d `mod` chunk in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM () putVector v = mapM_ put $! toList v getVector :: (Storable a, Binary a) => Int -> Get (Vector a) getVector d = do xs <- replicateM d get return $! fromList xs -------------------------------------------------------------------------------- toByteString :: Storable t => Vector t -> BS.ByteString toByteString v = BS.PS (castForeignPtr fp) (sz*o) (sz * dim v) where (fp,o,_n) = unsafeToForeignPtr v sz = sizeOf (v@>0) fromByteString :: Storable t => BS.ByteString -> Vector t fromByteString (BS.PS fp o n) = r where r = unsafeFromForeignPtr (castForeignPtr (updPtr (`plusPtr` o) fp)) 0 n' n' = n `div` sz sz = sizeOf (r@>0) -------------------------------------------------------------------------------- instance (Binary a, Storable a) => Binary (Vector a) where put v = do let d = dim v put d mapM_ putVector $! takesV (chunks d) v -- put = put . v2bs get = do d <- get vs <- mapM getVector $ chunks d return $! vjoin vs -- get = fmap bs2v get ------------------------------------------------------------------- {- | creates a Vector of the specified length using the supplied function to to map the index to the value at that index. @> buildVector 4 fromIntegral 4 |> [0.0,1.0,2.0,3.0]@ -} buildVector :: Storable a => Int -> (Int -> a) -> Vector a buildVector len f = fromList $ map f [0 .. (len - 1)] -- | zip for Vectors zipVector :: (Storable a, Storable b, Storable (a,b)) => Vector a -> Vector b -> Vector (a,b) zipVector = zipVectorWith (,) -- | unzip for Vectors unzipVector :: (Storable a, Storable b, Storable (a,b)) => Vector (a,b) -> (Vector a,Vector b) unzipVector = unzipVectorWith id ------------------------------------------------------------------- hmatrix-0.19.0.0/src/Internal/Devel.hs0000644000000000000000000000460213260621005015534 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Internal.Devel -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- module Internal.Devel where import Control.Monad ( when ) import Foreign.C.Types ( CInt ) --import Foreign.Storable.Complex () import Foreign.Ptr(Ptr) import Control.Exception as E ( SomeException, catch ) import Internal.Vector(Vector,avec) import Foreign.Storable(Storable) -- | postfix function application (@flip ($)@) (//) :: x -> (x -> y) -> y infixl 0 // (//) = flip ($) -- GSL error codes are <= 1024 -- | error codes for the auxiliary functions required by the wrappers errorCode :: CInt -> String errorCode 2000 = "bad size" errorCode 2001 = "bad function code" errorCode 2002 = "memory problem" errorCode 2003 = "bad file" errorCode 2004 = "singular" errorCode 2005 = "didn't converge" errorCode 2006 = "the input matrix is not positive definite" errorCode 2007 = "not yet supported in this OS" errorCode n = "code "++show n -- | clear the fpu foreign import ccall unsafe "asm_finit" finit :: IO () -- | check the error code check :: String -> IO CInt -> IO () check msg f = do -- finit err <- f when (err/=0) $ error (msg++": "++errorCode err) return () -- | postfix error code check infixl 0 #| (#|) :: IO CInt -> String -> IO () (#|) = flip check -- | Error capture and conversion to Maybe mbCatch :: IO x -> IO (Maybe x) mbCatch act = E.catch (Just `fmap` act) f where f :: SomeException -> IO (Maybe x) f _ = return Nothing -------------------------------------------------------------------------------- type CM b r = CInt -> CInt -> Ptr b -> r type CV b r = CInt -> Ptr b -> r type OM b r = CInt -> CInt -> CInt -> CInt -> Ptr b -> r type CIdxs r = CV CInt r type Ok = IO CInt infixr 5 :>, ::>, ..> type (:>) t r = CV t r type (::>) t r = OM t r type (..>) t r = CM t r class TransArray c where type Trans c b type TransRaw c b apply :: c -> (b -> IO r) -> (Trans c b) -> IO r applyRaw :: c -> (b -> IO r) -> (TransRaw c b) -> IO r infixl 1 `apply`, `applyRaw` instance Storable t => TransArray (Vector t) where type Trans (Vector t) b = CInt -> Ptr t -> b type TransRaw (Vector t) b = CInt -> Ptr t -> b apply = avec {-# INLINE apply #-} applyRaw = avec {-# INLINE applyRaw #-} hmatrix-0.19.0.0/src/Internal/Vectorized.hs0000644000000000000000000004417713260621005016626 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vectorized -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Low level interface to vector operations. -- ----------------------------------------------------------------------------- module Internal.Vectorized where import Internal.Vector import Internal.Devel import Data.Complex import Foreign.Marshal.Alloc(free,malloc) import Foreign.Marshal.Array(newArray,copyArray) import Foreign.Ptr(Ptr) import Foreign.Storable(peek,Storable) import Foreign.C.Types import Foreign.C.String import System.IO.Unsafe(unsafePerformIO) import Control.Monad(when) infixr 1 # (#) :: TransArray c => c -> (b -> IO r) -> TransRaw c b -> IO r a # b = applyRaw a b {-# INLINE (#) #-} (#!) :: (TransArray c, TransArray c1) => c1 -> c -> TransRaw c1 (TransRaw c (IO r)) -> IO r a #! b = a # b # id {-# INLINE (#!) #-} fromei :: Enum a => a -> CInt fromei x = fromIntegral (fromEnum x) :: CInt data FunCodeV = Sin | Cos | Tan | Abs | ASin | ACos | ATan | Sinh | Cosh | Tanh | ASinh | ACosh | ATanh | Exp | Log | Sign | Sqrt deriving Enum data FunCodeSV = Scale | Recip | AddConstant | Negate | PowSV | PowVS | ModSV | ModVS deriving Enum data FunCodeVV = Add | Sub | Mul | Div | Pow | ATan2 | Mod deriving Enum data FunCodeS = Norm2 | AbsSum | MaxIdx | Max | MinIdx | Min deriving Enum ------------------------------------------------------------------ -- | sum of elements sumF :: Vector Float -> Float sumF = sumg c_sumF -- | sum of elements sumR :: Vector Double -> Double sumR = sumg c_sumR -- | sum of elements sumQ :: Vector (Complex Float) -> Complex Float sumQ = sumg c_sumQ -- | sum of elements sumC :: Vector (Complex Double) -> Complex Double sumC = sumg c_sumC sumI :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr I -> I :> Ok) , TransArray c , Storable a ) => I -> c -> a sumI m = sumg (c_sumI m) sumL :: ( TransRaw c (CInt -> Ptr a -> IO CInt) ~ (CInt -> Ptr Z -> Z :> Ok) , TransArray c , Storable a ) => Z -> c -> a sumL m = sumg (c_sumL m) sumg :: (TransArray c, Storable a) => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a sumg f x = unsafePerformIO $ do r <- createVector 1 (x #! r) f #| "sum" return $ r @> 0 type TVV t = t :> t :> Ok foreign import ccall unsafe "sumF" c_sumF :: TVV Float foreign import ccall unsafe "sumR" c_sumR :: TVV Double foreign import ccall unsafe "sumQ" c_sumQ :: TVV (Complex Float) foreign import ccall unsafe "sumC" c_sumC :: TVV (Complex Double) foreign import ccall unsafe "sumI" c_sumI :: I -> TVV I foreign import ccall unsafe "sumL" c_sumL :: Z -> TVV Z -- | product of elements prodF :: Vector Float -> Float prodF = prodg c_prodF -- | product of elements prodR :: Vector Double -> Double prodR = prodg c_prodR -- | product of elements prodQ :: Vector (Complex Float) -> Complex Float prodQ = prodg c_prodQ -- | product of elements prodC :: Vector (Complex Double) -> Complex Double prodC = prodg c_prodC prodI :: I-> Vector I -> I prodI = prodg . c_prodI prodL :: Z-> Vector Z -> Z prodL = prodg . c_prodL prodg :: (TransArray c, Storable a) => TransRaw c (CInt -> Ptr a -> IO CInt) -> c -> a prodg f x = unsafePerformIO $ do r <- createVector 1 (x #! r) f #| "prod" return $ r @> 0 foreign import ccall unsafe "prodF" c_prodF :: TVV Float foreign import ccall unsafe "prodR" c_prodR :: TVV Double foreign import ccall unsafe "prodQ" c_prodQ :: TVV (Complex Float) foreign import ccall unsafe "prodC" c_prodC :: TVV (Complex Double) foreign import ccall unsafe "prodI" c_prodI :: I -> TVV I foreign import ccall unsafe "prodL" c_prodL :: Z -> TVV Z ------------------------------------------------------------------ toScalarAux :: (Enum a, TransArray c, Storable a1) => (CInt -> TransRaw c (CInt -> Ptr a1 -> IO CInt)) -> a -> c -> a1 toScalarAux fun code v = unsafePerformIO $ do r <- createVector 1 (v #! r) (fun (fromei code)) #|"toScalarAux" return (r @> 0) vectorMapAux :: (Enum a, Storable t, Storable a1) => (CInt -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt) -> a -> Vector t -> Vector a1 vectorMapAux fun code v = unsafePerformIO $ do r <- createVector (dim v) (v #! r) (fun (fromei code)) #|"vectorMapAux" return r vectorMapValAux :: (Enum a, Storable a2, Storable t, Storable a1) => (CInt -> Ptr a2 -> CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt) -> a -> a2 -> Vector t -> Vector a1 vectorMapValAux fun code val v = unsafePerformIO $ do r <- createVector (dim v) pval <- newArray [val] (v #! r) (fun (fromei code) pval) #|"vectorMapValAux" free pval return r vectorZipAux :: (Enum a, TransArray c, Storable t, Storable a1) => (CInt -> CInt -> Ptr t -> TransRaw c (CInt -> Ptr a1 -> IO CInt)) -> a -> Vector t -> c -> Vector a1 vectorZipAux fun code u v = unsafePerformIO $ do r <- createVector (dim u) (u # v #! r) (fun (fromei code)) #|"vectorZipAux" return r --------------------------------------------------------------------- -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarR :: FunCodeS -> Vector Double -> Double toScalarR oper = toScalarAux c_toScalarR (fromei oper) foreign import ccall unsafe "toScalarR" c_toScalarR :: CInt -> TVV Double -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarF :: FunCodeS -> Vector Float -> Float toScalarF oper = toScalarAux c_toScalarF (fromei oper) foreign import ccall unsafe "toScalarF" c_toScalarF :: CInt -> TVV Float -- | obtains different functions of a vector: only norm1, norm2 toScalarC :: FunCodeS -> Vector (Complex Double) -> Double toScalarC oper = toScalarAux c_toScalarC (fromei oper) foreign import ccall unsafe "toScalarC" c_toScalarC :: CInt -> Complex Double :> Double :> Ok -- | obtains different functions of a vector: only norm1, norm2 toScalarQ :: FunCodeS -> Vector (Complex Float) -> Float toScalarQ oper = toScalarAux c_toScalarQ (fromei oper) foreign import ccall unsafe "toScalarQ" c_toScalarQ :: CInt -> Complex Float :> Float :> Ok -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarI :: FunCodeS -> Vector CInt -> CInt toScalarI oper = toScalarAux c_toScalarI (fromei oper) foreign import ccall unsafe "toScalarI" c_toScalarI :: CInt -> TVV CInt -- | obtains different functions of a vector: norm1, norm2, max, min, posmax, posmin, etc. toScalarL :: FunCodeS -> Vector Z -> Z toScalarL oper = toScalarAux c_toScalarL (fromei oper) foreign import ccall unsafe "toScalarL" c_toScalarL :: CInt -> TVV Z ------------------------------------------------------------------ -- | map of real vectors with given function vectorMapR :: FunCodeV -> Vector Double -> Vector Double vectorMapR = vectorMapAux c_vectorMapR foreign import ccall unsafe "mapR" c_vectorMapR :: CInt -> TVV Double -- | map of complex vectors with given function vectorMapC :: FunCodeV -> Vector (Complex Double) -> Vector (Complex Double) vectorMapC oper = vectorMapAux c_vectorMapC (fromei oper) foreign import ccall unsafe "mapC" c_vectorMapC :: CInt -> TVV (Complex Double) -- | map of real vectors with given function vectorMapF :: FunCodeV -> Vector Float -> Vector Float vectorMapF = vectorMapAux c_vectorMapF foreign import ccall unsafe "mapF" c_vectorMapF :: CInt -> TVV Float -- | map of real vectors with given function vectorMapQ :: FunCodeV -> Vector (Complex Float) -> Vector (Complex Float) vectorMapQ = vectorMapAux c_vectorMapQ foreign import ccall unsafe "mapQ" c_vectorMapQ :: CInt -> TVV (Complex Float) -- | map of real vectors with given function vectorMapI :: FunCodeV -> Vector CInt -> Vector CInt vectorMapI = vectorMapAux c_vectorMapI foreign import ccall unsafe "mapI" c_vectorMapI :: CInt -> TVV CInt -- | map of real vectors with given function vectorMapL :: FunCodeV -> Vector Z -> Vector Z vectorMapL = vectorMapAux c_vectorMapL foreign import ccall unsafe "mapL" c_vectorMapL :: CInt -> TVV Z ------------------------------------------------------------------- -- | map of real vectors with given function vectorMapValR :: FunCodeSV -> Double -> Vector Double -> Vector Double vectorMapValR oper = vectorMapValAux c_vectorMapValR (fromei oper) foreign import ccall unsafe "mapValR" c_vectorMapValR :: CInt -> Ptr Double -> TVV Double -- | map of complex vectors with given function vectorMapValC :: FunCodeSV -> Complex Double -> Vector (Complex Double) -> Vector (Complex Double) vectorMapValC = vectorMapValAux c_vectorMapValC foreign import ccall unsafe "mapValC" c_vectorMapValC :: CInt -> Ptr (Complex Double) -> TVV (Complex Double) -- | map of real vectors with given function vectorMapValF :: FunCodeSV -> Float -> Vector Float -> Vector Float vectorMapValF oper = vectorMapValAux c_vectorMapValF (fromei oper) foreign import ccall unsafe "mapValF" c_vectorMapValF :: CInt -> Ptr Float -> TVV Float -- | map of complex vectors with given function vectorMapValQ :: FunCodeSV -> Complex Float -> Vector (Complex Float) -> Vector (Complex Float) vectorMapValQ oper = vectorMapValAux c_vectorMapValQ (fromei oper) foreign import ccall unsafe "mapValQ" c_vectorMapValQ :: CInt -> Ptr (Complex Float) -> TVV (Complex Float) -- | map of real vectors with given function vectorMapValI :: FunCodeSV -> CInt -> Vector CInt -> Vector CInt vectorMapValI oper = vectorMapValAux c_vectorMapValI (fromei oper) foreign import ccall unsafe "mapValI" c_vectorMapValI :: CInt -> Ptr CInt -> TVV CInt -- | map of real vectors with given function vectorMapValL :: FunCodeSV -> Z -> Vector Z -> Vector Z vectorMapValL oper = vectorMapValAux c_vectorMapValL (fromei oper) foreign import ccall unsafe "mapValL" c_vectorMapValL :: CInt -> Ptr Z -> TVV Z ------------------------------------------------------------------- type TVVV t = t :> t :> t :> Ok -- | elementwise operation on real vectors vectorZipR :: FunCodeVV -> Vector Double -> Vector Double -> Vector Double vectorZipR = vectorZipAux c_vectorZipR foreign import ccall unsafe "zipR" c_vectorZipR :: CInt -> TVVV Double -- | elementwise operation on complex vectors vectorZipC :: FunCodeVV -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) vectorZipC = vectorZipAux c_vectorZipC foreign import ccall unsafe "zipC" c_vectorZipC :: CInt -> TVVV (Complex Double) -- | elementwise operation on real vectors vectorZipF :: FunCodeVV -> Vector Float -> Vector Float -> Vector Float vectorZipF = vectorZipAux c_vectorZipF foreign import ccall unsafe "zipF" c_vectorZipF :: CInt -> TVVV Float -- | elementwise operation on complex vectors vectorZipQ :: FunCodeVV -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float) vectorZipQ = vectorZipAux c_vectorZipQ foreign import ccall unsafe "zipQ" c_vectorZipQ :: CInt -> TVVV (Complex Float) -- | elementwise operation on CInt vectors vectorZipI :: FunCodeVV -> Vector CInt -> Vector CInt -> Vector CInt vectorZipI = vectorZipAux c_vectorZipI foreign import ccall unsafe "zipI" c_vectorZipI :: CInt -> TVVV CInt -- | elementwise operation on CInt vectors vectorZipL :: FunCodeVV -> Vector Z -> Vector Z -> Vector Z vectorZipL = vectorZipAux c_vectorZipL foreign import ccall unsafe "zipL" c_vectorZipL :: CInt -> TVVV Z -------------------------------------------------------------------------------- foreign import ccall unsafe "vectorScan" c_vectorScan :: CString -> Ptr CInt -> Ptr (Ptr Double) -> IO CInt vectorScan :: FilePath -> IO (Vector Double) vectorScan s = do pp <- malloc pn <- malloc cs <- newCString s ok <- c_vectorScan cs pn pp when (not (ok == 0)) $ error ("vectorScan: file \"" ++ s ++"\" not found") n <- fromIntegral <$> peek pn p <- peek pp v <- createVector n free pn free cs unsafeWith v $ \pv -> copyArray pv p n free p free pp return v -------------------------------------------------------------------------------- type Seed = Int data RandDist = Uniform -- ^ uniform distribution in [0,1) | Gaussian -- ^ normal distribution with mean zero and standard deviation one deriving Enum -- | Obtains a vector of pseudorandom elements (use randomIO to get a random seed). randomVector :: Seed -> RandDist -- ^ distribution -> Int -- ^ vector size -> Vector Double randomVector seed dist n = unsafePerformIO $ do r <- createVector n (r # id) (c_random_vector (fi seed) ((fi.fromEnum) dist)) #|"randomVector" return r foreign import ccall unsafe "random_vector" c_random_vector :: CInt -> CInt -> Double :> Ok -------------------------------------------------------------------------------- roundVector :: Vector Double -> Vector Double roundVector v = unsafePerformIO $ do r <- createVector (dim v) (v #! r) c_round_vector #|"roundVector" return r foreign import ccall unsafe "round_vector" c_round_vector :: TVV Double -------------------------------------------------------------------------------- -- | -- >>> range 5 -- fromList [0,1,2,3,4] -- range :: Int -> Vector I range n = unsafePerformIO $ do r <- createVector n (r # id) c_range_vector #|"range" return r foreign import ccall unsafe "range_vector" c_range_vector :: CInt :> Ok float2DoubleV :: Vector Float -> Vector Double float2DoubleV = tog c_float2double double2FloatV :: Vector Double -> Vector Float double2FloatV = tog c_double2float double2IntV :: Vector Double -> Vector CInt double2IntV = tog c_double2int int2DoubleV :: Vector CInt -> Vector Double int2DoubleV = tog c_int2double double2longV :: Vector Double -> Vector Z double2longV = tog c_double2long long2DoubleV :: Vector Z -> Vector Double long2DoubleV = tog c_long2double float2IntV :: Vector Float -> Vector CInt float2IntV = tog c_float2int int2floatV :: Vector CInt -> Vector Float int2floatV = tog c_int2float int2longV :: Vector I -> Vector Z int2longV = tog c_int2long long2intV :: Vector Z -> Vector I long2intV = tog c_long2int tog :: (Storable t, Storable a) => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a tog f v = unsafePerformIO $ do r <- createVector (dim v) (v #! r) f #|"tog" return r foreign import ccall unsafe "float2double" c_float2double :: Float :> Double :> Ok foreign import ccall unsafe "double2float" c_double2float :: Double :> Float :> Ok foreign import ccall unsafe "int2double" c_int2double :: CInt :> Double :> Ok foreign import ccall unsafe "double2int" c_double2int :: Double :> CInt :> Ok foreign import ccall unsafe "long2double" c_long2double :: Z :> Double :> Ok foreign import ccall unsafe "double2long" c_double2long :: Double :> Z :> Ok foreign import ccall unsafe "int2float" c_int2float :: CInt :> Float :> Ok foreign import ccall unsafe "float2int" c_float2int :: Float :> CInt :> Ok foreign import ccall unsafe "int2long" c_int2long :: I :> Z :> Ok foreign import ccall unsafe "long2int" c_long2int :: Z :> I :> Ok --------------------------------------------------------------- stepg :: (Storable t, Storable a) => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a stepg f v = unsafePerformIO $ do r <- createVector (dim v) (v #! r) f #|"step" return r stepD :: Vector Double -> Vector Double stepD = stepg c_stepD stepF :: Vector Float -> Vector Float stepF = stepg c_stepF stepI :: Vector CInt -> Vector CInt stepI = stepg c_stepI stepL :: Vector Z -> Vector Z stepL = stepg c_stepL foreign import ccall unsafe "stepF" c_stepF :: TVV Float foreign import ccall unsafe "stepD" c_stepD :: TVV Double foreign import ccall unsafe "stepI" c_stepI :: TVV CInt foreign import ccall unsafe "stepL" c_stepL :: TVV Z -------------------------------------------------------------------------------- conjugateAux :: (Storable t, Storable a) => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a conjugateAux fun x = unsafePerformIO $ do v <- createVector (dim x) (x #! v) fun #|"conjugateAux" return v conjugateQ :: Vector (Complex Float) -> Vector (Complex Float) conjugateQ = conjugateAux c_conjugateQ foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TVV (Complex Float) conjugateC :: Vector (Complex Double) -> Vector (Complex Double) conjugateC = conjugateAux c_conjugateC foreign import ccall unsafe "conjugateC" c_conjugateC :: TVV (Complex Double) -------------------------------------------------------------------------------- cloneVector :: Storable t => Vector t -> IO (Vector t) cloneVector v = do let n = dim v r <- createVector n let f _ s _ d = copyArray d s n >> return 0 (v #! r) f #|"cloneVector" return r -------------------------------------------------------------------------------- constantAux :: (Storable a1, Storable a) => (Ptr a1 -> CInt -> Ptr a -> IO CInt) -> a1 -> Int -> Vector a constantAux fun x n = unsafePerformIO $ do v <- createVector n px <- newArray [x] (v # id) (fun px) #|"constantAux" free px return v type TConst t = Ptr t -> t :> Ok foreign import ccall unsafe "constantF" cconstantF :: TConst Float foreign import ccall unsafe "constantR" cconstantR :: TConst Double foreign import ccall unsafe "constantQ" cconstantQ :: TConst (Complex Float) foreign import ccall unsafe "constantC" cconstantC :: TConst (Complex Double) foreign import ccall unsafe "constantI" cconstantI :: TConst CInt foreign import ccall unsafe "constantL" cconstantL :: TConst Z ---------------------------------------------------------------------- hmatrix-0.19.0.0/src/Internal/Matrix.hs0000644000000000000000000006412413260621005015746 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ConstrainedClassMethods #-} -- | -- Module : Internal.Matrix -- Copyright : (c) Alberto Ruiz 2007-15 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Internal matrix representation -- module Internal.Matrix where import Internal.Vector import Internal.Devel import Internal.Vectorized hiding ((#), (#!)) import Foreign.Marshal.Alloc ( free ) import Foreign.Marshal.Array(newArray) import Foreign.Ptr ( Ptr ) import Foreign.Storable ( Storable ) import Data.Complex ( Complex ) import Foreign.C.Types ( CInt(..) ) import Foreign.C.String ( CString, newCString ) import System.IO.Unsafe ( unsafePerformIO ) import Control.DeepSeq ( NFData(..) ) import Text.Printf ----------------------------------------------------------------- data MatrixOrder = RowMajor | ColumnMajor deriving (Show,Eq) -- | Matrix representation suitable for BLAS\/LAPACK computations. data Matrix t = Matrix { irows :: {-# UNPACK #-} !Int , icols :: {-# UNPACK #-} !Int , xRow :: {-# UNPACK #-} !Int , xCol :: {-# UNPACK #-} !Int , xdat :: {-# UNPACK #-} !(Vector t) } rows :: Matrix t -> Int rows = irows {-# INLINE rows #-} cols :: Matrix t -> Int cols = icols {-# INLINE cols #-} size :: Matrix t -> (Int, Int) size m = (irows m, icols m) {-# INLINE size #-} rowOrder :: Matrix t -> Bool rowOrder m = xCol m == 1 || cols m == 1 {-# INLINE rowOrder #-} colOrder :: Matrix t -> Bool colOrder m = xRow m == 1 || rows m == 1 {-# INLINE colOrder #-} is1d :: Matrix t -> Bool is1d (size->(r,c)) = r==1 || c==1 {-# INLINE is1d #-} -- data is not contiguous isSlice :: Storable t => Matrix t -> Bool isSlice m@(size->(r,c)) = r*c < dim (xdat m) {-# INLINE isSlice #-} orderOf :: Matrix t -> MatrixOrder orderOf m = if rowOrder m then RowMajor else ColumnMajor showInternal :: Storable t => Matrix t -> IO () showInternal m = printf "%dx%d %s %s %d:%d (%d)\n" r c slc ord xr xc dv where r = rows m c = cols m xr = xRow m xc = xCol m slc = if isSlice m then "slice" else "full" ord = if is1d m then "1d" else if rowOrder m then "rows" else "cols" dv = dim (xdat m) -------------------------------------------------------------------------------- -- | Matrix transpose. trans :: Matrix t -> Matrix t trans m@Matrix { irows = r, icols = c, xRow = xr, xCol = xc } = m { irows = c, icols = r, xRow = xc, xCol = xr } cmat :: (Element t) => Matrix t -> Matrix t cmat m | rowOrder m = m | otherwise = extractAll RowMajor m fmat :: (Element t) => Matrix t -> Matrix t fmat m | colOrder m = m | otherwise = extractAll ColumnMajor m -- C-Haskell matrix adapters {-# INLINE amatr #-} amatr :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> Ptr a -> f) -> IO r amatr x f g = unsafeWith (xdat x) (f . g r c) where r = fi (rows x) c = fi (cols x) {-# INLINE amat #-} amat :: Storable a => Matrix a -> (f -> IO r) -> (CInt -> CInt -> CInt -> CInt -> Ptr a -> f) -> IO r amat x f g = unsafeWith (xdat x) (f . g r c sr sc) where r = fi (rows x) c = fi (cols x) sr = fi (xRow x) sc = fi (xCol x) instance Storable t => TransArray (Matrix t) where type TransRaw (Matrix t) b = CInt -> CInt -> Ptr t -> b type Trans (Matrix t) b = CInt -> CInt -> CInt -> CInt -> Ptr t -> b apply = amat {-# INLINE apply #-} applyRaw = amatr {-# INLINE applyRaw #-} infixr 1 # (#) :: TransArray c => c -> (b -> IO r) -> Trans c b -> IO r a # b = apply a b {-# INLINE (#) #-} (#!) :: (TransArray c, TransArray c1) => c1 -> c -> Trans c1 (Trans c (IO r)) -> IO r a #! b = a # b # id {-# INLINE (#!) #-} -------------------------------------------------------------------------------- copy :: Element t => MatrixOrder -> Matrix t -> IO (Matrix t) copy ord m = extractR ord m 0 (idxs[0,rows m-1]) 0 (idxs[0,cols m-1]) extractAll :: Element t => MatrixOrder -> Matrix t -> Matrix t extractAll ord m = unsafePerformIO (copy ord m) {- | Creates a vector by concatenation of rows. If the matrix is ColumnMajor, this operation requires a transpose. >>> flatten (ident 3) fromList [1.0,0.0,0.0,0.0,1.0,0.0,0.0,0.0,1.0] -} flatten :: Element t => Matrix t -> Vector t flatten m | isSlice m || not (rowOrder m) = xdat (extractAll RowMajor m) | otherwise = xdat m -- | the inverse of 'Data.Packed.Matrix.fromLists' toLists :: (Element t) => Matrix t -> [[t]] toLists = map toList . toRows -- | common value with \"adaptable\" 1 compatdim :: [Int] -> Maybe Int compatdim [] = Nothing compatdim [a] = Just a compatdim (a:b:xs) | a==b = compatdim (b:xs) | a==1 = compatdim (b:xs) | b==1 = compatdim (a:xs) | otherwise = Nothing -- | Create a matrix from a list of vectors. -- All vectors must have the same dimension, -- or dimension 1, which is are automatically expanded. fromRows :: Element t => [Vector t] -> Matrix t fromRows [] = emptyM 0 0 fromRows vs = case compatdim (map dim vs) of Nothing -> error $ "fromRows expects vectors with equal sizes (or singletons), given: " ++ show (map dim vs) Just 0 -> emptyM r 0 Just c -> matrixFromVector RowMajor r c . vjoin . map (adapt c) $ vs where r = length vs adapt c v | c == 0 = fromList[] | dim v == c = v | otherwise = constantD (v@>0) c -- | extracts the rows of a matrix as a list of vectors toRows :: Element t => Matrix t -> [Vector t] toRows m | rowOrder m = map sub rowRange | otherwise = map ext rowRange where rowRange = [0..rows m-1] sub k = subVector (k*xRow m) (cols m) (xdat m) ext k = xdat $ unsafePerformIO $ extractR RowMajor m 1 (idxs[k]) 0 (idxs[0,cols m-1]) -- | Creates a matrix from a list of vectors, as columns fromColumns :: Element t => [Vector t] -> Matrix t fromColumns m = trans . fromRows $ m -- | Creates a list of vectors from the columns of a matrix toColumns :: Element t => Matrix t -> [Vector t] toColumns m = toRows . trans $ m -- | Reads a matrix position. (@@>) :: Storable t => Matrix t -> (Int,Int) -> t infixl 9 @@> m@Matrix {irows = r, icols = c} @@> (i,j) | i<0 || i>=r || j<0 || j>=c = error "matrix indexing out of range" | otherwise = atM' m i j {-# INLINE (@@>) #-} -- Unsafe matrix access without range checking atM' :: Storable t => Matrix t -> Int -> Int -> t atM' m i j = xdat m `at'` (i * (xRow m) + j * (xCol m)) {-# INLINE atM' #-} ------------------------------------------------------------------ matrixFromVector :: Storable t => MatrixOrder -> Int -> Int -> Vector t -> Matrix t matrixFromVector _ 1 _ v@(dim->d) = Matrix { irows = 1, icols = d, xdat = v, xRow = d, xCol = 1 } matrixFromVector _ _ 1 v@(dim->d) = Matrix { irows = d, icols = 1, xdat = v, xRow = 1, xCol = d } matrixFromVector o r c v | r * c == dim v = m | otherwise = error $ "can't reshape vector dim = "++ show (dim v)++" to matrix " ++ shSize m where m | o == RowMajor = Matrix { irows = r, icols = c, xdat = v, xRow = c, xCol = 1 } | otherwise = Matrix { irows = r, icols = c, xdat = v, xRow = 1, xCol = r } -- allocates memory for a new matrix createMatrix :: (Storable a) => MatrixOrder -> Int -> Int -> IO (Matrix a) createMatrix ord r c = do p <- createVector (r*c) return (matrixFromVector ord r c p) {- | Creates a matrix from a vector by grouping the elements in rows with the desired number of columns. (GNU-Octave groups by columns. To do it you can define @reshapeF r = tr' . reshape r@ where r is the desired number of rows.) >>> reshape 4 (fromList [1..12]) (3><4) [ 1.0, 2.0, 3.0, 4.0 , 5.0, 6.0, 7.0, 8.0 , 9.0, 10.0, 11.0, 12.0 ] -} reshape :: Storable t => Int -> Vector t -> Matrix t reshape 0 v = matrixFromVector RowMajor 0 0 v reshape c v = matrixFromVector RowMajor (dim v `div` c) c v -- | application of a vector function on the flattened matrix elements liftMatrix :: (Element a, Element b) => (Vector a -> Vector b) -> Matrix a -> Matrix b liftMatrix f m@Matrix { irows = r, icols = c, xdat = d} | isSlice m = matrixFromVector RowMajor r c (f (flatten m)) | otherwise = matrixFromVector (orderOf m) r c (f d) -- | application of a vector function on the flattened matrices elements liftMatrix2 :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t liftMatrix2 f m1@(size->(r,c)) m2 | (r,c)/=size m2 = error "nonconformant matrices in liftMatrix2" | rowOrder m1 = matrixFromVector RowMajor r c (f (flatten m1) (flatten m2)) | otherwise = matrixFromVector ColumnMajor r c (f (flatten (trans m1)) (flatten (trans m2))) ------------------------------------------------------------------ -- | Supported matrix elements. class (Storable a) => Element a where constantD :: a -> Int -> Vector a extractR :: MatrixOrder -> Matrix a -> CInt -> Vector CInt -> CInt -> Vector CInt -> IO (Matrix a) setRect :: Int -> Int -> Matrix a -> Matrix a -> IO () sortI :: Ord a => Vector a -> Vector CInt sortV :: Ord a => Vector a -> Vector a compareV :: Ord a => Vector a -> Vector a -> Vector CInt selectV :: Vector CInt -> Vector a -> Vector a -> Vector a -> Vector a remapM :: Matrix CInt -> Matrix CInt -> Matrix a -> Matrix a rowOp :: Int -> a -> Int -> Int -> Int -> Int -> Matrix a -> IO () gemm :: Vector a -> Matrix a -> Matrix a -> Matrix a -> IO () reorderV :: Vector CInt-> Vector CInt-> Vector a -> Vector a -- see reorderVector for documentation instance Element Float where constantD = constantAux cconstantF extractR = extractAux c_extractF setRect = setRectAux c_setRectF sortI = sortIdxF sortV = sortValF compareV = compareF selectV = selectF remapM = remapF rowOp = rowOpAux c_rowOpF gemm = gemmg c_gemmF reorderV = reorderAux c_reorderF instance Element Double where constantD = constantAux cconstantR extractR = extractAux c_extractD setRect = setRectAux c_setRectD sortI = sortIdxD sortV = sortValD compareV = compareD selectV = selectD remapM = remapD rowOp = rowOpAux c_rowOpD gemm = gemmg c_gemmD reorderV = reorderAux c_reorderD instance Element (Complex Float) where constantD = constantAux cconstantQ extractR = extractAux c_extractQ setRect = setRectAux c_setRectQ sortI = undefined sortV = undefined compareV = undefined selectV = selectQ remapM = remapQ rowOp = rowOpAux c_rowOpQ gemm = gemmg c_gemmQ reorderV = reorderAux c_reorderQ instance Element (Complex Double) where constantD = constantAux cconstantC extractR = extractAux c_extractC setRect = setRectAux c_setRectC sortI = undefined sortV = undefined compareV = undefined selectV = selectC remapM = remapC rowOp = rowOpAux c_rowOpC gemm = gemmg c_gemmC reorderV = reorderAux c_reorderC instance Element (CInt) where constantD = constantAux cconstantI extractR = extractAux c_extractI setRect = setRectAux c_setRectI sortI = sortIdxI sortV = sortValI compareV = compareI selectV = selectI remapM = remapI rowOp = rowOpAux c_rowOpI gemm = gemmg c_gemmI reorderV = reorderAux c_reorderI instance Element Z where constantD = constantAux cconstantL extractR = extractAux c_extractL setRect = setRectAux c_setRectL sortI = sortIdxL sortV = sortValL compareV = compareL selectV = selectL remapM = remapL rowOp = rowOpAux c_rowOpL gemm = gemmg c_gemmL reorderV = reorderAux c_reorderL ------------------------------------------------------------------- -- | reference to a rectangular slice of a matrix (no data copy) subMatrix :: Element a => (Int,Int) -- ^ (r0,c0) starting position -> (Int,Int) -- ^ (rt,ct) dimensions of submatrix -> Matrix a -- ^ input matrix -> Matrix a -- ^ result subMatrix (r0,c0) (rt,ct) m | rt <= 0 || ct <= 0 = matrixFromVector RowMajor (max 0 rt) (max 0 ct) (fromList []) | 0 <= r0 && 0 <= rt && r0+rt <= rows m && 0 <= c0 && 0 <= ct && c0+ct <= cols m = res | otherwise = error $ "wrong subMatrix "++show ((r0,c0),(rt,ct))++" of "++shSize m where p = r0 * xRow m + c0 * xCol m tot | rowOrder m = ct + (rt-1) * xRow m | otherwise = rt + (ct-1) * xCol m res = m { irows = rt, icols = ct, xdat = subVector p tot (xdat m) } -------------------------------------------------------------------------- maxZ :: (Num t1, Ord t1, Foldable t) => t t1 -> t1 maxZ xs = if minimum xs == 0 then 0 else maximum xs conformMs :: Element t => [Matrix t] -> [Matrix t] conformMs ms = map (conformMTo (r,c)) ms where r = maxZ (map rows ms) c = maxZ (map cols ms) conformVs :: Element t => [Vector t] -> [Vector t] conformVs vs = map (conformVTo n) vs where n = maxZ (map dim vs) conformMTo :: Element t => (Int, Int) -> Matrix t -> Matrix t conformMTo (r,c) m | size m == (r,c) = m | size m == (1,1) = matrixFromVector RowMajor r c (constantD (m@@>(0,0)) (r*c)) | size m == (r,1) = repCols c m | size m == (1,c) = repRows r m | otherwise = error $ "matrix " ++ shSize m ++ " cannot be expanded to " ++ shDim (r,c) conformVTo :: Element t => Int -> Vector t -> Vector t conformVTo n v | dim v == n = v | dim v == 1 = constantD (v@>0) n | otherwise = error $ "vector of dim=" ++ show (dim v) ++ " cannot be expanded to dim=" ++ show n repRows :: Element t => Int -> Matrix t -> Matrix t repRows n x = fromRows (replicate n (flatten x)) repCols :: Element t => Int -> Matrix t -> Matrix t repCols n x = fromColumns (replicate n (flatten x)) shSize :: Matrix t -> [Char] shSize = shDim . size shDim :: (Show a, Show a1) => (a1, a) -> [Char] shDim (r,c) = "(" ++ show r ++"x"++ show c ++")" emptyM :: Storable t => Int -> Int -> Matrix t emptyM r c = matrixFromVector RowMajor r c (fromList[]) ---------------------------------------------------------------------- instance (Storable t, NFData t) => NFData (Matrix t) where rnf m | d > 0 = rnf (v @> 0) | otherwise = () where d = dim v v = xdat m --------------------------------------------------------------- extractAux :: (Eq t3, Eq t2, TransArray c, Storable a, Storable t1, Storable t, Num t3, Num t2, Integral t1, Integral t) => (t3 -> t2 -> CInt -> Ptr t1 -> CInt -> Ptr t -> Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt)) -> MatrixOrder -> c -> t3 -> Vector t1 -> t2 -> Vector t -> IO (Matrix a) extractAux f ord m moder vr modec vc = do let nr = if moder == 0 then fromIntegral $ vr@>1 - vr@>0 + 1 else dim vr nc = if modec == 0 then fromIntegral $ vc@>1 - vc@>0 + 1 else dim vc r <- createMatrix ord nr nc (vr # vc # m #! r) (f moder modec) #|"extract" return r type Extr x = CInt -> CInt -> CIdxs (CIdxs (OM x (OM x (IO CInt)))) foreign import ccall unsafe "extractD" c_extractD :: Extr Double foreign import ccall unsafe "extractF" c_extractF :: Extr Float foreign import ccall unsafe "extractC" c_extractC :: Extr (Complex Double) foreign import ccall unsafe "extractQ" c_extractQ :: Extr (Complex Float) foreign import ccall unsafe "extractI" c_extractI :: Extr CInt foreign import ccall unsafe "extractL" c_extractL :: Extr Z --------------------------------------------------------------- setRectAux :: (TransArray c1, TransArray c) => (CInt -> CInt -> Trans c1 (Trans c (IO CInt))) -> Int -> Int -> c1 -> c -> IO () setRectAux f i j m r = (m #! r) (f (fi i) (fi j)) #|"setRect" type SetRect x = I -> I -> x ::> x::> Ok foreign import ccall unsafe "setRectD" c_setRectD :: SetRect Double foreign import ccall unsafe "setRectF" c_setRectF :: SetRect Float foreign import ccall unsafe "setRectC" c_setRectC :: SetRect (Complex Double) foreign import ccall unsafe "setRectQ" c_setRectQ :: SetRect (Complex Float) foreign import ccall unsafe "setRectI" c_setRectI :: SetRect I foreign import ccall unsafe "setRectL" c_setRectL :: SetRect Z -------------------------------------------------------------------------------- sortG :: (Storable t, Storable a) => (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> Vector t -> Vector a sortG f v = unsafePerformIO $ do r <- createVector (dim v) (v #! r) f #|"sortG" return r sortIdxD :: Vector Double -> Vector CInt sortIdxD = sortG c_sort_indexD sortIdxF :: Vector Float -> Vector CInt sortIdxF = sortG c_sort_indexF sortIdxI :: Vector CInt -> Vector CInt sortIdxI = sortG c_sort_indexI sortIdxL :: Vector Z -> Vector I sortIdxL = sortG c_sort_indexL sortValD :: Vector Double -> Vector Double sortValD = sortG c_sort_valD sortValF :: Vector Float -> Vector Float sortValF = sortG c_sort_valF sortValI :: Vector CInt -> Vector CInt sortValI = sortG c_sort_valI sortValL :: Vector Z -> Vector Z sortValL = sortG c_sort_valL foreign import ccall unsafe "sort_indexD" c_sort_indexD :: CV Double (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexF" c_sort_indexF :: CV Float (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexI" c_sort_indexI :: CV CInt (CV CInt (IO CInt)) foreign import ccall unsafe "sort_indexL" c_sort_indexL :: Z :> I :> Ok foreign import ccall unsafe "sort_valuesD" c_sort_valD :: CV Double (CV Double (IO CInt)) foreign import ccall unsafe "sort_valuesF" c_sort_valF :: CV Float (CV Float (IO CInt)) foreign import ccall unsafe "sort_valuesI" c_sort_valI :: CV CInt (CV CInt (IO CInt)) foreign import ccall unsafe "sort_valuesL" c_sort_valL :: Z :> Z :> Ok -------------------------------------------------------------------------------- compareG :: (TransArray c, Storable t, Storable a) => Trans c (CInt -> Ptr t -> CInt -> Ptr a -> IO CInt) -> c -> Vector t -> Vector a compareG f u v = unsafePerformIO $ do r <- createVector (dim v) (u # v #! r) f #|"compareG" return r compareD :: Vector Double -> Vector Double -> Vector CInt compareD = compareG c_compareD compareF :: Vector Float -> Vector Float -> Vector CInt compareF = compareG c_compareF compareI :: Vector CInt -> Vector CInt -> Vector CInt compareI = compareG c_compareI compareL :: Vector Z -> Vector Z -> Vector CInt compareL = compareG c_compareL foreign import ccall unsafe "compareD" c_compareD :: CV Double (CV Double (CV CInt (IO CInt))) foreign import ccall unsafe "compareF" c_compareF :: CV Float (CV Float (CV CInt (IO CInt))) foreign import ccall unsafe "compareI" c_compareI :: CV CInt (CV CInt (CV CInt (IO CInt))) foreign import ccall unsafe "compareL" c_compareL :: Z :> Z :> I :> Ok -------------------------------------------------------------------------------- selectG :: (TransArray c, TransArray c1, TransArray c2, Storable t, Storable a) => Trans c2 (Trans c1 (CInt -> Ptr t -> Trans c (CInt -> Ptr a -> IO CInt))) -> c2 -> c1 -> Vector t -> c -> Vector a selectG f c u v w = unsafePerformIO $ do r <- createVector (dim v) (c # u # v # w #! r) f #|"selectG" return r selectD :: Vector CInt -> Vector Double -> Vector Double -> Vector Double -> Vector Double selectD = selectG c_selectD selectF :: Vector CInt -> Vector Float -> Vector Float -> Vector Float -> Vector Float selectF = selectG c_selectF selectI :: Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt -> Vector CInt selectI = selectG c_selectI selectL :: Vector CInt -> Vector Z -> Vector Z -> Vector Z -> Vector Z selectL = selectG c_selectL selectC :: Vector CInt -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) selectC = selectG c_selectC selectQ :: Vector CInt -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float) -> Vector (Complex Float) selectQ = selectG c_selectQ type Sel x = CV CInt (CV x (CV x (CV x (CV x (IO CInt))))) foreign import ccall unsafe "chooseD" c_selectD :: Sel Double foreign import ccall unsafe "chooseF" c_selectF :: Sel Float foreign import ccall unsafe "chooseI" c_selectI :: Sel CInt foreign import ccall unsafe "chooseC" c_selectC :: Sel (Complex Double) foreign import ccall unsafe "chooseQ" c_selectQ :: Sel (Complex Float) foreign import ccall unsafe "chooseL" c_selectL :: Sel Z --------------------------------------------------------------------------- remapG :: (TransArray c, TransArray c1, Storable t, Storable a) => (CInt -> CInt -> CInt -> CInt -> Ptr t -> Trans c1 (Trans c (CInt -> CInt -> CInt -> CInt -> Ptr a -> IO CInt))) -> Matrix t -> c1 -> c -> Matrix a remapG f i j m = unsafePerformIO $ do r <- createMatrix RowMajor (rows i) (cols i) (i # j # m #! r) f #|"remapG" return r remapD :: Matrix CInt -> Matrix CInt -> Matrix Double -> Matrix Double remapD = remapG c_remapD remapF :: Matrix CInt -> Matrix CInt -> Matrix Float -> Matrix Float remapF = remapG c_remapF remapI :: Matrix CInt -> Matrix CInt -> Matrix CInt -> Matrix CInt remapI = remapG c_remapI remapL :: Matrix CInt -> Matrix CInt -> Matrix Z -> Matrix Z remapL = remapG c_remapL remapC :: Matrix CInt -> Matrix CInt -> Matrix (Complex Double) -> Matrix (Complex Double) remapC = remapG c_remapC remapQ :: Matrix CInt -> Matrix CInt -> Matrix (Complex Float) -> Matrix (Complex Float) remapQ = remapG c_remapQ type Rem x = OM CInt (OM CInt (OM x (OM x (IO CInt)))) foreign import ccall unsafe "remapD" c_remapD :: Rem Double foreign import ccall unsafe "remapF" c_remapF :: Rem Float foreign import ccall unsafe "remapI" c_remapI :: Rem CInt foreign import ccall unsafe "remapC" c_remapC :: Rem (Complex Double) foreign import ccall unsafe "remapQ" c_remapQ :: Rem (Complex Float) foreign import ccall unsafe "remapL" c_remapL :: Rem Z -------------------------------------------------------------------------------- rowOpAux :: (TransArray c, Storable a) => (CInt -> Ptr a -> CInt -> CInt -> CInt -> CInt -> Trans c (IO CInt)) -> Int -> a -> Int -> Int -> Int -> Int -> c -> IO () rowOpAux f c x i1 i2 j1 j2 m = do px <- newArray [x] (m # id) (f (fi c) px (fi i1) (fi i2) (fi j1) (fi j2)) #|"rowOp" free px type RowOp x = CInt -> Ptr x -> CInt -> CInt -> CInt -> CInt -> x ::> Ok foreign import ccall unsafe "rowop_double" c_rowOpD :: RowOp R foreign import ccall unsafe "rowop_float" c_rowOpF :: RowOp Float foreign import ccall unsafe "rowop_TCD" c_rowOpC :: RowOp C foreign import ccall unsafe "rowop_TCF" c_rowOpQ :: RowOp (Complex Float) foreign import ccall unsafe "rowop_int32_t" c_rowOpI :: RowOp I foreign import ccall unsafe "rowop_int64_t" c_rowOpL :: RowOp Z foreign import ccall unsafe "rowop_mod_int32_t" c_rowOpMI :: I -> RowOp I foreign import ccall unsafe "rowop_mod_int64_t" c_rowOpML :: Z -> RowOp Z -------------------------------------------------------------------------------- gemmg :: (TransArray c1, TransArray c, TransArray c2, TransArray c3) => Trans c3 (Trans c2 (Trans c1 (Trans c (IO CInt)))) -> c3 -> c2 -> c1 -> c -> IO () gemmg f v m1 m2 m3 = (v # m1 # m2 #! m3) f #|"gemmg" type Tgemm x = x :> x ::> x ::> x ::> Ok foreign import ccall unsafe "gemm_double" c_gemmD :: Tgemm R foreign import ccall unsafe "gemm_float" c_gemmF :: Tgemm Float foreign import ccall unsafe "gemm_TCD" c_gemmC :: Tgemm C foreign import ccall unsafe "gemm_TCF" c_gemmQ :: Tgemm (Complex Float) foreign import ccall unsafe "gemm_int32_t" c_gemmI :: Tgemm I foreign import ccall unsafe "gemm_int64_t" c_gemmL :: Tgemm Z foreign import ccall unsafe "gemm_mod_int32_t" c_gemmMI :: I -> Tgemm I foreign import ccall unsafe "gemm_mod_int64_t" c_gemmML :: Z -> Tgemm Z -------------------------------------------------------------------------------- reorderAux :: (TransArray c, Storable t, Storable a1, Storable t1, Storable a) => (CInt -> Ptr a -> CInt -> Ptr t1 -> Trans c (CInt -> Ptr t -> CInt -> Ptr a1 -> IO CInt)) -> Vector t1 -> c -> Vector t -> Vector a1 reorderAux f s d v = unsafePerformIO $ do k <- createVector (dim s) r <- createVector (dim v) (k # s # d # v #! r) f #| "reorderV" return r type Reorder x = CV CInt (CV CInt (CV CInt (CV x (CV x (IO CInt))))) foreign import ccall unsafe "reorderD" c_reorderD :: Reorder Double foreign import ccall unsafe "reorderF" c_reorderF :: Reorder Float foreign import ccall unsafe "reorderI" c_reorderI :: Reorder CInt foreign import ccall unsafe "reorderC" c_reorderC :: Reorder (Complex Double) foreign import ccall unsafe "reorderQ" c_reorderQ :: Reorder (Complex Float) foreign import ccall unsafe "reorderL" c_reorderL :: Reorder Z -- | Transpose an array with dimensions @dims@ by making a copy using @strides@. For example, for an array with 3 indices, -- @(reorderVector strides dims v) ! ((i * dims ! 1 + j) * dims ! 2 + k) == v ! (i * strides ! 0 + j * strides ! 1 + k * strides ! 2)@ -- This function is intended to be used internally by tensor libraries. reorderVector :: Element a => Vector CInt -- ^ @strides@: array strides -> Vector CInt -- ^ @dims@: array dimensions of new array @v@ -> Vector a -- ^ @v@: flattened input array -> Vector a -- ^ @v'@: flattened output array reorderVector = reorderV -------------------------------------------------------------------------------- foreign import ccall unsafe "saveMatrix" c_saveMatrix :: CString -> CString -> Double ::> Ok {- | save a matrix as a 2D ASCII table -} saveMatrix :: FilePath -> String -- ^ \"printf\" format (e.g. \"%.2f\", \"%g\", etc.) -> Matrix Double -> IO () saveMatrix name format m = do cname <- newCString name cformat <- newCString format (m # id) (c_saveMatrix cname cformat) #|"saveMatrix" free cname free cformat return () -------------------------------------------------------------------------------- hmatrix-0.19.0.0/src/Internal/ST.hs0000644000000000000000000002177313260621005015033 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.ST -- Copyright : (c) Alberto Ruiz 2008 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- In-place manipulation inside the ST monad. -- See @examples/inplace.hs@ in the repository. -- ----------------------------------------------------------------------------- module Internal.ST ( ST, runST, -- * Mutable Vectors STVector, newVector, thawVector, freezeVector, runSTVector, readVector, writeVector, modifyVector, liftSTVector, -- * Mutable Matrices STMatrix, newMatrix, thawMatrix, freezeMatrix, runSTMatrix, readMatrix, writeMatrix, modifyMatrix, liftSTMatrix, mutable, extractMatrix, setMatrix, rowOper, RowOper(..), RowRange(..), ColRange(..), gemmm, Slice(..), -- * Unsafe functions newUndefinedVector, unsafeReadVector, unsafeWriteVector, unsafeThawVector, unsafeFreezeVector, newUndefinedMatrix, unsafeReadMatrix, unsafeWriteMatrix, unsafeThawMatrix, unsafeFreezeMatrix ) where import Internal.Vector import Internal.Matrix import Internal.Vectorized import Control.Monad.ST(ST, runST) import Foreign.Storable(Storable, peekElemOff, pokeElemOff) import Control.Monad.ST.Unsafe(unsafeIOToST) {-# INLINE ioReadV #-} ioReadV :: Storable t => Vector t -> Int -> IO t ioReadV v k = unsafeWith v $ \s -> peekElemOff s k {-# INLINE ioWriteV #-} ioWriteV :: Storable t => Vector t -> Int -> t -> IO () ioWriteV v k x = unsafeWith v $ \s -> pokeElemOff s k x newtype STVector s t = STVector (Vector t) thawVector :: Storable t => Vector t -> ST s (STVector s t) thawVector = unsafeIOToST . fmap STVector . cloneVector unsafeThawVector :: Storable t => Vector t -> ST s (STVector s t) unsafeThawVector = unsafeIOToST . return . STVector runSTVector :: Storable t => (forall s . ST s (STVector s t)) -> Vector t runSTVector st = runST (st >>= unsafeFreezeVector) {-# INLINE unsafeReadVector #-} unsafeReadVector :: Storable t => STVector s t -> Int -> ST s t unsafeReadVector (STVector x) = unsafeIOToST . ioReadV x {-# INLINE unsafeWriteVector #-} unsafeWriteVector :: Storable t => STVector s t -> Int -> t -> ST s () unsafeWriteVector (STVector x) k = unsafeIOToST . ioWriteV x k {-# INLINE modifyVector #-} modifyVector :: (Storable t) => STVector s t -> Int -> (t -> t) -> ST s () modifyVector x k f = readVector x k >>= return . f >>= unsafeWriteVector x k liftSTVector :: (Storable t) => (Vector t -> a) -> STVector s t -> ST s a liftSTVector f (STVector x) = unsafeIOToST . fmap f . cloneVector $ x freezeVector :: (Storable t) => STVector s t -> ST s (Vector t) freezeVector v = liftSTVector id v unsafeFreezeVector :: (Storable t) => STVector s t -> ST s (Vector t) unsafeFreezeVector (STVector x) = unsafeIOToST . return $ x {-# INLINE safeIndexV #-} safeIndexV :: Storable t2 => (STVector s t2 -> Int -> t) -> STVector t1 t2 -> Int -> t safeIndexV f (STVector v) k | k < 0 || k>= dim v = error $ "out of range error in vector (dim=" ++show (dim v)++", pos="++show k++")" | otherwise = f (STVector v) k {-# INLINE readVector #-} readVector :: Storable t => STVector s t -> Int -> ST s t readVector = safeIndexV unsafeReadVector {-# INLINE writeVector #-} writeVector :: Storable t => STVector s t -> Int -> t -> ST s () writeVector = safeIndexV unsafeWriteVector newUndefinedVector :: Storable t => Int -> ST s (STVector s t) newUndefinedVector = unsafeIOToST . fmap STVector . createVector {-# INLINE newVector #-} newVector :: Storable t => t -> Int -> ST s (STVector s t) newVector x n = do v <- newUndefinedVector n let go (-1) = return v go !k = unsafeWriteVector v k x >> go (k-1 :: Int) go (n-1) ------------------------------------------------------------------------- {-# INLINE ioReadM #-} ioReadM :: Storable t => Matrix t -> Int -> Int -> IO t ioReadM m r c = ioReadV (xdat m) (r * xRow m + c * xCol m) {-# INLINE ioWriteM #-} ioWriteM :: Storable t => Matrix t -> Int -> Int -> t -> IO () ioWriteM m r c val = ioWriteV (xdat m) (r * xRow m + c * xCol m) val newtype STMatrix s t = STMatrix (Matrix t) thawMatrix :: Element t => Matrix t -> ST s (STMatrix s t) thawMatrix = unsafeIOToST . fmap STMatrix . cloneMatrix unsafeThawMatrix :: Storable t => Matrix t -> ST s (STMatrix s t) unsafeThawMatrix = unsafeIOToST . return . STMatrix runSTMatrix :: Storable t => (forall s . ST s (STMatrix s t)) -> Matrix t runSTMatrix st = runST (st >>= unsafeFreezeMatrix) {-# INLINE unsafeReadMatrix #-} unsafeReadMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t unsafeReadMatrix (STMatrix x) r = unsafeIOToST . ioReadM x r {-# INLINE unsafeWriteMatrix #-} unsafeWriteMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () unsafeWriteMatrix (STMatrix x) r c = unsafeIOToST . ioWriteM x r c {-# INLINE modifyMatrix #-} modifyMatrix :: (Storable t) => STMatrix s t -> Int -> Int -> (t -> t) -> ST s () modifyMatrix x r c f = readMatrix x r c >>= return . f >>= unsafeWriteMatrix x r c liftSTMatrix :: (Element t) => (Matrix t -> a) -> STMatrix s t -> ST s a liftSTMatrix f (STMatrix x) = unsafeIOToST . fmap f . cloneMatrix $ x unsafeFreezeMatrix :: (Storable t) => STMatrix s t -> ST s (Matrix t) unsafeFreezeMatrix (STMatrix x) = unsafeIOToST . return $ x freezeMatrix :: (Element t) => STMatrix s t -> ST s (Matrix t) freezeMatrix m = liftSTMatrix id m cloneMatrix :: Element t => Matrix t -> IO (Matrix t) cloneMatrix m = copy (orderOf m) m {-# INLINE safeIndexM #-} safeIndexM :: (STMatrix s t2 -> Int -> Int -> t) -> STMatrix t1 t2 -> Int -> Int -> t safeIndexM f (STMatrix m) r c | r<0 || r>=rows m || c<0 || c>=cols m = error $ "out of range error in matrix (size=" ++show (rows m,cols m)++", pos="++show (r,c)++")" | otherwise = f (STMatrix m) r c {-# INLINE readMatrix #-} readMatrix :: Storable t => STMatrix s t -> Int -> Int -> ST s t readMatrix = safeIndexM unsafeReadMatrix {-# INLINE writeMatrix #-} writeMatrix :: Storable t => STMatrix s t -> Int -> Int -> t -> ST s () writeMatrix = safeIndexM unsafeWriteMatrix setMatrix :: Element t => STMatrix s t -> Int -> Int -> Matrix t -> ST s () setMatrix (STMatrix x) i j m = unsafeIOToST $ setRect i j m x newUndefinedMatrix :: Storable t => MatrixOrder -> Int -> Int -> ST s (STMatrix s t) newUndefinedMatrix ord r c = unsafeIOToST $ fmap STMatrix $ createMatrix ord r c {-# NOINLINE newMatrix #-} newMatrix :: Storable t => t -> Int -> Int -> ST s (STMatrix s t) newMatrix v r c = unsafeThawMatrix $ reshape c $ runSTVector $ newVector v (r*c) -------------------------------------------------------------------------------- data ColRange = AllCols | ColRange Int Int | Col Int | FromCol Int getColRange :: Int -> ColRange -> (Int, Int) getColRange c AllCols = (0,c-1) getColRange c (ColRange a b) = (a `mod` c, b `mod` c) getColRange c (Col a) = (a `mod` c, a `mod` c) getColRange c (FromCol a) = (a `mod` c, c-1) data RowRange = AllRows | RowRange Int Int | Row Int | FromRow Int getRowRange :: Int -> RowRange -> (Int, Int) getRowRange r AllRows = (0,r-1) getRowRange r (RowRange a b) = (a `mod` r, b `mod` r) getRowRange r (Row a) = (a `mod` r, a `mod` r) getRowRange r (FromRow a) = (a `mod` r, r-1) data RowOper t = AXPY t Int Int ColRange | SCAL t RowRange ColRange | SWAP Int Int ColRange rowOper :: (Num t, Element t) => RowOper t -> STMatrix s t -> ST s () rowOper (AXPY x i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 0 x i1' i2' j1 j2 m where (j1,j2) = getColRange (cols m) r i1' = i1 `mod` (rows m) i2' = i2 `mod` (rows m) rowOper (SCAL x rr rc) (STMatrix m) = unsafeIOToST $ rowOp 1 x i1 i2 j1 j2 m where (i1,i2) = getRowRange (rows m) rr (j1,j2) = getColRange (cols m) rc rowOper (SWAP i1 i2 r) (STMatrix m) = unsafeIOToST $ rowOp 2 0 i1' i2' j1 j2 m where (j1,j2) = getColRange (cols m) r i1' = i1 `mod` (rows m) i2' = i2 `mod` (rows m) extractMatrix :: Element a => STMatrix t a -> RowRange -> ColRange -> ST s (Matrix a) extractMatrix (STMatrix m) rr rc = unsafeIOToST (extractR (orderOf m) m 0 (idxs[i1,i2]) 0 (idxs[j1,j2])) where (i1,i2) = getRowRange (rows m) rr (j1,j2) = getColRange (cols m) rc -- | r0 c0 height width data Slice s t = Slice (STMatrix s t) Int Int Int Int slice :: Element a => Slice t a -> Matrix a slice (Slice (STMatrix m) r0 c0 nr nc) = subMatrix (r0,c0) (nr,nc) m gemmm :: Element t => t -> Slice s t -> t -> Slice s t -> Slice s t -> ST s () gemmm beta (slice->r) alpha (slice->a) (slice->b) = res where res = unsafeIOToST (gemm v a b r) v = fromList [alpha,beta] mutable :: Element t => (forall s . (Int, Int) -> STMatrix s t -> ST s u) -> Matrix t -> (Matrix t,u) mutable f a = runST $ do x <- thawMatrix a info <- f (rows a, cols a) x r <- unsafeFreezeMatrix x return (r,info) hmatrix-0.19.0.0/src/Internal/IO.hs0000644000000000000000000001330213260621005015001 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Internal.IO -- Copyright : (c) Alberto Ruiz 2010 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Display, formatting and IO functions for numeric 'Vector' and 'Matrix' -- ----------------------------------------------------------------------------- module Internal.IO ( dispf, disps, dispcf, vecdisp, latexFormat, format, loadMatrix, loadMatrix', saveMatrix ) where import Internal.Devel import Internal.Vector import Internal.Matrix import Internal.Vectorized import Text.Printf(printf, PrintfArg, PrintfType) import Data.List(intersperse,transpose) import Data.Complex -- | Formatting tool table :: String -> [[String]] -> String table sep as = unlines . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse sep {- | Creates a string from a matrix given a separator and a function to show each entry. Using this function the user can easily define any desired display function: @import Text.Printf(printf)@ @disp = putStr . format \" \" (printf \"%.2f\")@ -} format :: (Element t) => String -> (t -> String) -> Matrix t -> String format sep f m = table sep . map (map f) . toLists $ m {- | Show a matrix with \"autoscaling\" and a given number of decimal places. >>> putStr . disps 2 $ 120 * (3><4) [1..] 3x4 E3 0.12 0.24 0.36 0.48 0.60 0.72 0.84 0.96 1.08 1.20 1.32 1.44 -} disps :: Int -> Matrix Double -> String disps d x = sdims x ++ " " ++ formatScaled d x {- | Show a matrix with a given number of decimal places. >>> dispf 2 (1/3 + ident 3) "3x3\n1.33 0.33 0.33\n0.33 1.33 0.33\n0.33 0.33 1.33\n" >>> putStr . dispf 2 $ (3><4)[1,1.5..] 3x4 1.00 1.50 2.00 2.50 3.00 3.50 4.00 4.50 5.00 5.50 6.00 6.50 >>> putStr . unlines . tail . lines . dispf 2 . asRow $ linspace 10 (0,1) 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00 -} dispf :: Int -> Matrix Double -> String dispf d x = sdims x ++ "\n" ++ formatFixed (if isInt x then 0 else d) x sdims :: Matrix t -> [Char] sdims x = show (rows x) ++ "x" ++ show (cols x) formatFixed :: (Show a, Text.Printf.PrintfArg t, Element t) => a -> Matrix t -> String formatFixed d x = format " " (printf ("%."++show d++"f")) $ x isInt :: Matrix Double -> Bool isInt = all lookslikeInt . toList . flatten formatScaled :: (Text.Printf.PrintfArg b, RealFrac b, Floating b, Num t, Element b, Show t) => t -> Matrix b -> [Char] formatScaled dec t = "E"++show o++"\n" ++ ss where ss = format " " (printf fmt. g) t g x | o >= 0 = x/10^(o::Int) | otherwise = x*10^(-o) o | rows t == 0 || cols t == 0 = 0 | otherwise = floor $ maximum $ map (logBase 10 . abs) $ toList $ flatten t fmt = '%':show (dec+3) ++ '.':show dec ++"f" {- | Show a vector using a function for showing matrices. >>> putStr . vecdisp (dispf 2) $ linspace 10 (0,1) 10 |> 0.00 0.11 0.22 0.33 0.44 0.56 0.67 0.78 0.89 1.00 -} vecdisp :: (Element t) => (Matrix t -> String) -> Vector t -> String vecdisp f v = ((show (dim v) ++ " |> ") ++) . (++"\n") . unwords . lines . tail . dropWhile (not . (`elem` " \n")) . f . trans . reshape 1 $ v {- | Tool to display matrices with latex syntax. >>> latexFormat "bmatrix" (dispf 2 $ ident 2) "\\begin{bmatrix}\n1 & 0\n\\\\\n0 & 1\n\\end{bmatrix}" -} latexFormat :: String -- ^ type of braces: \"matrix\", \"bmatrix\", \"pmatrix\", etc. -> String -- ^ Formatted matrix, with elements separated by spaces and newlines -> String latexFormat del tab = "\\begin{"++del++"}\n" ++ f tab ++ "\\end{"++del++"}" where f = unlines . intersperse "\\\\" . map unwords . map (intersperse " & " . words) . tail . lines -- | Pretty print a complex number with at most n decimal digits. showComplex :: Int -> Complex Double -> String showComplex d (a:+b) | isZero a && isZero b = "0" | isZero b = sa | isZero a && isOne b = s2++"i" | isZero a = sb++"i" | isOne b = sa++s3++"i" | otherwise = sa++s1++sb++"i" where sa = shcr d a sb = shcr d b s1 = if b<0 then "" else "+" s2 = if b<0 then "-" else "" s3 = if b<0 then "-" else "+" shcr :: (Show a, Show t1, Text.Printf.PrintfType t, Text.Printf.PrintfArg t1, RealFrac t1) => a -> t1 -> t shcr d a | lookslikeInt a = printf "%.0f" a | otherwise = printf ("%."++show d++"f") a lookslikeInt :: (Show a, RealFrac a) => a -> Bool lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx where shx = show x isZero :: Show a => a -> Bool isZero x = show x `elem` ["0.0","-0.0"] isOne :: Show a => a -> Bool isOne x = show x `elem` ["1.0","-1.0"] -- | Pretty print a complex matrix with at most n decimal digits. dispcf :: Int -> Matrix (Complex Double) -> String dispcf d m = sdims m ++ "\n" ++ format " " (showComplex d) m -------------------------------------------------------------------- apparentCols :: FilePath -> IO Int apparentCols s = f . dropWhile null . map words . lines <$> readFile s where f [] = 0 f (x:_) = length x -- | load a matrix from an ASCII file formatted as a 2D table. loadMatrix :: FilePath -> IO (Matrix Double) loadMatrix f = do v <- vectorScan f c <- apparentCols f if (dim v `mod` c /= 0) then error $ printf "loadMatrix: %d elements and %d columns in file %s" (dim v) c f else return (reshape c v) loadMatrix' :: FilePath -> IO (Maybe (Matrix Double)) loadMatrix' name = mbCatch (loadMatrix name) hmatrix-0.19.0.0/src/Internal/Element.hs0000644000000000000000000004517313260621005016076 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Matrix -- Copyright : (c) Alberto Ruiz 2007-10 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- A Matrix representation suitable for numerical computations using LAPACK and GSL. -- -- This module provides basic functions for manipulation of structure. ----------------------------------------------------------------------------- module Internal.Element where import Internal.Vector import Internal.Matrix import Internal.Vectorized import qualified Internal.ST as ST import Data.Array import Text.Printf import Data.List(transpose,intersperse) import Data.List.Split(chunksOf) import Foreign.Storable(Storable) import System.IO.Unsafe(unsafePerformIO) import Control.Monad(liftM) import Foreign.C.Types(CInt) ------------------------------------------------------------------- import Data.Binary instance (Binary (Vector a), Element a) => Binary (Matrix a) where put m = do put (cols m) put (flatten m) get = do c <- get v <- get return (reshape c v) ------------------------------------------------------------------- instance (Show a, Element a) => (Show (Matrix a)) where show m | rows m == 0 || cols m == 0 = sizes m ++" []" show m = (sizes m++) . dsp . map (map show) . toLists $ m sizes :: Matrix t -> [Char] sizes m = "("++show (rows m)++"><"++show (cols m)++")\n" dsp :: [[[Char]]] -> [Char] dsp as = (++" ]") . (" ["++) . init . drop 2 . unlines . map (" , "++) . map unwords' $ transpose mtp where mt = transpose as longs = map (maximum . map length) mt mtp = zipWith (\a b -> map (pad a) b) longs mt pad n str = replicate (n - length str) ' ' ++ str unwords' = concat . intersperse ", " ------------------------------------------------------------------ instance (Element a, Read a) => Read (Matrix a) where readsPrec _ s = [((rs>' $ dims breakAt :: Eq a => a -> [a] -> ([a], [a]) breakAt c l = (a++[c],tail b) where (a,b) = break (==c) l -------------------------------------------------------------------------------- -- | Specification of indexes for the operator '??'. data Extractor = All | Range Int Int Int | Pos (Vector I) | PosCyc (Vector I) | Take Int | TakeLast Int | Drop Int | DropLast Int deriving Show ppext :: Extractor -> [Char] ppext All = ":" ppext (Range a 1 c) = printf "%d:%d" a c ppext (Range a b c) = printf "%d:%d:%d" a b c ppext (Pos v) = show (toList v) ppext (PosCyc v) = "Cyclic"++show (toList v) ppext (Take n) = printf "Take %d" n ppext (Drop n) = printf "Drop %d" n ppext (TakeLast n) = printf "TakeLast %d" n ppext (DropLast n) = printf "DropLast %d" n {- | General matrix slicing. >>> m (4><5) [ 0, 1, 2, 3, 4 , 5, 6, 7, 8, 9 , 10, 11, 12, 13, 14 , 15, 16, 17, 18, 19 ] >>> m ?? (Take 3, DropLast 2) (3><3) [ 0, 1, 2 , 5, 6, 7 , 10, 11, 12 ] >>> m ?? (Pos (idxs[2,1]), All) (2><5) [ 10, 11, 12, 13, 14 , 5, 6, 7, 8, 9 ] >>> m ?? (PosCyc (idxs[-7,80]), Range 4 (-2) 0) (2><3) [ 9, 7, 5 , 4, 2, 0 ] -} infixl 9 ?? (??) :: Element t => Matrix t -> (Extractor,Extractor) -> Matrix t minEl :: Vector CInt -> CInt minEl = toScalarI Min maxEl :: Vector CInt -> CInt maxEl = toScalarI Max cmodi :: Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt -> Vector Foreign.C.Types.CInt cmodi = vectorMapValI ModVS extractError :: Matrix t1 -> (Extractor, Extractor) -> t extractError m (e1,e2)= error $ printf "can't extract (%s,%s) from matrix %dx%d" (ppext e1::String) (ppext e2::String) (rows m) (cols m) m ?? (Range a s b,e) | s /= 1 = m ?? (Pos (idxs [a,a+s .. b]), e) m ?? (e,Range a s b) | s /= 1 = m ?? (e, Pos (idxs [a,a+s .. b])) m ?? e@(Range a _ b,_) | a < 0 || b >= rows m = extractError m e m ?? e@(_,Range a _ b) | a < 0 || b >= cols m = extractError m e m ?? e@(Pos vs,_) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (rows m)) = extractError m e m ?? e@(_,Pos vs) | dim vs>0 && (minEl vs < 0 || maxEl vs >= fi (cols m)) = extractError m e m ?? (All,All) = m m ?? (Range a _ b,e) | a > b = m ?? (Take 0,e) m ?? (e,Range a _ b) | a > b = m ?? (e,Take 0) m ?? (Take n,e) | n <= 0 = (0>= rows m = m ?? (All,e) m ?? (e,Take n) | n <= 0 = (rows m><0) [] ?? (e,All) | n >= cols m = m ?? (e,All) m ?? (Drop n,e) | n <= 0 = m ?? (All,e) | n >= rows m = (0>= cols m = (rows m><0) [] ?? (e,All) m ?? (TakeLast n, e) = m ?? (Drop (rows m - n), e) m ?? (e, TakeLast n) = m ?? (e, Drop (cols m - n)) m ?? (DropLast n, e) = m ?? (Take (rows m - n), e) m ?? (e, DropLast n) = m ?? (e, Take (cols m - n)) m ?? (er,ec) = unsafePerformIO $ extractR (orderOf m) m moder rs modec cs where (moder,rs) = mkExt (rows m) er (modec,cs) = mkExt (cols m) ec ran a b = (0, idxs [a,b]) pos ks = (1, ks) mkExt _ (Pos ks) = pos ks mkExt n (PosCyc ks) | n == 0 = mkExt n (Take 0) | otherwise = pos (cmodi (fi n) ks) mkExt _ (Range mn _ mx) = ran mn mx mkExt _ (Take k) = ran 0 (k-1) mkExt n (Drop k) = ran k (n-1) mkExt n _ = ran 0 (n-1) -- All -------------------------------------------------------------------------------- -- | obtains the common value of a property of a list common :: (Eq a) => (b->a) -> [b] -> Maybe a common f = commonval . map f where commonval :: (Eq a) => [a] -> Maybe a commonval [] = Nothing commonval [a] = Just a commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing -- | creates a matrix from a vertical list of matrices joinVert :: Element t => [Matrix t] -> Matrix t joinVert [] = emptyM 0 0 joinVert ms = case common cols ms of Nothing -> error "(impossible) joinVert on matrices with different number of columns" Just c -> matrixFromVector RowMajor (sum (map rows ms)) c $ vjoin (map flatten ms) -- | creates a matrix from a horizontal list of matrices joinHoriz :: Element t => [Matrix t] -> Matrix t joinHoriz ms = trans. joinVert . map trans $ ms {- | Create a matrix from blocks given as a list of lists of matrices. Single row-column components are automatically expanded to match the corresponding common row and column: @ disp = putStr . dispf 2 @ >>> disp $ fromBlocks [[ident 5, 7, row[10,20]], [3, diagl[1,2,3], 0]] 8x10 1 0 0 0 0 7 7 7 10 20 0 1 0 0 0 7 7 7 10 20 0 0 1 0 0 7 7 7 10 20 0 0 0 1 0 7 7 7 10 20 0 0 0 0 1 7 7 7 10 20 3 3 3 3 3 1 0 0 0 0 3 3 3 3 3 0 2 0 0 0 3 3 3 3 3 0 0 3 0 0 -} fromBlocks :: Element t => [[Matrix t]] -> Matrix t fromBlocks = fromBlocksRaw . adaptBlocks fromBlocksRaw :: Element t => [[Matrix t]] -> Matrix t fromBlocksRaw mms = joinVert . map joinHoriz $ mms adaptBlocks :: Element t => [[Matrix t]] -> [[Matrix t]] adaptBlocks ms = ms' where bc = case common length ms of Just c -> c Nothing -> error "fromBlocks requires rectangular [[Matrix]]" rs = map (compatdim . map rows) ms cs = map (compatdim . map cols) (transpose ms) szs = sequence [rs,cs] ms' = chunksOf bc $ zipWith g szs (concat ms) g [Just nr,Just nc] m | nr == r && nc == c = m | r == 1 && c == 1 = matrixFromVector RowMajor nr nc (constantD x (nr*nc)) | r == 1 = fromRows (replicate nr (flatten m)) | otherwise = fromColumns (replicate nc (flatten m)) where r = rows m c = cols m x = m@@>(0,0) g _ _ = error "inconsistent dimensions in fromBlocks" -------------------------------------------------------------------------------- {- | create a block diagonal matrix >>> disp 2 $ diagBlock [konst 1 (2,2), konst 2 (3,5), col [5,7]] 7x8 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 0 0 0 2 2 2 2 2 0 0 0 0 0 0 0 0 5 0 0 0 0 0 0 0 7 >>> diagBlock [(0><4)[], konst 2 (2,3)] :: Matrix Double (2><7) [ 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 , 0.0, 0.0, 0.0, 0.0, 2.0, 2.0, 2.0 ] -} diagBlock :: (Element t, Num t) => [Matrix t] -> Matrix t diagBlock ms = fromBlocks $ zipWith f ms [0..] where f m k = take n $ replicate k z ++ m : repeat z n = length ms z = (1><1) [0] -------------------------------------------------------------------------------- -- | Reverse rows flipud :: Element t => Matrix t -> Matrix t flipud m = extractRows [r-1,r-2 .. 0] $ m where r = rows m -- | Reverse columns fliprl :: Element t => Matrix t -> Matrix t fliprl m = extractColumns [c-1,c-2 .. 0] $ m where c = cols m ------------------------------------------------------------ {- | creates a rectangular diagonal matrix: >>> diagRect 7 (fromList [10,20,30]) 4 5 :: Matrix Double (4><5) [ 10.0, 7.0, 7.0, 7.0, 7.0 , 7.0, 20.0, 7.0, 7.0, 7.0 , 7.0, 7.0, 30.0, 7.0, 7.0 , 7.0, 7.0, 7.0, 7.0, 7.0 ] -} diagRect :: (Storable t) => t -> Vector t -> Int -> Int -> Matrix t diagRect z v r c = ST.runSTMatrix $ do m <- ST.newMatrix z r c let d = min r c `min` (dim v) mapM_ (\k -> ST.writeMatrix m k k (v@>k)) [0..d-1] return m -- | extracts the diagonal from a rectangular matrix takeDiag :: (Element t) => Matrix t -> Vector t takeDiag m = fromList [flatten m @> (k*cols m+k) | k <- [0 .. min (rows m) (cols m) -1]] ------------------------------------------------------------ {- | Create a matrix from a list of elements >>> (2><3) [2, 4, 7+2*iC, -3, 11, 0] (2><3) [ 2.0 :+ 0.0, 4.0 :+ 0.0, 7.0 :+ 2.0 , (-3.0) :+ (-0.0), 11.0 :+ 0.0, 0.0 :+ 0.0 ] The input list is explicitly truncated, so that it can safely be used with lists that are too long (like infinite lists). >>> (2><3)[1..] (2><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 ] This is the format produced by the instances of Show (Matrix a), which can also be used for input. -} (><) :: (Storable a) => Int -> Int -> [a] -> Matrix a r >< c = f where f l | dim v == r*c = matrixFromVector RowMajor r c v | otherwise = error $ "inconsistent list size = " ++show (dim v) ++" in ("++show r++"><"++show c++")" where v = fromList $ take (r*c) l ---------------------------------------------------------------- takeRows :: Element t => Int -> Matrix t -> Matrix t takeRows n mt = subMatrix (0,0) (n, cols mt) mt -- | Creates a matrix with the last n rows of another matrix takeLastRows :: Element t => Int -> Matrix t -> Matrix t takeLastRows n mt = subMatrix (rows mt - n, 0) (n, cols mt) mt dropRows :: Element t => Int -> Matrix t -> Matrix t dropRows n mt = subMatrix (n,0) (rows mt - n, cols mt) mt -- | Creates a copy of a matrix without the last n rows dropLastRows :: Element t => Int -> Matrix t -> Matrix t dropLastRows n mt = subMatrix (0,0) (rows mt - n, cols mt) mt takeColumns :: Element t => Int -> Matrix t -> Matrix t takeColumns n mt = subMatrix (0,0) (rows mt, n) mt -- |Creates a matrix with the last n columns of another matrix takeLastColumns :: Element t => Int -> Matrix t -> Matrix t takeLastColumns n mt = subMatrix (0, cols mt - n) (rows mt, n) mt dropColumns :: Element t => Int -> Matrix t -> Matrix t dropColumns n mt = subMatrix (0,n) (rows mt, cols mt - n) mt -- | Creates a copy of a matrix without the last n columns dropLastColumns :: Element t => Int -> Matrix t -> Matrix t dropLastColumns n mt = subMatrix (0,0) (rows mt, cols mt - n) mt ---------------------------------------------------------------- {- | Creates a 'Matrix' from a list of lists (considered as rows). >>> fromLists [[1,2],[3,4],[5,6]] (3><2) [ 1.0, 2.0 , 3.0, 4.0 , 5.0, 6.0 ] -} fromLists :: Element t => [[t]] -> Matrix t fromLists = fromRows . map fromList -- | creates a 1-row matrix from a vector -- -- >>> asRow (fromList [1..5]) -- (1><5) -- [ 1.0, 2.0, 3.0, 4.0, 5.0 ] -- asRow :: Storable a => Vector a -> Matrix a asRow = trans . asColumn -- | creates a 1-column matrix from a vector -- -- >>> asColumn (fromList [1..5]) -- (5><1) -- [ 1.0 -- , 2.0 -- , 3.0 -- , 4.0 -- , 5.0 ] -- asColumn :: Storable a => Vector a -> Matrix a asColumn v = reshape 1 v {- | creates a Matrix of the specified size using the supplied function to to map the row\/column position to the value at that row\/column position. @> buildMatrix 3 4 (\\(r,c) -> fromIntegral r * fromIntegral c) (3><4) [ 0.0, 0.0, 0.0, 0.0, 0.0 , 0.0, 1.0, 2.0, 3.0, 4.0 , 0.0, 2.0, 4.0, 6.0, 8.0]@ Hilbert matrix of order N: @hilb n = buildMatrix n n (\\(i,j)->1/(fromIntegral i + fromIntegral j +1))@ -} buildMatrix :: Element a => Int -> Int -> ((Int, Int) -> a) -> Matrix a buildMatrix rc cc f = fromLists $ map (map f) $ map (\ ri -> map (\ ci -> (ri, ci)) [0 .. (cc - 1)]) [0 .. (rc - 1)] ----------------------------------------------------- fromArray2D :: (Storable e) => Array (Int, Int) e -> Matrix e fromArray2D m = (r> [Int] -> Matrix t -> Matrix t extractRows l m = m ?? (Pos (idxs l), All) -- | rearranges the rows of a matrix according to the order given in a list of integers. extractColumns :: Element t => [Int] -> Matrix t -> Matrix t extractColumns l m = m ?? (All, Pos (idxs l)) {- | creates matrix by repetition of a matrix a given number of rows and columns >>> repmat (ident 2) 2 3 (4><6) [ 1.0, 0.0, 1.0, 0.0, 1.0, 0.0 , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 , 1.0, 0.0, 1.0, 0.0, 1.0, 0.0 , 0.0, 1.0, 0.0, 1.0, 0.0, 1.0 ] -} repmat :: (Element t) => Matrix t -> Int -> Int -> Matrix t repmat m r c | r == 0 || c == 0 = emptyM (r*rows m) (c*cols m) | otherwise = fromBlocks $ replicate r $ replicate c $ m -- | A version of 'liftMatrix2' which automatically adapt matrices with a single row or column to match the dimensions of the other matrix. liftMatrix2Auto :: (Element t, Element a, Element b) => (Vector a -> Vector b -> Vector t) -> Matrix a -> Matrix b -> Matrix t liftMatrix2Auto f m1 m2 | compat' m1 m2 = lM f m1 m2 | ok = lM f m1' m2' | otherwise = error $ "nonconformable matrices in liftMatrix2Auto: " ++ shSize m1 ++ ", " ++ shSize m2 where (r1,c1) = size m1 (r2,c2) = size m2 r = max r1 r2 c = max c1 c2 r0 = min r1 r2 c0 = min c1 c2 ok = r0 == 1 || r1 == r2 && c0 == 1 || c1 == c2 m1' = conformMTo (r,c) m1 m2' = conformMTo (r,c) m2 -- FIXME do not flatten if equal order lM :: (Storable t, Element t1, Element t2) => (Vector t1 -> Vector t2 -> Vector t) -> Matrix t1 -> Matrix t2 -> Matrix t lM f m1 m2 = matrixFromVector RowMajor (max' (rows m1) (rows m2)) (max' (cols m1) (cols m2)) (f (flatten m1) (flatten m2)) where max' 1 b = b max' a 1 = a max' a b = max a b compat' :: Matrix a -> Matrix b -> Bool compat' m1 m2 = s1 == (1,1) || s2 == (1,1) || s1 == s2 where s1 = size m1 s2 = size m2 ------------------------------------------------------------ toBlockRows :: Element t => [Int] -> Matrix t -> [Matrix t] toBlockRows [r] m | r == rows m = [m] toBlockRows rs m | cols m > 0 = map (reshape (cols m)) (takesV szs (flatten m)) | otherwise = map g rs where szs = map (* cols m) rs g k = (k><0)[] toBlockCols :: Element t => [Int] -> Matrix t -> [Matrix t] toBlockCols [c] m | c == cols m = [m] toBlockCols cs m = map trans . toBlockRows cs . trans $ m -- | Partition a matrix into blocks with the given numbers of rows and columns. -- The remaining rows and columns are discarded. toBlocks :: (Element t) => [Int] -> [Int] -> Matrix t -> [[Matrix t]] toBlocks rs cs m | ok = map (toBlockCols cs) . toBlockRows rs $ m | otherwise = error $ "toBlocks: bad partition: "++show rs++" "++show cs ++ " "++shSize m where ok = sum rs <= rows m && sum cs <= cols m && all (>=0) rs && all (>=0) cs -- | Fully partition a matrix into blocks of the same size. If the dimensions are not -- a multiple of the given size the last blocks will be smaller. toBlocksEvery :: (Element t) => Int -> Int -> Matrix t -> [[Matrix t]] toBlocksEvery r c m | r < 1 || c < 1 = error $ "toBlocksEvery expects block sizes > 0, given "++show r++" and "++ show c | otherwise = toBlocks rs cs m where (qr,rr) = rows m `divMod` r (qc,rc) = cols m `divMod` c rs = replicate qr r ++ if rr > 0 then [rr] else [] cs = replicate qc c ++ if rc > 0 then [rc] else [] ------------------------------------------------------------------- -- Given a column number and a function taking matrix indexes, returns -- a function which takes vector indexes (that can be used on the -- flattened matrix). mk :: Int -> ((Int, Int) -> t) -> (Int -> t) mk c g = \k -> g (divMod k c) {- | >>> mapMatrixWithIndexM_ (\(i,j) v -> printf "m[%d,%d] = %.f\n" i j v :: IO()) ((2><3)[1 :: Double ..]) m[0,0] = 1 m[0,1] = 2 m[0,2] = 3 m[1,0] = 4 m[1,1] = 5 m[1,2] = 6 -} mapMatrixWithIndexM_ :: (Element a, Num a, Monad m) => ((Int, Int) -> a -> m ()) -> Matrix a -> m () mapMatrixWithIndexM_ g m = mapVectorWithIndexM_ (mk c g) . flatten $ m where c = cols m {- | >>> mapMatrixWithIndexM (\(i,j) v -> Just $ 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double) Just (3><3) [ 100.0, 1.0, 2.0 , 10.0, 111.0, 12.0 , 20.0, 21.0, 122.0 ] -} mapMatrixWithIndexM :: (Element a, Storable b, Monad m) => ((Int, Int) -> a -> m b) -> Matrix a -> m (Matrix b) mapMatrixWithIndexM g m = liftM (reshape c) . mapVectorWithIndexM (mk c g) . flatten $ m where c = cols m {- | >>> mapMatrixWithIndex (\(i,j) v -> 100*v + 10*fromIntegral i + fromIntegral j) (ident 3:: Matrix Double) (3><3) [ 100.0, 1.0, 2.0 , 10.0, 111.0, 12.0 , 20.0, 21.0, 122.0 ] -} mapMatrixWithIndex :: (Element a, Storable b) => ((Int, Int) -> a -> b) -> Matrix a -> Matrix b mapMatrixWithIndex g m = reshape c . mapVectorWithIndex (mk c g) . flatten $ m where c = cols m mapMatrix :: (Element a, Element b) => (a -> b) -> Matrix a -> Matrix b mapMatrix f = liftMatrix (mapVector f) hmatrix-0.19.0.0/src/Internal/Conversion.hs0000644000000000000000000000542613223170642016634 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Conversion -- Copyright : (c) Alberto Ruiz 2010 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Conversion routines -- ----------------------------------------------------------------------------- module Internal.Conversion ( Complexable(..), RealElement, module Data.Complex ) where import Internal.Vector import Internal.Matrix import Internal.Vectorized import Data.Complex import Control.Arrow((***)) ------------------------------------------------------------------- -- | Supported single-double precision type pairs class (Element s, Element d) => Precision s d | s -> d, d -> s where double2FloatG :: Vector d -> Vector s float2DoubleG :: Vector s -> Vector d instance Precision Float Double where double2FloatG = double2FloatV float2DoubleG = float2DoubleV instance Precision (Complex Float) (Complex Double) where double2FloatG = asComplex . double2FloatV . asReal float2DoubleG = asComplex . float2DoubleV . asReal instance Precision I Z where double2FloatG = long2intV float2DoubleG = int2longV -- | Supported real types class (Element t, Element (Complex t), RealFloat t) => RealElement t instance RealElement Double instance RealElement Float -- | Structures that may contain complex numbers class Complexable c where toComplex' :: (RealElement e) => (c e, c e) -> c (Complex e) fromComplex' :: (RealElement e) => c (Complex e) -> (c e, c e) comp' :: (RealElement e) => c e -> c (Complex e) single' :: Precision a b => c b -> c a double' :: Precision a b => c a -> c b instance Complexable Vector where toComplex' = toComplexV fromComplex' = fromComplexV comp' v = toComplex' (v,constantD 0 (dim v)) single' = double2FloatG double' = float2DoubleG -- | creates a complex vector from vectors with real and imaginary parts toComplexV :: (RealElement a) => (Vector a, Vector a) -> Vector (Complex a) toComplexV (r,i) = asComplex $ flatten $ fromColumns [r,i] -- | the inverse of 'toComplex' fromComplexV :: (RealElement a) => Vector (Complex a) -> (Vector a, Vector a) fromComplexV z = (r,i) where [r,i] = toColumns $ reshape 2 $ asReal z instance Complexable Matrix where toComplex' = uncurry $ liftMatrix2 $ curry toComplex' fromComplex' z = (reshape c *** reshape c) . fromComplex' . flatten $ z where c = cols z comp' = liftMatrix comp' single' = liftMatrix single' double' = liftMatrix double' hmatrix-0.19.0.0/src/Internal/LAPACK.hs0000644000000000000000000006671513260621005015445 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.LinearAlgebra.LAPACK -- Copyright : (c) Alberto Ruiz 2006-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Functional interface to selected LAPACK functions (). -- ----------------------------------------------------------------------------- module Internal.LAPACK where import Internal.Devel import Internal.Vector import Internal.Matrix hiding ((#), (#!)) import Internal.Conversion import Internal.Element import Foreign.Ptr(nullPtr) import Foreign.C.Types import Control.Monad(when) import System.IO.Unsafe(unsafePerformIO) ----------------------------------------------------------------------------------- infixr 1 # a # b = apply a b {-# INLINE (#) #-} a #! b = a # b # id {-# INLINE (#!) #-} ----------------------------------------------------------------------------------- type TMMM t = t ::> t ::> t ::> Ok type F = Float type Q = Complex Float foreign import ccall unsafe "multiplyR" dgemmc :: CInt -> CInt -> TMMM R foreign import ccall unsafe "multiplyC" zgemmc :: CInt -> CInt -> TMMM C foreign import ccall unsafe "multiplyF" sgemmc :: CInt -> CInt -> TMMM F foreign import ccall unsafe "multiplyQ" cgemmc :: CInt -> CInt -> TMMM Q foreign import ccall unsafe "multiplyI" c_multiplyI :: I -> TMMM I foreign import ccall unsafe "multiplyL" c_multiplyL :: Z -> TMMM Z isT (rowOrder -> False) = 0 isT _ = 1 tt x@(rowOrder -> False) = x tt x = trans x multiplyAux f st a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ show (rows a,cols a) ++ " x " ++ show (rows b, cols b) s <- createMatrix ColumnMajor (rows a) (cols b) ((tt a) # (tt b) #! s) (f (isT a) (isT b)) #| st return s -- | Matrix product based on BLAS's /dgemm/. multiplyR :: Matrix Double -> Matrix Double -> Matrix Double multiplyR a b = {-# SCC "multiplyR" #-} multiplyAux dgemmc "dgemmc" a b -- | Matrix product based on BLAS's /zgemm/. multiplyC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) multiplyC a b = multiplyAux zgemmc "zgemmc" a b -- | Matrix product based on BLAS's /sgemm/. multiplyF :: Matrix Float -> Matrix Float -> Matrix Float multiplyF a b = multiplyAux sgemmc "sgemmc" a b -- | Matrix product based on BLAS's /cgemm/. multiplyQ :: Matrix (Complex Float) -> Matrix (Complex Float) -> Matrix (Complex Float) multiplyQ a b = multiplyAux cgemmc "cgemmc" a b multiplyI :: I -> Matrix CInt -> Matrix CInt -> Matrix CInt multiplyI m a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b s <- createMatrix ColumnMajor (rows a) (cols b) (a # b #! s) (c_multiplyI m) #|"c_multiplyI" return s multiplyL :: Z -> Matrix Z -> Matrix Z -> Matrix Z multiplyL m a b = unsafePerformIO $ do when (cols a /= rows b) $ error $ "inconsistent dimensions in matrix product "++ shSize a ++ " x " ++ shSize b s <- createMatrix ColumnMajor (rows a) (cols b) (a # b #! s) (c_multiplyL m) #|"c_multiplyL" return s ----------------------------------------------------------------------------- type TSVD t = t ::> t ::> R :> t ::> Ok foreign import ccall unsafe "svd_l_R" dgesvd :: TSVD R foreign import ccall unsafe "svd_l_C" zgesvd :: TSVD C foreign import ccall unsafe "svd_l_Rdd" dgesdd :: TSVD R foreign import ccall unsafe "svd_l_Cdd" zgesdd :: TSVD C -- | Full SVD of a real matrix using LAPACK's /dgesvd/. svdR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdR = svdAux dgesvd "svdR" -- | Full SVD of a real matrix using LAPACK's /dgesdd/. svdRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) svdRd = svdAux dgesdd "svdRdd" -- | Full SVD of a complex matrix using LAPACK's /zgesvd/. svdC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdC = svdAux zgesvd "svdC" -- | Full SVD of a complex matrix using LAPACK's /zgesdd/. svdCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) svdCd = svdAux zgesdd "svdCdd" svdAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r r s <- createVector (min r c) v <- createMatrix ColumnMajor c c (a # u # s #! v) f #| st return (u,s,v) where r = rows x c = cols x -- | Thin SVD of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'S\'. thinSVDR :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDR = thinSVDAux dgesvd "thinSVDR" -- | Thin SVD of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'S\'. thinSVDC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDC = thinSVDAux zgesvd "thinSVDC" -- | Thin SVD of a real matrix, using LAPACK's /dgesdd/ with jobz == \'S\'. thinSVDRd :: Matrix Double -> (Matrix Double, Vector Double, Matrix Double) thinSVDRd = thinSVDAux dgesdd "thinSVDRdd" -- | Thin SVD of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'S\'. thinSVDCd :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double, Matrix (Complex Double)) thinSVDCd = thinSVDAux zgesdd "thinSVDCdd" thinSVDAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r q s <- createVector q v <- createMatrix ColumnMajor q c (a # u # s #! v) f #| st return (u,s,v) where r = rows x c = cols x q = min r c -- | Singular values of a real matrix, using LAPACK's /dgesvd/ with jobu == jobvt == \'N\'. svR :: Matrix Double -> Vector Double svR = svAux dgesvd "svR" -- | Singular values of a complex matrix, using LAPACK's /zgesvd/ with jobu == jobvt == \'N\'. svC :: Matrix (Complex Double) -> Vector Double svC = svAux zgesvd "svC" -- | Singular values of a real matrix, using LAPACK's /dgesdd/ with jobz == \'N\'. svRd :: Matrix Double -> Vector Double svRd = svAux dgesdd "svRd" -- | Singular values of a complex matrix, using LAPACK's /zgesdd/ with jobz == \'N\'. svCd :: Matrix (Complex Double) -> Vector Double svCd = svAux zgesdd "svCd" svAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x s <- createVector q (a #! s) g #| st return s where r = rows x c = cols x q = min r c g ra ca xra xca pa nb pb = f ra ca xra xca pa 0 0 0 0 nullPtr nb pb 0 0 0 0 nullPtr -- | Singular values and all right singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVR :: Matrix Double -> (Vector Double, Matrix Double) rightSVR = rightSVAux dgesvd "rightSVR" -- | Singular values and all right singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'N\' and jobvt == \'A\'. rightSVC :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) rightSVC = rightSVAux zgesvd "rightSVC" rightSVAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x s <- createVector q v <- createMatrix ColumnMajor c c (a # s #! v) g #| st return (s,v) where r = rows x c = cols x q = min r c g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr -- | Singular values and all left singular vectors of a real matrix, using LAPACK's /dgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVR :: Matrix Double -> (Matrix Double, Vector Double) leftSVR = leftSVAux dgesvd "leftSVR" -- | Singular values and all left singular vectors of a complex matrix, using LAPACK's /zgesvd/ with jobu == \'A\' and jobvt == \'N\'. leftSVC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector Double) leftSVC = leftSVAux zgesvd "leftSVC" leftSVAux f st x = unsafePerformIO $ do a <- copy ColumnMajor x u <- createMatrix ColumnMajor r r s <- createVector q (a # u #! s) g #| st return (u,s) where r = rows x c = cols x q = min r c g ra ca xra xca pa ru cu xru xcu pu nb pb = f ra ca xra xca pa ru cu xru xcu pu nb pb 0 0 0 0 nullPtr ----------------------------------------------------------------------------- foreign import ccall unsafe "eig_l_R" dgeev :: R ::> R ::> C :> R ::> Ok foreign import ccall unsafe "eig_l_C" zgeev :: C ::> C ::> C :> C ::> Ok foreign import ccall unsafe "eig_l_S" dsyev :: CInt -> R :> R ::> Ok foreign import ccall unsafe "eig_l_H" zheev :: CInt -> R :> C ::> Ok eigAux f st m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r v <- createMatrix ColumnMajor r r (a # l #! v) g #| st return (l,v) where r = rows m g ra ca xra xca pa = f ra ca xra xca pa 0 0 0 0 nullPtr -- | Eigenvalues and right eigenvectors of a general complex matrix, using LAPACK's /zgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigC :: Matrix (Complex Double) -> (Vector (Complex Double), Matrix (Complex Double)) eigC = eigAux zgeev "eigC" eigOnlyAux f st m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r (a #! l) g #| st return l where r = rows m g ra ca xra xca pa nl pl = f ra ca xra xca pa 0 0 0 0 nullPtr nl pl 0 0 0 0 nullPtr -- | Eigenvalues of a general complex matrix, using LAPACK's /zgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyC :: Matrix (Complex Double) -> Vector (Complex Double) eigOnlyC = eigOnlyAux zgeev "eigOnlyC" -- | Eigenvalues and right eigenvectors of a general real matrix, using LAPACK's /dgeev/. -- The eigenvectors are the columns of v. The eigenvalues are not sorted. eigR :: Matrix Double -> (Vector (Complex Double), Matrix (Complex Double)) eigR m = (s', v'') where (s,v) = eigRaux m s' = fixeig1 s v' = toRows $ trans v v'' = fromColumns $ fixeig (toList s') v' eigRaux :: Matrix Double -> (Vector (Complex Double), Matrix Double) eigRaux m = unsafePerformIO $ do a <- copy ColumnMajor m l <- createVector r v <- createMatrix ColumnMajor r r (a # l #! v) g #| "eigR" return (l,v) where r = rows m g ra ca xra xca pa = dgeev ra ca xra xca pa 0 0 0 0 nullPtr fixeig1 s = toComplex' (subVector 0 r (asReal s), subVector r r (asReal s)) where r = dim s fixeig [] _ = [] fixeig [_] [v] = [comp' v] fixeig ((r1:+i1):(r2:+i2):r) (v1:v2:vs) | r1 == r2 && i1 == (-i2) = toComplex' (v1,v2) : toComplex' (v1, mapVector negate v2) : fixeig r vs | otherwise = comp' v1 : fixeig ((r2:+i2):r) (v2:vs) fixeig _ _ = error "fixeig with impossible inputs" -- | Eigenvalues of a general real matrix, using LAPACK's /dgeev/ with jobz == \'N\'. -- The eigenvalues are not sorted. eigOnlyR :: Matrix Double -> Vector (Complex Double) eigOnlyR = fixeig1 . eigOnlyAux dgeev "eigOnlyR" ----------------------------------------------------------------------------- eigSHAux f st m = unsafePerformIO $ do l <- createVector r v <- copy ColumnMajor m (l #! v) f #| st return (l,v) where r = rows m -- | Eigenvalues and right eigenvectors of a symmetric real matrix, using LAPACK's /dsyev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigS'' for ascending order). eigS :: Matrix Double -> (Vector Double, Matrix Double) eigS m = (s', fliprl v) where (s,v) = eigS' m s' = fromList . reverse . toList $ s -- | 'eigS' in ascending order eigS' :: Matrix Double -> (Vector Double, Matrix Double) eigS' = eigSHAux (dsyev 1) "eigS'" -- | Eigenvalues and right eigenvectors of a hermitian complex matrix, using LAPACK's /zheev/. -- The eigenvectors are the columns of v. -- The eigenvalues are sorted in descending order (use 'eigH'' for ascending order). eigH :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH m = (s', fliprl v) where (s,v) = eigH' m s' = fromList . reverse . toList $ s -- | 'eigH' in ascending order eigH' :: Matrix (Complex Double) -> (Vector Double, Matrix (Complex Double)) eigH' = eigSHAux (zheev 1) "eigH'" -- | Eigenvalues of a symmetric real matrix, using LAPACK's /dsyev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyS :: Matrix Double -> Vector Double eigOnlyS = vrev . fst. eigSHAux (dsyev 0) "eigS'" -- | Eigenvalues of a hermitian complex matrix, using LAPACK's /zheev/ with jobz == \'N\'. -- The eigenvalues are sorted in descending order. eigOnlyH :: Matrix (Complex Double) -> Vector Double eigOnlyH = vrev . fst. eigSHAux (zheev 0) "eigH'" vrev = flatten . flipud . reshape 1 ----------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveR_l" dgesv :: R ::> R ::> Ok foreign import ccall unsafe "linearSolveC_l" zgesv :: C ::> C ::> Ok linearSolveSQAux g f st a b | n1==n2 && n1==r = unsafePerformIO . g $ do a' <- copy ColumnMajor a s <- copy ColumnMajor b (a' #! s) f #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b -- | Solve a real linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /dgesv/. For underconstrained or overconstrained systems use 'linearSolveLSR' or 'linearSolveSVDR'. See also 'lusR'. linearSolveR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveR a b = linearSolveSQAux id dgesv "linearSolveR" a b mbLinearSolveR :: Matrix Double -> Matrix Double -> Maybe (Matrix Double) mbLinearSolveR a b = linearSolveSQAux mbCatch dgesv "linearSolveR" a b -- | Solve a complex linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, based on LAPACK's /zgesv/. For underconstrained or overconstrained systems use 'linearSolveLSC' or 'linearSolveSVDC'. See also 'lusC'. linearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveC a b = linearSolveSQAux id zgesv "linearSolveC" a b mbLinearSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Maybe (Matrix (Complex Double)) mbLinearSolveC a b = linearSolveSQAux mbCatch zgesv "linearSolveC" a b -------------------------------------------------------------------------------- foreign import ccall unsafe "cholSolveR_l" dpotrs :: R ::> R ::> Ok foreign import ccall unsafe "cholSolveC_l" zpotrs :: C ::> C ::> Ok linearSolveSQAux2 g f st a b | n1==n2 && n1==r = unsafePerformIO . g $ do s <- copy ColumnMajor b (a #! s) f #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b -- | Solves a symmetric positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholS'. cholSolveR :: Matrix Double -> Matrix Double -> Matrix Double cholSolveR a b = linearSolveSQAux2 id dpotrs "cholSolveR" (fmat a) b -- | Solves a Hermitian positive definite system of linear equations using a precomputed Cholesky factorization obtained by 'cholH'. cholSolveC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) cholSolveC a b = linearSolveSQAux2 id zpotrs "cholSolveC" (fmat a) b -------------------------------------------------------------------------------- foreign import ccall unsafe "triSolveR_l_u" dtrtrs_u :: R ::> R ::> Ok foreign import ccall unsafe "triSolveC_l_u" ztrtrs_u :: C ::> C ::> Ok foreign import ccall unsafe "triSolveR_l_l" dtrtrs_l :: R ::> R ::> Ok foreign import ccall unsafe "triSolveC_l_l" ztrtrs_l :: C ::> C ::> Ok linearSolveTRAux2 g f st a b | n1==n2 && n1==r = unsafePerformIO . g $ do s <- copy ColumnMajor b (a #! s) f #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where n1 = rows a n2 = cols a r = rows b data UpLo = Lower | Upper -- | Solves a triangular system of linear equations. triSolveR :: UpLo -> Matrix Double -> Matrix Double -> Matrix Double triSolveR Lower a b = linearSolveTRAux2 id dtrtrs_l "triSolveR" (fmat a) b triSolveR Upper a b = linearSolveTRAux2 id dtrtrs_u "triSolveR" (fmat a) b -- | Solves a triangular system of linear equations. triSolveC :: UpLo -> Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) triSolveC Lower a b = linearSolveTRAux2 id ztrtrs_l "triSolveC" (fmat a) b triSolveC Upper a b = linearSolveTRAux2 id ztrtrs_u "triSolveC" (fmat a) b -------------------------------------------------------------------------------- foreign import ccall unsafe "triDiagSolveR_l" dgttrs :: R :> R :> R :> R ::> Ok foreign import ccall unsafe "triDiagSolveC_l" zgttrs :: C :> C :> C :> C ::> Ok linearSolveGTAux2 g f st dl d du b | ndl == nd - 1 && ndu == nd - 1 && nd == r = unsafePerformIO . g $ do s <- copy ColumnMajor b (dl # d # du #! s) f #| st return s | otherwise = error $ st ++ " of nonsquare matrix" where ndl = dim dl nd = dim d ndu = dim du r = rows b -- | Solves a tridiagonal system of linear equations. triDiagSolveR dl d du b = linearSolveGTAux2 id dgttrs "triDiagSolveR" dl d du b triDiagSolveC dl d du b = linearSolveGTAux2 id zgttrs "triDiagSolveC" dl d du b ----------------------------------------------------------------------------------- foreign import ccall unsafe "linearSolveLSR_l" dgels :: R ::> R ::> Ok foreign import ccall unsafe "linearSolveLSC_l" zgels :: C ::> C ::> Ok foreign import ccall unsafe "linearSolveSVDR_l" dgelss :: Double -> R ::> R ::> Ok foreign import ccall unsafe "linearSolveSVDC_l" zgelss :: Double -> C ::> C ::> Ok linearSolveAux f st a b | m == rows b = unsafePerformIO $ do a' <- copy ColumnMajor a r <- createMatrix ColumnMajor (max m n) nrhs setRect 0 0 b r (a' #! r) f #| st return r | otherwise = error $ "different number of rows in linearSolve ("++st++")" where m = rows a n = cols a nrhs = cols b -- | Least squared error solution of an overconstrained real linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /dgels/. For rank-deficient systems use 'linearSolveSVDR'. linearSolveLSR :: Matrix Double -> Matrix Double -> Matrix Double linearSolveLSR a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux dgels "linearSolverLSR" a b -- | Least squared error solution of an overconstrained complex linear system, or the minimum norm solution of an underconstrained system, using LAPACK's /zgels/. For rank-deficient systems use 'linearSolveSVDC'. linearSolveLSC :: Matrix (Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) linearSolveLSC a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux zgels "linearSolveLSC" a b -- | Minimum norm solution of a general real linear least squares problem Ax=B using the SVD, based on LAPACK's /dgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSR'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDR :: Maybe Double -- ^ rcond -> Matrix Double -- ^ coefficient matrix -> Matrix Double -- ^ right hand sides (as columns) -> Matrix Double -- ^ solution vectors (as columns) linearSolveSVDR (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (dgelss rcond) "linearSolveSVDR" a b linearSolveSVDR Nothing a b = linearSolveSVDR (Just (-1)) a b -- | Minimum norm solution of a general complex linear least squares problem Ax=B using the SVD, based on LAPACK's /zgelss/. Admits rank-deficient systems but it is slower than 'linearSolveLSC'. The effective rank of A is determined by treating as zero those singular valures which are less than rcond times the largest singular value. If rcond == Nothing machine precision is used. linearSolveSVDC :: Maybe Double -- ^ rcond -> Matrix (Complex Double) -- ^ coefficient matrix -> Matrix (Complex Double) -- ^ right hand sides (as columns) -> Matrix (Complex Double) -- ^ solution vectors (as columns) linearSolveSVDC (Just rcond) a b = subMatrix (0,0) (cols a, cols b) $ linearSolveAux (zgelss rcond) "linearSolveSVDC" a b linearSolveSVDC Nothing a b = linearSolveSVDC (Just (-1)) a b ----------------------------------------------------------------------------------- foreign import ccall unsafe "chol_l_H" zpotrf :: C ::> Ok foreign import ccall unsafe "chol_l_S" dpotrf :: R ::> Ok cholAux f st a = do r <- copy ColumnMajor a (r # id) f #| st return r -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/. cholH :: Matrix (Complex Double) -> Matrix (Complex Double) cholH = unsafePerformIO . cholAux zpotrf "cholH" -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/. cholS :: Matrix Double -> Matrix Double cholS = unsafePerformIO . cholAux dpotrf "cholS" -- | Cholesky factorization of a complex Hermitian positive definite matrix, using LAPACK's /zpotrf/ ('Maybe' version). mbCholH :: Matrix (Complex Double) -> Maybe (Matrix (Complex Double)) mbCholH = unsafePerformIO . mbCatch . cholAux zpotrf "cholH" -- | Cholesky factorization of a real symmetric positive definite matrix, using LAPACK's /dpotrf/ ('Maybe' version). mbCholS :: Matrix Double -> Maybe (Matrix Double) mbCholS = unsafePerformIO . mbCatch . cholAux dpotrf "cholS" ----------------------------------------------------------------------------------- type TMVM t = t ::> t :> t ::> Ok foreign import ccall unsafe "qr_l_R" dgeqr2 :: R :> R ::> Ok foreign import ccall unsafe "qr_l_C" zgeqr2 :: C :> C ::> Ok -- | QR factorization of a real matrix, using LAPACK's /dgeqr2/. qrR :: Matrix Double -> (Matrix Double, Vector Double) qrR = qrAux dgeqr2 "qrR" -- | QR factorization of a complex matrix, using LAPACK's /zgeqr2/. qrC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) qrC = qrAux zgeqr2 "qrC" qrAux f st a = unsafePerformIO $ do r <- copy ColumnMajor a tau <- createVector mn (tau #! r) f #| st return (r,tau) where m = rows a n = cols a mn = min m n foreign import ccall unsafe "c_dorgqr" dorgqr :: R :> R ::> Ok foreign import ccall unsafe "c_zungqr" zungqr :: C :> C ::> Ok -- | build rotation from reflectors qrgrR :: Int -> (Matrix Double, Vector Double) -> Matrix Double qrgrR = qrgrAux dorgqr "qrgrR" -- | build rotation from reflectors qrgrC :: Int -> (Matrix (Complex Double), Vector (Complex Double)) -> Matrix (Complex Double) qrgrC = qrgrAux zungqr "qrgrC" qrgrAux f st n (a, tau) = unsafePerformIO $ do res <- copy ColumnMajor (subMatrix (0,0) (rows a,n) a) ((subVector 0 n tau') #! res) f #| st return res where tau' = vjoin [tau, constantD 0 n] ----------------------------------------------------------------------------------- foreign import ccall unsafe "hess_l_R" dgehrd :: R :> R ::> Ok foreign import ccall unsafe "hess_l_C" zgehrd :: C :> C ::> Ok -- | Hessenberg factorization of a square real matrix, using LAPACK's /dgehrd/. hessR :: Matrix Double -> (Matrix Double, Vector Double) hessR = hessAux dgehrd "hessR" -- | Hessenberg factorization of a square complex matrix, using LAPACK's /zgehrd/. hessC :: Matrix (Complex Double) -> (Matrix (Complex Double), Vector (Complex Double)) hessC = hessAux zgehrd "hessC" hessAux f st a = unsafePerformIO $ do r <- copy ColumnMajor a tau <- createVector (mn-1) (tau #! r) f #| st return (r,tau) where m = rows a n = cols a mn = min m n ----------------------------------------------------------------------------------- foreign import ccall unsafe "schur_l_R" dgees :: R ::> R ::> Ok foreign import ccall unsafe "schur_l_C" zgees :: C ::> C ::> Ok -- | Schur factorization of a square real matrix, using LAPACK's /dgees/. schurR :: Matrix Double -> (Matrix Double, Matrix Double) schurR = schurAux dgees "schurR" -- | Schur factorization of a square complex matrix, using LAPACK's /zgees/. schurC :: Matrix (Complex Double) -> (Matrix (Complex Double), Matrix (Complex Double)) schurC = schurAux zgees "schurC" schurAux f st a = unsafePerformIO $ do u <- createMatrix ColumnMajor n n s <- copy ColumnMajor a (u #! s) f #| st return (u,s) where n = rows a ----------------------------------------------------------------------------------- foreign import ccall unsafe "lu_l_R" dgetrf :: R :> R ::> Ok foreign import ccall unsafe "lu_l_C" zgetrf :: R :> C ::> Ok -- | LU factorization of a general real matrix, using LAPACK's /dgetrf/. luR :: Matrix Double -> (Matrix Double, [Int]) luR = luAux dgetrf "luR" -- | LU factorization of a general complex matrix, using LAPACK's /zgetrf/. luC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int]) luC = luAux zgetrf "luC" luAux f st a = unsafePerformIO $ do lu <- copy ColumnMajor a piv <- createVector (min n m) (piv #! lu) f #| st return (lu, map (pred.round) (toList piv)) where n = rows a m = cols a ----------------------------------------------------------------------------------- foreign import ccall unsafe "luS_l_R" dgetrs :: R ::> R :> R ::> Ok foreign import ccall unsafe "luS_l_C" zgetrs :: C ::> R :> C ::> Ok -- | Solve a real linear system from a precomputed LU decomposition ('luR'), using LAPACK's /dgetrs/. lusR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double lusR a piv b = lusAux dgetrs "lusR" (fmat a) piv b -- | Solve a complex linear system from a precomputed LU decomposition ('luC'), using LAPACK's /zgetrs/. lusC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double) lusC a piv b = lusAux zgetrs "lusC" (fmat a) piv b lusAux f st a piv b | n1==n2 && n2==n =unsafePerformIO $ do x <- copy ColumnMajor b (a # piv' #! x) f #| st return x | otherwise = error st where n1 = rows a n2 = cols a n = rows b piv' = fromList (map (fromIntegral.succ) piv) :: Vector Double ----------------------------------------------------------------------------------- foreign import ccall unsafe "ldl_R" dsytrf :: R :> R ::> Ok foreign import ccall unsafe "ldl_C" zhetrf :: R :> C ::> Ok -- | LDL factorization of a symmetric real matrix, using LAPACK's /dsytrf/. ldlR :: Matrix Double -> (Matrix Double, [Int]) ldlR = ldlAux dsytrf "ldlR" -- | LDL factorization of a hermitian complex matrix, using LAPACK's /zhetrf/. ldlC :: Matrix (Complex Double) -> (Matrix (Complex Double), [Int]) ldlC = ldlAux zhetrf "ldlC" ldlAux f st a = unsafePerformIO $ do ldl <- copy ColumnMajor a piv <- createVector (rows a) (piv #! ldl) f #| st return (ldl, map (pred.round) (toList piv)) ----------------------------------------------------------------------------------- foreign import ccall unsafe "ldl_S_R" dsytrs :: R ::> R :> R ::> Ok foreign import ccall unsafe "ldl_S_C" zsytrs :: C ::> R :> C ::> Ok -- | Solve a real linear system from a precomputed LDL decomposition ('ldlR'), using LAPACK's /dsytrs/. ldlsR :: Matrix Double -> [Int] -> Matrix Double -> Matrix Double ldlsR a piv b = lusAux dsytrs "ldlsR" (fmat a) piv b -- | Solve a complex linear system from a precomputed LDL decomposition ('ldlC'), using LAPACK's /zsytrs/. ldlsC :: Matrix (Complex Double) -> [Int] -> Matrix (Complex Double) -> Matrix (Complex Double) ldlsC a piv b = lusAux zsytrs "ldlsC" (fmat a) piv b hmatrix-0.19.0.0/src/Internal/Numeric.hs0000644000000000000000000006431213260621005016103 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Packed.Internal.Numeric -- Copyright : (c) Alberto Ruiz 2010-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- ----------------------------------------------------------------------------- module Internal.Numeric where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.ST as ST import Internal.Conversion import Internal.Vectorized import Internal.LAPACK(multiplyR,multiplyC,multiplyF,multiplyQ,multiplyI,multiplyL) import Data.List.Split(chunksOf) import qualified Data.Vector.Storable as V -------------------------------------------------------------------------------- type family IndexOf (c :: * -> *) type instance IndexOf Vector = Int type instance IndexOf Matrix = (Int,Int) type family ArgOf (c :: * -> *) a type instance ArgOf Vector a = a -> a type instance ArgOf Matrix a = a -> a -> a -------------------------------------------------------------------------------- -- | Basic element-by-element functions for numeric containers class Element e => Container c e where conj' :: c e -> c e size' :: c e -> IndexOf c scalar' :: e -> c e scale' :: e -> c e -> c e addConstant :: e -> c e -> c e add' :: c e -> c e -> c e sub :: c e -> c e -> c e -- | element by element multiplication mul :: c e -> c e -> c e equal :: c e -> c e -> Bool cmap' :: (Element b) => (e -> b) -> c e -> c b konst' :: e -> IndexOf c -> c e build' :: IndexOf c -> (ArgOf c e) -> c e atIndex' :: c e -> IndexOf c -> e minIndex' :: c e -> IndexOf c maxIndex' :: c e -> IndexOf c minElement' :: c e -> e maxElement' :: c e -> e sumElements' :: c e -> e prodElements' :: c e -> e step' :: Ord e => c e -> c e ccompare' :: Ord e => c e -> c e -> c I cselect' :: c I -> c e -> c e -> c e -> c e find' :: (e -> Bool) -> c e -> [IndexOf c] assoc' :: IndexOf c -- ^ size -> e -- ^ default value -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result accum' :: c e -- ^ initial structure -> (e -> e -> e) -- ^ update function -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result -- | scale the element by element reciprocal of the object: -- -- @scaleRecip 2 (fromList [5,i]) == 2 |> [0.4 :+ 0.0,0.0 :+ (-2.0)]@ scaleRecip :: Fractional e => e -> c e -> c e -- | element by element division divide :: Fractional e => c e -> c e -> c e -- -- element by element inverse tangent arctan2' :: Fractional e => c e -> c e -> c e cmod' :: Integral e => e -> c e -> c e fromInt' :: c I -> c e toInt' :: c e -> c I fromZ' :: c Z -> c e toZ' :: c e -> c Z -------------------------------------------------------------------------- instance Container Vector I where conj' = id size' = dim scale' = vectorMapValI Scale addConstant = vectorMapValI AddConstant add' = vectorZipI Add sub = vectorZipI Sub mul = vectorZipI Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarI MinIdx) maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarI MaxIdx) minElement' = emptyErrorV "minElement" (toScalarI Min) maxElement' = emptyErrorV "maxElement" (toScalarI Max) sumElements' = sumI 1 prodElements' = prodI 1 step' = stepI find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = undefined -- cannot match divide = undefined arctan2' = undefined cmod' m x | m /= 0 = vectorMapValI ModVS m x | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x) fromInt' = id toInt' = id fromZ' = long2intV toZ' = int2longV instance Container Vector Z where conj' = id size' = dim scale' = vectorMapValL Scale addConstant = vectorMapValL AddConstant add' = vectorZipL Add sub = vectorZipL Sub mul = vectorZipL Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (fromIntegral . toScalarL MinIdx) maxIndex' = emptyErrorV "maxIndex" (fromIntegral . toScalarL MaxIdx) minElement' = emptyErrorV "minElement" (toScalarL Min) maxElement' = emptyErrorV "maxElement" (toScalarL Max) sumElements' = sumL 1 prodElements' = prodL 1 step' = stepL find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = undefined -- cannot match divide = undefined arctan2' = undefined cmod' m x | m /= 0 = vectorMapValL ModVS m x | otherwise = error $ "cmod 0 on vector of size "++(show $ dim x) fromInt' = int2longV toInt' = long2intV fromZ' = id toZ' = id instance Container Vector Float where conj' = id size' = dim scale' = vectorMapValF Scale addConstant = vectorMapValF AddConstant add' = vectorZipF Add sub = vectorZipF Sub mul = vectorZipF Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (round . toScalarF MinIdx) maxIndex' = emptyErrorV "maxIndex" (round . toScalarF MaxIdx) minElement' = emptyErrorV "minElement" (toScalarF Min) maxElement' = emptyErrorV "maxElement" (toScalarF Max) sumElements' = sumF prodElements' = prodF step' = stepF find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = vectorMapValF Recip divide = vectorZipF Div arctan2' = vectorZipF ATan2 cmod' = undefined fromInt' = int2floatV toInt' = float2IntV fromZ' = (single :: Vector R-> Vector Float) . fromZ' toZ' = toZ' . double instance Container Vector Double where conj' = id size' = dim scale' = vectorMapValR Scale addConstant = vectorMapValR AddConstant add' = vectorZipR Add sub = vectorZipR Sub mul = vectorZipR Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (round . toScalarR MinIdx) maxIndex' = emptyErrorV "maxIndex" (round . toScalarR MaxIdx) minElement' = emptyErrorV "minElement" (toScalarR Min) maxElement' = emptyErrorV "maxElement" (toScalarR Max) sumElements' = sumR prodElements' = prodR step' = stepD find' = findV assoc' = assocV accum' = accumV ccompare' = compareCV compareV cselect' = selectCV selectV scaleRecip = vectorMapValR Recip divide = vectorZipR Div arctan2' = vectorZipR ATan2 cmod' = undefined fromInt' = int2DoubleV toInt' = double2IntV fromZ' = long2DoubleV toZ' = double2longV instance Container Vector (Complex Double) where conj' = conjugateC size' = dim scale' = vectorMapValC Scale addConstant = vectorMapValC AddConstant add' = vectorZipC Add sub = vectorZipC Sub mul = vectorZipC Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj')) maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj')) minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex') maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex') sumElements' = sumC prodElements' = prodC step' = undefined -- cannot match find' = findV assoc' = assocV accum' = accumV ccompare' = undefined -- cannot match cselect' = selectCV selectV scaleRecip = vectorMapValC Recip divide = vectorZipC Div arctan2' = vectorZipC ATan2 cmod' = undefined fromInt' = complex . int2DoubleV toInt' = toInt' . fst . fromComplex fromZ' = complex . long2DoubleV toZ' = toZ' . fst . fromComplex instance Container Vector (Complex Float) where conj' = conjugateQ size' = dim scale' = vectorMapValQ Scale addConstant = vectorMapValQ AddConstant add' = vectorZipQ Add sub = vectorZipQ Sub mul = vectorZipQ Mul equal = (==) scalar' = V.singleton konst' = constantD build' = buildV cmap' = mapVector atIndex' = (@>) minIndex' = emptyErrorV "minIndex" (minIndex' . fst . fromComplex . (mul <*> conj')) maxIndex' = emptyErrorV "maxIndex" (maxIndex' . fst . fromComplex . (mul <*> conj')) minElement' = emptyErrorV "minElement" (atIndex' <*> minIndex') maxElement' = emptyErrorV "maxElement" (atIndex' <*> maxIndex') sumElements' = sumQ prodElements' = prodQ step' = undefined -- cannot match find' = findV assoc' = assocV accum' = accumV ccompare' = undefined -- cannot match cselect' = selectCV selectV scaleRecip = vectorMapValQ Recip divide = vectorZipQ Div arctan2' = vectorZipQ ATan2 cmod' = undefined fromInt' = complex . int2floatV toInt' = toInt' . fst . fromComplex fromZ' = complex . single . long2DoubleV toZ' = toZ' . double . fst . fromComplex --------------------------------------------------------------- instance (Num a, Element a, Container Vector a) => Container Matrix a where conj' = liftMatrix conj' size' = size scale' x = liftMatrix (scale' x) addConstant x = liftMatrix (addConstant x) add' = liftMatrix2 add' sub = liftMatrix2 sub mul = liftMatrix2 mul equal a b = cols a == cols b && flatten a `equal` flatten b scalar' x = (1><1) [x] konst' v (r,c) = matrixFromVector RowMajor r c (konst' v (r*c)) build' = buildM cmap' f = liftMatrix (mapVector f) atIndex' = (@@>) minIndex' = emptyErrorM "minIndex of Matrix" $ \m -> divMod (minIndex' $ flatten m) (cols m) maxIndex' = emptyErrorM "maxIndex of Matrix" $ \m -> divMod (maxIndex' $ flatten m) (cols m) minElement' = emptyErrorM "minElement of Matrix" (atIndex' <*> minIndex') maxElement' = emptyErrorM "maxElement of Matrix" (atIndex' <*> maxIndex') sumElements' = sumElements' . flatten prodElements' = prodElements' . flatten step' = liftMatrix step' find' = findM assoc' = assocM accum' = accumM ccompare' = compareM cselect' = selectM scaleRecip x = liftMatrix (scaleRecip x) divide = liftMatrix2 divide arctan2' = liftMatrix2 arctan2' cmod' m x | m /= 0 = liftMatrix (cmod' m) x | otherwise = error $ "cmod 0 on matrix "++shSize x fromInt' = liftMatrix fromInt' toInt' = liftMatrix toInt' fromZ' = liftMatrix fromZ' toZ' = liftMatrix toZ' emptyErrorV msg f v = if dim v > 0 then f v else error $ msg ++ " of empty Vector" emptyErrorM msg f m = if rows m > 0 && cols m > 0 then f m else error $ msg++" "++shSize m -------------------------------------------------------------------------------- -- | create a structure with a single element -- -- >>> let v = fromList [1..3::Double] -- >>> v / scalar (norm2 v) -- fromList [0.2672612419124244,0.5345224838248488,0.8017837257372732] -- scalar :: Container c e => e -> c e scalar = scalar' -- | complex conjugate conj :: Container c e => c e -> c e conj = conj' arctan2 :: (Fractional e, Container c e) => c e -> c e -> c e arctan2 = arctan2' -- | 'mod' for integer arrays -- -- >>> cmod 3 (range 5) -- fromList [0,1,2,0,1] cmod :: (Integral e, Container c e) => e -> c e -> c e cmod = cmod' -- | -- >>>fromInt ((2><2) [0..3]) :: Matrix (Complex Double) -- (2><2) -- [ 0.0 :+ 0.0, 1.0 :+ 0.0 -- , 2.0 :+ 0.0, 3.0 :+ 0.0 ] -- fromInt :: (Container c e) => c I -> c e fromInt = fromInt' toInt :: (Container c e) => c e -> c I toInt = toInt' fromZ :: (Container c e) => c Z -> c e fromZ = fromZ' toZ :: (Container c e) => c e -> c Z toZ = toZ' -- | like 'fmap' (cannot implement instance Functor because of Element class constraint) cmap :: (Element b, Container c e) => (e -> b) -> c e -> c b cmap = cmap' -- | generic indexing function -- -- >>> vector [1,2,3] `atIndex` 1 -- 2.0 -- -- >>> matrix 3 [0..8] `atIndex` (2,0) -- 6.0 -- atIndex :: Container c e => c e -> IndexOf c -> e atIndex = atIndex' -- | index of minimum element minIndex :: Container c e => c e -> IndexOf c minIndex = minIndex' -- | index of maximum element maxIndex :: Container c e => c e -> IndexOf c maxIndex = maxIndex' -- | value of minimum element minElement :: Container c e => c e -> e minElement = minElement' -- | value of maximum element maxElement :: Container c e => c e -> e maxElement = maxElement' -- | the sum of elements sumElements :: Container c e => c e -> e sumElements = sumElements' -- | the product of elements prodElements :: Container c e => c e -> e prodElements = prodElements' -- | A more efficient implementation of @cmap (\\x -> if x>0 then 1 else 0)@ -- -- >>> step $ linspace 5 (-1,1::Double) -- 5 |> [0.0,0.0,0.0,1.0,1.0] -- step :: (Ord e, Container c e) => c e -> c e step = step' -- | Element by element version of @case compare a b of {LT -> l; EQ -> e; GT -> g}@. -- -- Arguments with any dimension = 1 are automatically expanded: -- -- >>> cond ((1><4)[1..]) ((3><1)[1..]) 0 100 ((3><4)[1..]) :: Matrix Double -- (3><4) -- [ 100.0, 2.0, 3.0, 4.0 -- , 0.0, 100.0, 7.0, 8.0 -- , 0.0, 0.0, 100.0, 12.0 ] -- -- >>> let chop x = cond (abs x) 1E-6 0 0 x -- cond :: (Ord e, Container c e, Container c x) => c e -- ^ a -> c e -- ^ b -> c x -- ^ l -> c x -- ^ e -> c x -- ^ g -> c x -- ^ result cond a b l e g = cselect' (ccompare' a b) l e g -- | Find index of elements which satisfy a predicate -- -- >>> find (>0) (ident 3 :: Matrix Double) -- [(0,0),(1,1),(2,2)] -- find :: Container c e => (e -> Bool) -> c e -> [IndexOf c] find = find' -- | Create a structure from an association list -- -- >>> assoc 5 0 [(3,7),(1,4)] :: Vector Double -- fromList [0.0,4.0,0.0,7.0,0.0] -- -- >>> assoc (2,3) 0 [((0,2),7),((1,0),2*i-3)] :: Matrix (Complex Double) -- (2><3) -- [ 0.0 :+ 0.0, 0.0 :+ 0.0, 7.0 :+ 0.0 -- , (-3.0) :+ 2.0, 0.0 :+ 0.0, 0.0 :+ 0.0 ] -- assoc :: Container c e => IndexOf c -- ^ size -> e -- ^ default value -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result assoc = assoc' -- | Modify a structure using an update function -- -- >>> accum (ident 5) (+) [((1,1),5),((0,3),3)] :: Matrix Double -- (5><5) -- [ 1.0, 0.0, 0.0, 3.0, 0.0 -- , 0.0, 6.0, 0.0, 0.0, 0.0 -- , 0.0, 0.0, 1.0, 0.0, 0.0 -- , 0.0, 0.0, 0.0, 1.0, 0.0 -- , 0.0, 0.0, 0.0, 0.0, 1.0 ] -- -- computation of histogram: -- -- >>> accum (konst 0 7) (+) (map (flip (,) 1) [4,5,4,1,5,2,5]) :: Vector Double -- fromList [0.0,1.0,1.0,0.0,2.0,3.0,0.0] -- accum :: Container c e => c e -- ^ initial structure -> (e -> e -> e) -- ^ update function -> [(IndexOf c, e)] -- ^ association list -> c e -- ^ result accum = accum' -------------------------------------------------------------------------------- class Konst e d c | d -> c, c -> d where -- | -- >>> konst 7 3 :: Vector Float -- fromList [7.0,7.0,7.0] -- -- >>> konst i (3::Int,4::Int) -- (3><4) -- [ 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 -- , 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0, 0.0 :+ 1.0 ] -- konst :: e -> d -> c e instance Container Vector e => Konst e Int Vector where konst = konst' instance (Num e, Container Vector e) => Konst e (Int,Int) Matrix where konst = konst' -------------------------------------------------------------------------------- class ( Container Vector t , Container Matrix t , Konst t Int Vector , Konst t (Int,Int) Matrix , CTrans t , Product t , Additive (Vector t) , Additive (Matrix t) , Linear t Vector , Linear t Matrix ) => Numeric t instance Numeric Double instance Numeric (Complex Double) instance Numeric Float instance Numeric (Complex Float) instance Numeric I instance Numeric Z -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- | Matrix product and related functions class (Num e, Element e) => Product e where -- | matrix product multiply :: Matrix e -> Matrix e -> Matrix e -- | sum of absolute value of elements (differs in complex case from @norm1@) absSum :: Vector e -> RealOf e -- | sum of absolute value of elements norm1 :: Vector e -> RealOf e -- | euclidean norm norm2 :: Floating e => Vector e -> RealOf e -- | element of maximum magnitude normInf :: Vector e -> RealOf e instance Product Float where norm2 = emptyVal (toScalarF Norm2) absSum = emptyVal (toScalarF AbsSum) norm1 = emptyVal (toScalarF AbsSum) normInf = emptyVal (maxElement . vectorMapF Abs) multiply = emptyMul multiplyF instance Product Double where norm2 = emptyVal (toScalarR Norm2) absSum = emptyVal (toScalarR AbsSum) norm1 = emptyVal (toScalarR AbsSum) normInf = emptyVal (maxElement . vectorMapR Abs) multiply = emptyMul multiplyR instance Product (Complex Float) where norm2 = emptyVal (toScalarQ Norm2) absSum = emptyVal (toScalarQ AbsSum) norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapQ Abs) normInf = emptyVal (maxElement . fst . fromComplex . vectorMapQ Abs) multiply = emptyMul multiplyQ instance Product (Complex Double) where norm2 = emptyVal (toScalarC Norm2) absSum = emptyVal (toScalarC AbsSum) norm1 = emptyVal (sumElements . fst . fromComplex . vectorMapC Abs) normInf = emptyVal (maxElement . fst . fromComplex . vectorMapC Abs) multiply = emptyMul multiplyC instance Product I where norm2 = undefined absSum = emptyVal (sumElements . vectorMapI Abs) norm1 = absSum normInf = emptyVal (maxElement . vectorMapI Abs) multiply = emptyMul (multiplyI 1) instance Product Z where norm2 = undefined absSum = emptyVal (sumElements . vectorMapL Abs) norm1 = absSum normInf = emptyVal (maxElement . vectorMapL Abs) multiply = emptyMul (multiplyL 1) emptyMul m a b | x1 == 0 && x2 == 0 || r == 0 || c == 0 = konst' 0 (r,c) | otherwise = m a b where r = rows a x1 = cols a x2 = rows b c = cols b emptyVal f v = if dim v > 0 then f v else 0 -- FIXME remove unused C wrappers -- | unconjugated dot product udot :: Product e => Vector e -> Vector e -> e udot u v | dim u == dim v = val (asRow u `multiply` asColumn v) | otherwise = error $ "different dimensions "++show (dim u)++" and "++show (dim v)++" in dot product" where val m | dim u > 0 = m@@>(0,0) | otherwise = 0 ---------------------------------------------------------- -- synonym for matrix product mXm :: Product t => Matrix t -> Matrix t -> Matrix t mXm = multiply -- matrix - vector product mXv :: Product t => Matrix t -> Vector t -> Vector t mXv m v = flatten $ m `mXm` (asColumn v) -- vector - matrix product vXm :: Product t => Vector t -> Matrix t -> Vector t vXm v m = flatten $ (asRow v) `mXm` m {- | Outer product of two vectors. >>> fromList [1,2,3] `outer` fromList [5,2,3] (3><3) [ 5.0, 2.0, 3.0 , 10.0, 4.0, 6.0 , 15.0, 6.0, 9.0 ] -} outer :: (Product t) => Vector t -> Vector t -> Matrix t outer u v = asColumn u `multiply` asRow v {- | Kronecker product of two matrices. @m1=(2><3) [ 1.0, 2.0, 0.0 , 0.0, -1.0, 3.0 ] m2=(4><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 ]@ >>> kronecker m1 m2 (8><9) [ 1.0, 2.0, 3.0, 2.0, 4.0, 6.0, 0.0, 0.0, 0.0 , 4.0, 5.0, 6.0, 8.0, 10.0, 12.0, 0.0, 0.0, 0.0 , 7.0, 8.0, 9.0, 14.0, 16.0, 18.0, 0.0, 0.0, 0.0 , 10.0, 11.0, 12.0, 20.0, 22.0, 24.0, 0.0, 0.0, 0.0 , 0.0, 0.0, 0.0, -1.0, -2.0, -3.0, 3.0, 6.0, 9.0 , 0.0, 0.0, 0.0, -4.0, -5.0, -6.0, 12.0, 15.0, 18.0 , 0.0, 0.0, 0.0, -7.0, -8.0, -9.0, 21.0, 24.0, 27.0 , 0.0, 0.0, 0.0, -10.0, -11.0, -12.0, 30.0, 33.0, 36.0 ] -} kronecker :: (Product t) => Matrix t -> Matrix t -> Matrix t kronecker a b = fromBlocks . chunksOf (cols a) . map (reshape (cols b)) . toRows $ flatten a `outer` flatten b ------------------------------------------------------------------- class Convert t where real :: Complexable c => c (RealOf t) -> c t complex :: Complexable c => c t -> c (ComplexOf t) single :: Complexable c => c t -> c (SingleOf t) double :: Complexable c => c t -> c (DoubleOf t) toComplex :: (Complexable c, RealElement t) => (c t, c t) -> c (Complex t) fromComplex :: (Complexable c, RealElement t) => c (Complex t) -> (c t, c t) instance Convert Double where real = id complex = comp' single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert Float where real = id complex = comp' single = id double = double' toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Double) where real = comp' complex = id single = single' double = id toComplex = toComplex' fromComplex = fromComplex' instance Convert (Complex Float) where real = comp' complex = id single = id double = double' toComplex = toComplex' fromComplex = fromComplex' ------------------------------------------------------------------- type family RealOf x type instance RealOf Double = Double type instance RealOf (Complex Double) = Double type instance RealOf Float = Float type instance RealOf (Complex Float) = Float type instance RealOf I = I type instance RealOf Z = Z type ComplexOf x = Complex (RealOf x) type family SingleOf x type instance SingleOf Double = Float type instance SingleOf Float = Float type instance SingleOf (Complex a) = Complex (SingleOf a) type family DoubleOf x type instance DoubleOf Double = Double type instance DoubleOf Float = Double type instance DoubleOf (Complex a) = Complex (DoubleOf a) type family ElementOf c type instance ElementOf (Vector a) = a type instance ElementOf (Matrix a) = a ------------------------------------------------------------ buildM (rc,cc) f = fromLists [ [f r c | c <- cs] | r <- rs ] where rs = map fromIntegral [0 .. (rc-1)] cs = map fromIntegral [0 .. (cc-1)] buildV n f = fromList [f k | k <- ks] where ks = map fromIntegral [0 .. (n-1)] -------------------------------------------------------- -- | Creates a square matrix with a given diagonal. diag :: (Num a, Element a) => Vector a -> Matrix a diag v = diagRect 0 v n n where n = dim v -- | creates the identity matrix of given dimension ident :: (Num a, Element a) => Int -> Matrix a ident n = diag (constantD 1 n) -------------------------------------------------------- findV p x = foldVectorWithIndex g [] x where g k z l = if p z then k:l else l findM p x = map ((`divMod` cols x)) $ findV p (flatten x) assocV n z xs = ST.runSTVector $ do v <- ST.newVector z n mapM_ (\(k,x) -> ST.writeVector v k x) xs return v assocM (r,c) z xs = ST.runSTMatrix $ do m <- ST.newMatrix z r c mapM_ (\((i,j),x) -> ST.writeMatrix m i j x) xs return m accumV v0 f xs = ST.runSTVector $ do v <- ST.thawVector v0 mapM_ (\(k,x) -> ST.modifyVector v k (f x)) xs return v accumM m0 f xs = ST.runSTMatrix $ do m <- ST.thawMatrix m0 mapM_ (\((i,j),x) -> ST.modifyMatrix m i j (f x)) xs return m ---------------------------------------------------------------------- compareM a b = matrixFromVector RowMajor (rows a'') (cols a'') $ ccompare' a' b' where args@(a'':_) = conformMs [a,b] [a', b'] = map flatten args compareCV f a b = f a' b' where [a', b'] = conformVs [a,b] selectM c l e t = matrixFromVector RowMajor (rows a'') (cols a'') $ cselect' (toInt c') l' e' t' where args@(a'':_) = conformMs [fromInt c,l,e,t] [c', l', e', t'] = map flatten args selectCV f c l e t = f (toInt c') l' e' t' where [c', l', e', t'] = conformVs [fromInt c,l,e,t] -------------------------------------------------------------------------------- class CTrans t where ctrans :: Matrix t -> Matrix t ctrans = trans instance CTrans Float instance CTrans R instance CTrans I instance CTrans Z instance CTrans C where ctrans = conj . trans instance CTrans (Complex Float) where ctrans = conj . trans class Transposable m mt | m -> mt, mt -> m where -- | conjugate transpose tr :: m -> mt -- | transpose tr' :: m -> mt instance (CTrans t, Container Vector t) => Transposable (Matrix t) (Matrix t) where tr = ctrans tr' = trans class Additive c where add :: c -> c -> c class Linear t c where scale :: t -> c t -> c t instance Container Vector t => Linear t Vector where scale = scale' instance Container Matrix t => Linear t Matrix where scale = scale' instance Container Vector t => Additive (Vector t) where add = add' instance Container Matrix t => Additive (Matrix t) where add = add' class Testable t where checkT :: t -> (Bool, IO()) ioCheckT :: t -> IO (Bool, IO()) ioCheckT = return . checkT -------------------------------------------------------------------------------- hmatrix-0.19.0.0/src/Internal/Algorithms.hs0000644000000000000000000010745413260621005016617 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- {- | Module : Internal.Algorithms Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional High level generic interface to common matrix computations. Specific functions for particular base types can also be explicitly imported from "Numeric.LinearAlgebra.LAPACK". -} ----------------------------------------------------------------------------- module Internal.Algorithms ( module Internal.Algorithms, UpLo(..) ) where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Conversion import Internal.LAPACK import Internal.Numeric import Data.List(foldl1') import qualified Data.Array as A import qualified Data.Vector.Storable as Vector import Internal.ST import Internal.Vectorized(range) import Control.DeepSeq {- | Generic linear algebra functions for double precision real and complex matrices. (Single precision data can be converted using 'single' and 'double'). -} class (Numeric t, Convert t, Normed Matrix t, Normed Vector t, Floating t, Linear t Vector, Linear t Matrix, Additive (Vector t), Additive (Matrix t), RealOf t ~ Double) => Field t where svd' :: Matrix t -> (Matrix t, Vector Double, Matrix t) thinSVD' :: Matrix t -> (Matrix t, Vector Double, Matrix t) sv' :: Matrix t -> Vector Double luPacked' :: Matrix t -> (Matrix t, [Int]) luSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t mbLinearSolve' :: Matrix t -> Matrix t -> Maybe (Matrix t) linearSolve' :: Matrix t -> Matrix t -> Matrix t cholSolve' :: Matrix t -> Matrix t -> Matrix t triSolve' :: UpLo -> Matrix t -> Matrix t -> Matrix t triDiagSolve' :: Vector t -> Vector t -> Vector t -> Matrix t -> Matrix t ldlPacked' :: Matrix t -> (Matrix t, [Int]) ldlSolve' :: (Matrix t, [Int]) -> Matrix t -> Matrix t linearSolveSVD' :: Matrix t -> Matrix t -> Matrix t linearSolveLS' :: Matrix t -> Matrix t -> Matrix t eig' :: Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eigSH'' :: Matrix t -> (Vector Double, Matrix t) eigOnly :: Matrix t -> Vector (Complex Double) eigOnlySH :: Matrix t -> Vector Double cholSH' :: Matrix t -> Matrix t mbCholSH' :: Matrix t -> Maybe (Matrix t) qr' :: Matrix t -> (Matrix t, Vector t) qrgr' :: Int -> (Matrix t, Vector t) -> Matrix t hess' :: Matrix t -> (Matrix t, Matrix t) schur' :: Matrix t -> (Matrix t, Matrix t) instance Field Double where svd' = svdRd thinSVD' = thinSVDRd sv' = svR luPacked' = luR luSolve' (l_u,perm) = lusR l_u perm linearSolve' = linearSolveR -- (luSolve . luPacked) ?? mbLinearSolve' = mbLinearSolveR cholSolve' = cholSolveR triSolve' = triSolveR triDiagSolve' = triDiagSolveR linearSolveLS' = linearSolveLSR linearSolveSVD' = linearSolveSVDR Nothing eig' = eigR eigSH'' = eigS eigOnly = eigOnlyR eigOnlySH = eigOnlyS cholSH' = cholS mbCholSH' = mbCholS qr' = qrR qrgr' = qrgrR hess' = unpackHess hessR schur' = schurR ldlPacked' = ldlR ldlSolve'= uncurry ldlsR instance Field (Complex Double) where #ifdef NOZGESDD svd' = svdC thinSVD' = thinSVDC #else svd' = svdCd thinSVD' = thinSVDCd #endif sv' = svC luPacked' = luC luSolve' (l_u,perm) = lusC l_u perm linearSolve' = linearSolveC mbLinearSolve' = mbLinearSolveC cholSolve' = cholSolveC triSolve' = triSolveC triDiagSolve' = triDiagSolveC linearSolveLS' = linearSolveLSC linearSolveSVD' = linearSolveSVDC Nothing eig' = eigC eigOnly = eigOnlyC eigSH'' = eigH eigOnlySH = eigOnlyH cholSH' = cholH mbCholSH' = mbCholH qr' = qrC qrgr' = qrgrC hess' = unpackHess hessC schur' = schurC ldlPacked' = ldlC ldlSolve' = uncurry ldlsC -------------------------------------------------------------- square m = rows m == cols m vertical m = rows m >= cols m exactHermitian m = m `equal` ctrans m -------------------------------------------------------------- {- | Full singular value decomposition. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = svd a >>> disp 3 u 5x5 -0.101 0.768 0.614 0.028 -0.149 -0.249 0.488 -0.503 0.172 0.646 -0.396 0.208 -0.405 -0.660 -0.449 -0.543 -0.072 -0.140 0.693 -0.447 -0.690 -0.352 0.433 -0.233 0.398 >>> s fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15] >>> disp 3 v 3x3 -0.519 -0.751 0.408 -0.576 -0.046 -0.816 -0.632 0.659 0.408 >>> let d = diagRect 0 s 5 3 >>> disp 3 d 5x3 35.183 0.000 0.000 0.000 1.477 0.000 0.000 0.000 0.000 0.000 0.000 0.000 >>> disp 3 $ u <> d <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} svd :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) svd = {-# SCC "svd" #-} g . svd' where g (u,s,v) = (u,s,tr v) {- | A version of 'svd' which returns only the @min (rows m) (cols m)@ singular vectors of @m@. If @(u,s,v) = thinSVD m@ then @m == u \<> diag s \<> tr v@. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = thinSVD a >>> disp 3 u 5x3 -0.101 0.768 0.614 -0.249 0.488 -0.503 -0.396 0.208 -0.405 -0.543 -0.072 -0.140 -0.690 -0.352 0.433 >>> s fromList [35.18264833189422,1.4769076999800903,1.089145439970417e-15] >>> disp 3 v 3x3 -0.519 -0.751 0.408 -0.576 -0.046 -0.816 -0.632 0.659 0.408 >>> disp 3 $ u <> diag s <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} thinSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) thinSVD = {-# SCC "thinSVD" #-} g . thinSVD' where g (u,s,v) = (u,s,tr v) -- | Singular values only. singularValues :: Field t => Matrix t -> Vector Double singularValues = {-# SCC "singularValues" #-} sv' -- | A version of 'svd' which returns an appropriate diagonal matrix with the singular values. -- -- If @(u,d,v) = fullSVD m@ then @m == u \<> d \<> tr v@. fullSVD :: Field t => Matrix t -> (Matrix t, Matrix Double, Matrix t) fullSVD m = (u,d,v) where (u,s,v) = svd m d = diagRect 0 s r c r = rows m c = cols m {- | Similar to 'thinSVD', returning only the nonzero singular values and the corresponding singular vectors. @ a = (5><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 , 10.0, 11.0, 12.0 , 13.0, 14.0, 15.0 ] :: Matrix Double @ >>> let (u,s,v) = compactSVD a >>> disp 3 u 5x2 -0.101 0.768 -0.249 0.488 -0.396 0.208 -0.543 -0.072 -0.690 -0.352 >>> s fromList [35.18264833189422,1.4769076999800903] >>> disp 3 u 5x2 -0.101 0.768 -0.249 0.488 -0.396 0.208 -0.543 -0.072 -0.690 -0.352 >>> disp 3 $ u <> diag s <> tr v 5x3 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 -} compactSVD :: Field t => Matrix t -> (Matrix t, Vector Double, Matrix t) compactSVD = compactSVDTol 1 -- | @compactSVDTol r@ is similar to 'compactSVD' (for which @r=1@), but uses tolerance @tol=r*g*eps*(max rows cols)@ to distinguish nonzero singular values, where @g@ is the greatest singular value. If @g Double -> Matrix t -> (Matrix t, Vector Double, Matrix t) compactSVDTol r m = (u', subVector 0 d s, v') where (u,s,v) = thinSVD m d = rankSVD (r*eps) m s `max` 1 u' = takeColumns d u v' = takeColumns d v -- | Singular values and all right singular vectors (as columns). rightSV :: Field t => Matrix t -> (Vector Double, Matrix t) rightSV m | vertical m = let (_,s,v) = thinSVD m in (s,v) | otherwise = let (_,s,v) = svd m in (s,v) -- | Singular values and all left singular vectors (as columns). leftSV :: Field t => Matrix t -> (Matrix t, Vector Double) leftSV m | vertical m = let (u,s,_) = svd m in (u,s) | otherwise = let (u,s,_) = thinSVD m in (u,s) -------------------------------------------------------------- -- | LU decomposition of a matrix in a compact format. data LU t = LU (Matrix t) [Int] deriving Show instance (NFData t, Numeric t) => NFData (LU t) where rnf (LU m _) = rnf m -- | Obtains the LU decomposition of a matrix in a compact data structure suitable for 'luSolve'. luPacked :: Field t => Matrix t -> LU t luPacked x = {-# SCC "luPacked" #-} LU m p where (m,p) = luPacked' x -- | Solution of a linear system (for several right hand sides) from the precomputed LU factorization obtained by 'luPacked'. luSolve :: Field t => LU t -> Matrix t -> Matrix t luSolve (LU m p) = {-# SCC "luSolve" #-} luSolve' (m,p) -- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. -- It is similar to 'luSolve' . 'luPacked', but @linearSolve@ raises an error if called on a singular system. linearSolve :: Field t => Matrix t -> Matrix t -> Matrix t linearSolve = {-# SCC "linearSolve" #-} linearSolve' -- | Solve a linear system (for square coefficient matrix and several right-hand sides) using the LU decomposition, returning Nothing for a singular system. For underconstrained or overconstrained systems use 'linearSolveLS' or 'linearSolveSVD'. mbLinearSolve :: Field t => Matrix t -> Matrix t -> Maybe (Matrix t) mbLinearSolve = {-# SCC "linearSolve" #-} mbLinearSolve' -- | Solve a symmetric or Hermitian positive definite linear system using a precomputed Cholesky decomposition obtained by 'chol'. cholSolve :: Field t => Matrix t -- ^ Cholesky decomposition of the coefficient matrix -> Matrix t -- ^ right hand sides -> Matrix t -- ^ solution cholSolve = {-# SCC "cholSolve" #-} cholSolve' -- | Solve a triangular linear system. If `Upper` is specified then -- all elements below the diagonal are ignored; if `Lower` is -- specified then all elements above the diagonal are ignored. triSolve :: Field t => UpLo -- ^ `Lower` or `Upper` -> Matrix t -- ^ coefficient matrix -> Matrix t -- ^ right hand sides -> Matrix t -- ^ solution triSolve = {-# SCC "triSolve" #-} triSolve' -- | Solve a tridiagonal linear system. Suppose you wish to solve \(Ax = b\) where -- -- \[ -- A = -- \begin{bmatrix} -- 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 -- \\ 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 -- \\ 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 -- \\ 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 & 0.0 -- \\ 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 & 0.0 -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 & 0.0 -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 & 0.0 -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 & 4.0 -- \\ 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 0.0 & 3.0 & 1.0 -- \end{bmatrix} -- \quad -- b = -- \begin{bmatrix} -- 1.0 & 1.0 & 1.0 -- \\ 1.0 & -1.0 & 2.0 -- \\ 1.0 & 1.0 & 3.0 -- \\ 1.0 & -1.0 & 4.0 -- \\ 1.0 & 1.0 & 5.0 -- \\ 1.0 & -1.0 & 6.0 -- \\ 1.0 & 1.0 & 7.0 -- \\ 1.0 & -1.0 & 8.0 -- \\ 1.0 & 1.0 & 9.0 -- \end{bmatrix} -- \] -- -- then -- -- @ -- dL = fromList [3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0] -- d = fromList [1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0] -- dU = fromList [4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0, 4.0] -- -- b = (9><3) -- [ -- 1.0, 1.0, 1.0, -- 1.0, -1.0, 2.0, -- 1.0, 1.0, 3.0, -- 1.0, -1.0, 4.0, -- 1.0, 1.0, 5.0, -- 1.0, -1.0, 6.0, -- 1.0, 1.0, 7.0, -- 1.0, -1.0, 8.0, -- 1.0, 1.0, 9.0 -- ] -- -- x = triDiagSolve dL d dU b -- @ -- triDiagSolve :: Field t => Vector t -- ^ lower diagonal: \(n - 1\) elements -> Vector t -- ^ diagonal: \(n\) elements -> Vector t -- ^ upper diagonal: \(n - 1\) elements -> Matrix t -- ^ right hand sides -> Matrix t -- ^ solution triDiagSolve = {-# SCC "triDiagSolve" #-} triDiagSolve' -- | Minimum norm solution of a general linear least squares problem Ax=B using the SVD. Admits rank-deficient systems but it is slower than 'linearSolveLS'. The effective rank of A is determined by treating as zero those singular valures which are less than 'eps' times the largest singular value. linearSolveSVD :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveSVD = {-# SCC "linearSolveSVD" #-} linearSolveSVD' -- | Least squared error solution of an overconstrained linear system, or the minimum norm solution of an underconstrained system. For rank-deficient systems use 'linearSolveSVD'. linearSolveLS :: Field t => Matrix t -> Matrix t -> Matrix t linearSolveLS = {-# SCC "linearSolveLS" #-} linearSolveLS' -------------------------------------------------------------------------------- -- | LDL decomposition of a complex Hermitian or real symmetric matrix in a compact format. data LDL t = LDL (Matrix t) [Int] deriving Show instance (NFData t, Numeric t) => NFData (LDL t) where rnf (LDL m _) = rnf m -- | Similar to 'ldlPacked', without checking that the input matrix is hermitian or symmetric. It works with the lower triangular part. ldlPackedSH :: Field t => Matrix t -> LDL t ldlPackedSH x = {-# SCC "ldlPacked" #-} LDL m p where (m,p) = ldlPacked' x -- | Obtains the LDL decomposition of a matrix in a compact data structure suitable for 'ldlSolve'. ldlPacked :: Field t => Herm t -> LDL t ldlPacked (Herm m) = ldlPackedSH m -- | Solution of a linear system (for several right hand sides) from a precomputed LDL factorization obtained by 'ldlPacked'. -- -- Note: this can be slower than the general solver based on the LU decomposition. ldlSolve :: Field t => LDL t -> Matrix t -> Matrix t ldlSolve (LDL m p) = {-# SCC "ldlSolve" #-} ldlSolve' (m,p) -------------------------------------------------------------- {- | Eigenvalues (not ordered) and eigenvectors (as columns) of a general square matrix. If @(s,v) = eig m@ then @m \<> v == v \<> diag s@ @ a = (3><3) [ 3, 0, -2 , 4, 5, -1 , 3, 1, 0 ] :: Matrix Double @ >>> let (l, v) = eig a >>> putStr . dispcf 3 . asRow $ l 1x3 1.925+1.523i 1.925-1.523i 4.151 >>> putStr . dispcf 3 $ v 3x3 -0.455+0.365i -0.455-0.365i 0.181 0.603 0.603 -0.978 0.033+0.543i 0.033-0.543i -0.104 >>> putStr . dispcf 3 $ complex a <> v 3x3 -1.432+0.010i -1.432-0.010i 0.753 1.160+0.918i 1.160-0.918i -4.059 -0.763+1.096i -0.763-1.096i -0.433 >>> putStr . dispcf 3 $ v <> diag l 3x3 -1.432+0.010i -1.432-0.010i 0.753 1.160+0.918i 1.160-0.918i -4.059 -0.763+1.096i -0.763-1.096i -0.433 -} eig :: Field t => Matrix t -> (Vector (Complex Double), Matrix (Complex Double)) eig = {-# SCC "eig" #-} eig' -- | Eigenvalues (not ordered) of a general square matrix. eigenvalues :: Field t => Matrix t -> Vector (Complex Double) eigenvalues = {-# SCC "eigenvalues" #-} eigOnly -- | Similar to 'eigSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. eigSH' :: Field t => Matrix t -> (Vector Double, Matrix t) eigSH' = {-# SCC "eigSH'" #-} eigSH'' -- | Similar to 'eigenvaluesSH' without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. eigenvaluesSH' :: Field t => Matrix t -> Vector Double eigenvaluesSH' = {-# SCC "eigenvaluesSH'" #-} eigOnlySH {- | Eigenvalues and eigenvectors (as columns) of a complex hermitian or real symmetric matrix, in descending order. If @(s,v) = eigSH m@ then @m == v \<> diag s \<> tr v@ @ a = (3><3) [ 1.0, 2.0, 3.0 , 2.0, 4.0, 5.0 , 3.0, 5.0, 6.0 ] @ >>> let (l, v) = eigSH a >>> l fromList [11.344814282762075,0.17091518882717918,-0.5157294715892575] >>> disp 3 $ v <> diag l <> tr v 3x3 1.000 2.000 3.000 2.000 4.000 5.000 3.000 5.000 6.000 -} eigSH :: Field t => Herm t -> (Vector Double, Matrix t) eigSH (Herm m) = eigSH' m -- | Eigenvalues (in descending order) of a complex hermitian or real symmetric matrix. eigenvaluesSH :: Field t => Herm t -> Vector Double eigenvaluesSH (Herm m) = eigenvaluesSH' m -------------------------------------------------------------- -- | QR decomposition of a matrix in compact form. (The orthogonal matrix is not explicitly formed.) data QR t = QR (Matrix t) (Vector t) instance (NFData t, Numeric t) => NFData (QR t) where rnf (QR m _) = rnf m -- | QR factorization. -- -- If @(q,r) = qr m@ then @m == q \<> r@, where q is unitary and r is upper triangular. -- Note: the current implementation is very slow for large matrices. 'thinQR' is much faster. qr :: Field t => Matrix t -> (Matrix t, Matrix t) qr = {-# SCC "qr" #-} unpackQR . qr' -- | A version of 'qr' which returns only the @min (rows m) (cols m)@ columns of @q@ and rows of @r@. thinQR :: Field t => Matrix t -> (Matrix t, Matrix t) thinQR = {-# SCC "thinQR" #-} thinUnpackQR . qr' -- | Compute the QR decomposition of a matrix in compact form. qrRaw :: Field t => Matrix t -> QR t qrRaw m = QR x v where (x,v) = qr' m -- | generate a matrix with k orthogonal columns from the compact QR decomposition obtained by 'qrRaw'. -- qrgr :: Field t => Int -> QR t -> Matrix t qrgr n (QR a t) | dim t > min (cols a) (rows a) || n < 0 || n > dim t = error "qrgr expects k <= min(rows,cols)" | otherwise = qrgr' n (a,t) -- | RQ factorization. -- -- If @(r,q) = rq m@ then @m == r \<> q@, where q is unitary and r is upper triangular. -- Note: the current implementation is very slow for large matrices. 'thinRQ' is much faster. rq :: Field t => Matrix t -> (Matrix t, Matrix t) rq = {-# SCC "rq" #-} rqFromQR qr -- | A version of 'rq' which returns only the @min (rows m) (cols m)@ columns of @r@ and rows of @q@. thinRQ :: Field t => Matrix t -> (Matrix t, Matrix t) thinRQ = {-# SCC "thinQR" #-} rqFromQR thinQR rqFromQR :: Field t => (Matrix t -> (Matrix t, Matrix t)) -> Matrix t -> (Matrix t, Matrix t) rqFromQR qr0 m = (r,q) where (q',r') = qr0 $ trans $ rev1 m r = rev2 (trans r') q = rev2 (trans q') rev1 = flipud . fliprl rev2 = fliprl . flipud -- | Hessenberg factorization. -- -- If @(p,h) = hess m@ then @m == p \<> h \<> tr p@, where p is unitary -- and h is in upper Hessenberg form (it has zero entries below the first subdiagonal). hess :: Field t => Matrix t -> (Matrix t, Matrix t) hess = hess' -- | Schur factorization. -- -- If @(u,s) = schur m@ then @m == u \<> s \<> tr u@, where u is unitary -- and s is a Shur matrix. A complex Schur matrix is upper triangular. A real Schur matrix is -- upper triangular in 2x2 blocks. -- -- \"Anything that the Jordan decomposition can do, the Schur decomposition -- can do better!\" (Van Loan) schur :: Field t => Matrix t -> (Matrix t, Matrix t) schur = schur' -- | Similar to 'cholSH', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'. mbCholSH :: Field t => Matrix t -> Maybe (Matrix t) mbCholSH = {-# SCC "mbCholSH" #-} mbCholSH' -- | Similar to 'chol', without checking that the input matrix is hermitian or symmetric. It works with the upper triangular part. cholSH :: Field t => Matrix t -> Matrix t cholSH = cholSH' -- | Cholesky factorization of a positive definite hermitian or symmetric matrix. -- -- If @c = chol m@ then @c@ is upper triangular and @m == tr c \<> c@. chol :: Field t => Herm t -> Matrix t chol (Herm m) = {-# SCC "chol" #-} cholSH' m -- | Similar to 'chol', but instead of an error (e.g., caused by a matrix not positive definite) it returns 'Nothing'. mbChol :: Field t => Herm t -> Maybe (Matrix t) mbChol (Herm m) = {-# SCC "mbChol" #-} mbCholSH' m -- | Joint computation of inverse and logarithm of determinant of a square matrix. invlndet :: Field t => Matrix t -> (Matrix t, (t, t)) -- ^ (inverse, (log abs det, sign or phase of det)) invlndet m | square m = (im,(ladm,sdm)) | otherwise = error $ "invlndet of nonsquare "++ shSize m ++ " matrix" where lp@(LU lup perm) = luPacked m s = signlp (rows m) perm dg = toList $ takeDiag $ lup ladm = sum $ map (log.abs) dg sdm = s* product (map signum dg) im = luSolve lp (ident (rows m)) -- | Determinant of a square matrix. To avoid possible overflow or underflow use 'invlndet'. det :: Field t => Matrix t -> t det m | square m = {-# SCC "det" #-} s * (product $ toList $ takeDiag $ lup) | otherwise = error $ "det of nonsquare "++ shSize m ++ " matrix" where LU lup perm = luPacked m s = signlp (rows m) perm -- | Explicit LU factorization of a general matrix. -- -- If @(l,u,p,s) = lu m@ then @m == p \<> l \<> u@, where l is lower triangular, -- u is upper triangular, p is a permutation matrix and s is the signature of the permutation. lu :: Field t => Matrix t -> (Matrix t, Matrix t, Matrix t, t) lu = luFact . luPacked -- | Inverse of a square matrix. See also 'invlndet'. inv :: Field t => Matrix t -> Matrix t inv m | square m = m `linearSolve` ident (rows m) | otherwise = error $ "inv of nonsquare "++ shSize m ++ " matrix" -- | Pseudoinverse of a general matrix with default tolerance ('pinvTol' 1, similar to GNU-Octave). pinv :: Field t => Matrix t -> Matrix t pinv = pinvTol 1 {- | @pinvTol r@ computes the pseudoinverse of a matrix with tolerance @tol=r*g*eps*(max rows cols)@, where g is the greatest singular value. @ m = (3><3) [ 1, 0, 0 , 0, 1, 0 , 0, 0, 1e-10] :: Matrix Double @ >>> pinv m 1. 0. 0. 0. 1. 0. 0. 0. 10000000000. >>> pinvTol 1E8 m 1. 0. 0. 0. 1. 0. 0. 0. 1. -} pinvTol :: Field t => Double -> Matrix t -> Matrix t pinvTol t m = v' `mXm` diag s' `mXm` ctrans u' where (u,s,v) = thinSVD m sl@(g:_) = toList s s' = real . fromList . map rec $ sl rec x = if x <= g*tol then x else 1/x tol = (fromIntegral (max r c) * g * t * eps) r = rows m c = cols m d = dim s u' = takeColumns d u v' = takeColumns d v -- | Numeric rank of a matrix from the SVD decomposition. rankSVD :: Element t => Double -- ^ numeric zero (e.g. 1*'eps') -> Matrix t -- ^ input matrix m -> Vector Double -- ^ 'sv' of m -> Int -- ^ rank of m rankSVD teps m s = ranksv teps (max (rows m) (cols m)) (toList s) -- | Numeric rank of a matrix from its singular values. ranksv :: Double -- ^ numeric zero (e.g. 1*'eps') -> Int -- ^ maximum dimension of the matrix -> [Double] -- ^ singular values -> Int -- ^ rank of m ranksv teps maxdim s = k where g = maximum s tol = fromIntegral maxdim * g * teps s' = filter (>tol) s k = if g > teps then length s' else 0 -- | The machine precision of a Double: @eps = 2.22044604925031e-16@ (the value used by GNU-Octave). eps :: Double eps = 2.22044604925031e-16 -- | 1 + 0.5*peps == 1, 1 + 0.6*peps /= 1 peps :: RealFloat x => x peps = x where x = 2.0 ** fromIntegral (1 - floatDigits x) ----------------------------------------------------------------------- -- | The nullspace of a matrix from its precomputed SVD decomposition. nullspaceSVD :: Field t => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'), -- or Right \"theoretical\" matrix rank. -> Matrix t -- ^ input matrix m -> (Vector Double, Matrix t) -- ^ 'rightSV' of m -> Matrix t -- ^ nullspace nullspaceSVD hint a (s,v) = vs where tol = case hint of Left t -> t _ -> eps k = case hint of Right t -> t _ -> rankSVD tol a s vs = dropColumns k v -- | The nullspace of a matrix. See also 'nullspaceSVD'. nullspacePrec :: Field t => Double -- ^ relative tolerance in 'eps' units (e.g., use 3 to get 3*'eps') -> Matrix t -- ^ input matrix -> [Vector t] -- ^ list of unitary vectors spanning the nullspace nullspacePrec t m = toColumns $ nullspaceSVD (Left (t*eps)) m (rightSV m) -- | The nullspace of a matrix, assumed to be one-dimensional, with machine precision. nullVector :: Field t => Matrix t -> Vector t nullVector = last . nullspacePrec 1 -- | The range space a matrix from its precomputed SVD decomposition. orthSVD :: Field t => Either Double Int -- ^ Left \"numeric\" zero (eg. 1*'eps'), -- or Right \"theoretical\" matrix rank. -> Matrix t -- ^ input matrix m -> (Matrix t, Vector Double) -- ^ 'leftSV' of m -> Matrix t -- ^ orth orthSVD hint a (v,s) = vs where tol = case hint of Left t -> t _ -> eps k = case hint of Right t -> t _ -> rankSVD tol a s vs = takeColumns k v orth :: Field t => Matrix t -> [Vector t] -- ^ Return an orthonormal basis of the range space of a matrix orth m = take r $ toColumns u where (u,s,_) = compactSVD m r = ranksv eps (max (rows m) (cols m)) (toList s) ------------------------------------------------------------------------ -- many thanks, quickcheck! haussholder :: (Field a) => a -> Vector a -> Matrix a haussholder tau v = ident (dim v) `sub` (tau `scale` (w `mXm` ctrans w)) where w = asColumn v zh k v = fromList $ replicate (k-1) 0 ++ (1:drop k xs) where xs = toList v zt 0 v = v zt k v = vjoin [subVector 0 (dim v - k) v, konst' 0 k] unpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t) unpackQR (pq, tau) = {-# SCC "unpackQR" #-} (q,r) where cs = toColumns pq m = rows pq n = cols pq mn = min m n r = fromColumns $ zipWith zt ([m-1, m-2 .. 1] ++ repeat 0) cs vs = zipWith zh [1..mn] cs hs = zipWith haussholder (toList tau) vs q = foldl1' mXm hs thinUnpackQR :: (Field t) => (Matrix t, Vector t) -> (Matrix t, Matrix t) thinUnpackQR (pq, tau) = (q, r) where mn = uncurry min $ size pq q = qrgr mn $ QR pq tau r = fromRows $ zipWith (\i v -> Vector.replicate i 0 Vector.++ Vector.drop i v) [0..mn-1] (toRows pq) unpackHess :: (Field t) => (Matrix t -> (Matrix t,Vector t)) -> Matrix t -> (Matrix t, Matrix t) unpackHess hf m | rows m == 1 = ((1><1)[1],m) | otherwise = (uH . hf) m uH (pq, tau) = (p,h) where cs = toColumns pq m = rows pq n = cols pq mn = min m n h = fromColumns $ zipWith zt ([m-2, m-3 .. 1] ++ repeat 0) cs vs = zipWith zh [2..mn] cs hs = zipWith haussholder (toList tau) vs p = foldl1' mXm hs -------------------------------------------------------------------------- -- | Reciprocal of the 2-norm condition number of a matrix, computed from the singular values. rcond :: Field t => Matrix t -> Double rcond m = last s / head s where s = toList (singularValues m) -- | Number of linearly independent rows or columns. See also 'ranksv' rank :: Field t => Matrix t -> Int rank m = rankSVD eps m (singularValues m) {- expm' m = case diagonalize (complex m) of Just (l,v) -> v `mXm` diag (exp l) `mXm` inv v Nothing -> error "Sorry, expm not yet implemented for non-diagonalizable matrices" where exp = vectorMapC Exp -} diagonalize m = if rank v == n then Just (l,v) else Nothing where n = rows m (l,v) = if exactHermitian m then let (l',v') = eigSH (trustSym m) in (real l', v') else eig m -- | Generic matrix functions for diagonalizable matrices. For instance: -- -- @logm = matFunc log@ -- matFunc :: (Complex Double -> Complex Double) -> Matrix (Complex Double) -> Matrix (Complex Double) matFunc f m = case diagonalize m of Just (l,v) -> v `mXm` diag (mapVector f l) `mXm` inv v Nothing -> error "Sorry, matFunc requires a diagonalizable matrix" -------------------------------------------------------------- golubeps :: Integer -> Integer -> Double golubeps p q = a * fromIntegral b / fromIntegral c where a = 2^^(3-p-q) b = fact p * fact q c = fact (p+q) * fact (p+q+1) fact n = product [1..n] epslist :: [(Int,Double)] epslist = [ (fromIntegral k, golubeps k k) | k <- [1..]] geps delta = head [ k | (k,g) <- epslist, g Matrix t -> Matrix t expm = expGolub expGolub :: Field t => Matrix t -> Matrix t expGolub m = iterate msq f !! j where j = max 0 $ floor $ logBase 2 $ pnorm Infinity m a = m */ fromIntegral ((2::Int)^j) q = geps eps -- 7 steps eye = ident (rows m) work (k,c,x,n,d) = (k',c',x',n',d') where k' = k+1 c' = c * fromIntegral (q-k+1) / fromIntegral ((2*q-k+1)*k) x' = a <> x n' = n |+| (c' .* x') d' = d |+| (((-1)^k * c') .* x') (_,_,_,nf,df) = iterate work (1,1,eye,eye,eye) !! q f = linearSolve df nf msq x = x <> x (<>) = multiply v */ x = scale (recip x) v (.*) = scale (|+|) = add -------------------------------------------------------------- {- | Matrix square root. Currently it uses a simple iterative algorithm described in Wikipedia. It only works with invertible matrices that have a real solution. @m = (2><2) [4,9 ,0,4] :: Matrix Double@ >>> sqrtm m (2><2) [ 2.0, 2.25 , 0.0, 2.0 ] For diagonalizable matrices you can try 'matFunc' @sqrt@: >>> matFunc sqrt ((2><2) [1,0,0,-1]) (2><2) [ 1.0 :+ 0.0, 0.0 :+ 0.0 , 0.0 :+ 0.0, 0.0 :+ 1.0 ] -} sqrtm :: Field t => Matrix t -> Matrix t sqrtm = sqrtmInv sqrtmInv x = fst $ fixedPoint $ iterate f (x, ident (rows x)) where fixedPoint (a:b:rest) | pnorm PNorm1 (fst a |-| fst b) < peps = a | otherwise = fixedPoint (b:rest) fixedPoint _ = error "fixedpoint with impossible inputs" f (y,z) = (0.5 .* (y |+| inv z), 0.5 .* (inv y |+| z)) (.*) = scale (|+|) = add (|-|) = sub ------------------------------------------------------------------ signlp r vals = foldl f 1 (zip [0..r-1] vals) where f s (a,b) | a /= b = -s | otherwise = s fixPerm r vals = (fromColumns $ A.elems res, sign) where v = [0..r-1] t = toColumns (ident r) (res,sign) = foldl swap (A.listArray (0,r-1) t, 1) (zip v vals) swap (arr,s) (a,b) | a /= b = (arr A.// [(a, arr A.! b),(b,arr A.! a)],-s) | otherwise = (arr,s) fixPerm' :: [Int] -> Vector I fixPerm' s = res $ mutable f s0 where s0 = reshape 1 (range (length s)) res = flatten . fst swap m i j = rowOper (SWAP i j AllCols) m f :: (Num t, Element t) => (Int, Int) -> STMatrix s t -> ST s () -- needed because of TypeFamilies f _ p = sequence_ $ zipWith (swap p) [0..] s triang r c h v = (r>=h then v else 1 - v -- | Compute the explicit LU decomposition from the compact one obtained by 'luPacked'. luFact :: Numeric t => LU t -> (Matrix t, Matrix t, Matrix t, t) luFact (LU l_u perm) | r <= c = (l ,u ,p, s) | otherwise = (l',u',p, s) where r = rows l_u c = cols l_u tu = triang r c 0 1 tl = triang r c 0 0 l = takeColumns r (l_u |*| tl) |+| diagRect 0 (konst' 1 r) r r u = l_u |*| tu (p,s) = fixPerm r perm l' = (l_u |*| tl) |+| diagRect 0 (konst' 1 c) r c u' = takeRows c (l_u |*| tu) (|+|) = add (|*|) = mul --------------------------------------------------------------------------- data NormType = Infinity | PNorm1 | PNorm2 | Frobenius class (RealFloat (RealOf t)) => Normed c t where pnorm :: NormType -> c t -> RealOf t instance Normed Vector Double where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = norm2 instance Normed Vector (Complex Double) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector Float where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Vector (Complex Float) where pnorm PNorm1 = norm1 pnorm PNorm2 = norm2 pnorm Infinity = normInf pnorm Frobenius = pnorm PNorm2 instance Normed Matrix Double where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Double) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = (@>0) . singularValues pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix Float where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten instance Normed Matrix (Complex Float) where pnorm PNorm1 = maximum . map (pnorm PNorm1) . toColumns pnorm PNorm2 = realToFrac . (@>0) . singularValues . double pnorm Infinity = pnorm PNorm1 . trans pnorm Frobenius = pnorm PNorm2 . flatten -- | Approximate number of common digits in the maximum element. relativeError' :: (Normed c t, Container c t) => c t -> c t -> Int relativeError' x y = dig (norm (x `sub` y) / norm x) where norm = pnorm Infinity dig r = round $ -logBase 10 (realToFrac r :: Double) relativeError :: Num a => (a -> Double) -> a -> a -> Double relativeError norm a b = r where na = norm a nb = norm b nab = norm (a-b) mx = max na nb mn = min na nb r = if mn < peps then mx else nab/mx ---------------------------------------------------------------------- -- | Generalized symmetric positive definite eigensystem Av = lBv, -- for A and B symmetric, B positive definite. geigSH :: Field t => Herm t -- ^ A -> Herm t -- ^ B -> (Vector Double, Matrix t) geigSH (Herm a) (Herm b) = geigSH' a b geigSH' :: Field t => Matrix t -- ^ A -> Matrix t -- ^ B -> (Vector Double, Matrix t) geigSH' a b = (l,v') where u = cholSH b iu = inv u c = ctrans iu <> a <> iu (l,v) = eigSH' c v' = iu <> v (<>) = mXm -------------------------------------------------------------------------------- -- | A matrix that, by construction, it is known to be complex Hermitian or real symmetric. -- -- It can be created using 'sym', 'mTm', or 'trustSym', and the matrix can be extracted using 'unSym'. newtype Herm t = Herm (Matrix t) deriving Show instance (NFData t, Numeric t) => NFData (Herm t) where rnf (Herm m) = rnf m -- | Extract the general matrix from a 'Herm' structure, forgetting its symmetric or Hermitian property. unSym :: Herm t -> Matrix t unSym (Herm x) = x -- | Compute the complex Hermitian or real symmetric part of a square matrix (@(x + tr x)/2@). sym :: Field t => Matrix t -> Herm t sym x = Herm (scale 0.5 (tr x `add` x)) -- | Compute the contraction @tr x <> x@ of a general matrix. mTm :: Numeric t => Matrix t -> Herm t mTm x = Herm (tr x `mXm` x) instance Field t => Linear t Herm where scale x (Herm m) = Herm (scale x m) instance Field t => Additive (Herm t) where add (Herm a) (Herm b) = Herm (a `add` b) -- | At your own risk, declare that a matrix is complex Hermitian or real symmetric -- for usage in 'chol', 'eigSH', etc. Only a triangular part of the matrix will be used. trustSym :: Matrix t -> Herm t trustSym x = (Herm x) hmatrix-0.19.0.0/src/Internal/Random.hs0000644000000000000000000000444713223170642015731 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Numeric.LinearAlgebra.Random -- Copyright : (c) Alberto Ruiz 2009-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Random vectors and matrices. -- ----------------------------------------------------------------------------- module Internal.Random ( Seed, RandDist(..), randomVector, gaussianSample, uniformSample, rand, randn ) where import Internal.Vectorized import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Algorithms import System.Random(randomIO) -- | Obtains a matrix whose rows are pseudorandom samples from a multivariate -- Gaussian distribution. gaussianSample :: Seed -> Int -- ^ number of rows -> Vector Double -- ^ mean vector -> Herm Double -- ^ covariance matrix -> Matrix Double -- ^ result gaussianSample seed n med cov = m where c = dim med meds = konst' 1 n `outer` med rs = reshape c $ randomVector seed Gaussian (c * n) m = rs `mXm` chol cov `add` meds -- | Obtains a matrix whose rows are pseudorandom samples from a multivariate -- uniform distribution. uniformSample :: Seed -> Int -- ^ number of rows -> [(Double,Double)] -- ^ ranges for each column -> Matrix Double -- ^ result uniformSample seed n rgs = m where (as,bs) = unzip rgs a = fromList as cs = zipWith subtract as bs d = dim a dat = toRows $ reshape n $ randomVector seed Uniform (n*d) am = konst' 1 n `outer` a m = fromColumns (zipWith scale cs dat) `add` am -- | pseudorandom matrix with uniform elements between 0 and 1 randm :: RandDist -> Int -- ^ rows -> Int -- ^ columns -> IO (Matrix Double) randm d r c = do seed <- randomIO return (reshape c $ randomVector seed d (r*c)) -- | pseudorandom matrix with uniform elements between 0 and 1 rand :: Int -> Int -> IO (Matrix Double) rand = randm Uniform {- | pseudorandom matrix with normal elements >>> disp 3 =<< randn 3 5 3x5 0.386 -1.141 0.491 -0.510 1.512 0.069 -0.919 1.022 -0.181 0.745 0.313 -0.670 -0.097 -1.575 -0.583 -} randn :: Int -> Int -> IO (Matrix Double) randn = randm Gaussian hmatrix-0.19.0.0/src/Internal/Container.hs0000644000000000000000000001662313267060772016444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.Container -- Copyright : (c) Alberto Ruiz 2010-14 -- License : BSD3 -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Basic numeric operations on 'Vector' and 'Matrix', including conversion routines. -- -- The 'Container' class is used to define optimized generic functions which work -- on 'Vector' and 'Matrix' with real or complex elements. -- -- Some of these functions are also available in the instances of the standard -- numeric Haskell classes provided by "Numeric.LinearAlgebra". -- ----------------------------------------------------------------------------- module Internal.Container where import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Numeric import Internal.Algorithms(Field,linearSolveSVD,Herm,mTm) #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif ------------------------------------------------------------------ {- | Creates a real vector containing a range of values: >>> linspace 5 (-3,7::Double) fromList [-3.0,-0.5,2.0,4.5,7.0]@ >>> linspace 5 (8,2+i) :: Vector (Complex Double) fromList [8.0 :+ 0.0,6.5 :+ 0.25,5.0 :+ 0.5,3.5 :+ 0.75,2.0 :+ 1.0] Logarithmic spacing can be defined as follows: @logspace n (a,b) = 10 ** linspace n (a,b)@ -} linspace :: (Fractional e, Container Vector e) => Int -> (e, e) -> Vector e linspace 0 _ = fromList[] linspace 1 (a,b) = fromList[(a+b)/2] linspace n (a,b) = addConstant a $ scale s $ fromList $ map fromIntegral [0 .. n-1] where s = (b-a)/fromIntegral (n-1) -------------------------------------------------------------------------------- infixr 8 <.> {- | An infix synonym for 'dot' >>> vector [1,2,3,4] <.> vector [-2,0,1,1] 5.0 >>> let 𝑖 = 0:+1 :: C >>> fromList [1+𝑖,1] <.> fromList [1,1+𝑖] 2.0 :+ 0.0 -} (<.>) :: Numeric t => Vector t -> Vector t -> t (<.>) = dot {- | dense matrix-vector product >>> let m = (2><3) [1..] >>> m (2><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 ] >>> let v = vector [10,20,30] >>> m #> v fromList [140.0,320.0] -} infixr 8 #> (#>) :: Numeric t => Matrix t -> Vector t -> Vector t (#>) = mXv -- | dense matrix-vector product app :: Numeric t => Matrix t -> Vector t -> Vector t app = (#>) infixl 8 <# -- | dense vector-matrix product (<#) :: Numeric t => Vector t -> Matrix t -> Vector t (<#) = vXm -------------------------------------------------------------------------------- class Mul a b c | a b -> c where infixl 7 <> -- | Matrix-matrix, matrix-vector, and vector-matrix products. (<>) :: Product t => a t -> b t -> c t instance Mul Matrix Matrix Matrix where (<>) = mXm instance Mul Matrix Vector Vector where (<>) m v = flatten $ m <> asColumn v instance Mul Vector Matrix Vector where (<>) v m = flatten $ asRow v <> m -------------------------------------------------------------------------------- {- | Least squares solution of a linear system, similar to the \\ operator of Matlab\/Octave (based on linearSolveSVD) @ a = (3><2) [ 1.0, 2.0 , 2.0, 4.0 , 2.0, -1.0 ] @ @ v = vector [13.0,27.0,1.0] @ >>> let x = a <\> v >>> x fromList [3.0799999999999996,5.159999999999999] >>> a #> x fromList [13.399999999999999,26.799999999999997,1.0] It also admits multiple right-hand sides stored as columns in a matrix. -} infixl 7 <\> (<\>) :: (LSDiv c, Field t) => Matrix t -> c t -> c t (<\>) = linSolve class LSDiv c where linSolve :: Field t => Matrix t -> c t -> c t instance LSDiv Vector where linSolve m v = flatten (linearSolveSVD m (reshape 1 v)) instance LSDiv Matrix where linSolve = linearSolveSVD -------------------------------------------------------------------------------- class Build d f c e | d -> c, c -> d, f -> e, f -> d, f -> c, c e -> f, d e -> f where -- | -- >>> build 5 (**2) :: Vector Double -- fromList [0.0,1.0,4.0,9.0,16.0] -- -- Hilbert matrix of order N: -- -- >>> let hilb n = build (n,n) (\i j -> 1/(i+j+1)) :: Matrix Double -- >>> putStr . dispf 2 $ hilb 3 -- 3x3 -- 1.00 0.50 0.33 -- 0.50 0.33 0.25 -- 0.33 0.25 0.20 -- build :: d -> f -> c e instance Container Vector e => Build Int (e -> e) Vector e where build = build' instance Container Matrix e => Build (Int,Int) (e -> e -> e) Matrix e where build = build' -------------------------------------------------------------------------------- -- @dot u v = 'udot' ('conj' u) v@ dot :: (Numeric t) => Vector t -> Vector t -> t dot u v = udot (conj u) v -------------------------------------------------------------------------------- optimiseMult :: Monoid (Matrix t) => [Matrix t] -> Matrix t optimiseMult = mconcat -------------------------------------------------------------------------------- {- | Compute mean vector and covariance matrix of the rows of a matrix. >>> meanCov $ gaussianSample 666 1000 (fromList[4,5]) (diagl[2,3]) (fromList [4.010341078059521,5.0197204699640405], (2><2) [ 1.9862461923890056, -1.0127225830525157e-2 , -1.0127225830525157e-2, 3.0373954915729318 ]) -} meanCov :: Matrix Double -> (Vector Double, Herm Double) meanCov x = (med,cov) where r = rows x k = 1 / fromIntegral r med = konst k r `vXm` x meds = konst 1 r `outer` med xc = x `sub` meds cov = scale (recip (fromIntegral (r-1))) (mTm xc) -------------------------------------------------------------------------------- sortVector :: (Ord t, Element t) => Vector t -> Vector t sortVector = sortV {- | >>> m <- randn 4 10 >>> disp 2 m 4x10 -0.31 0.41 0.43 -0.19 -0.17 -0.23 -0.17 -1.04 -0.07 -1.24 0.26 0.19 0.14 0.83 -1.54 -0.09 0.37 -0.63 0.71 -0.50 -0.11 -0.10 -1.29 -1.40 -1.04 -0.89 -0.68 0.35 -1.46 1.86 1.04 -0.29 0.19 -0.75 -2.20 -0.01 1.06 0.11 -2.09 -1.58 >>> disp 2 $ m ?? (All, Pos $ sortIndex (m!1)) 4x10 -0.17 -1.04 -1.24 -0.23 0.43 0.41 -0.31 -0.17 -0.07 -0.19 -1.54 -0.63 -0.50 -0.09 0.14 0.19 0.26 0.37 0.71 0.83 -1.04 0.35 1.86 -0.89 -1.29 -0.10 -0.11 -0.68 -1.46 -1.40 -2.20 0.11 -1.58 -0.01 0.19 -0.29 1.04 1.06 -2.09 -0.75 -} sortIndex :: (Ord t, Element t) => Vector t -> Vector I sortIndex = sortI ccompare :: (Ord t, Container c t) => c t -> c t -> c I ccompare = ccompare' cselect :: (Container c t) => c I -> c t -> c t -> c t -> c t cselect = cselect' {- | Extract elements from positions given in matrices of rows and columns. >>> r (3><3) [ 1, 1, 1 , 1, 2, 2 , 1, 2, 3 ] >>> c (3><3) [ 0, 1, 5 , 2, 2, 1 , 4, 4, 1 ] >>> m (4><6) [ 0, 1, 2, 3, 4, 5 , 6, 7, 8, 9, 10, 11 , 12, 13, 14, 15, 16, 17 , 18, 19, 20, 21, 22, 23 ] >>> remap r c m (3><3) [ 6, 7, 11 , 8, 14, 13 , 10, 16, 19 ] The indexes are autoconformable. >>> c' (3><1) [ 1 , 2 , 4 ] >>> remap r c' m (3><3) [ 7, 7, 7 , 8, 14, 14 , 10, 16, 22 ] -} remap :: Element t => Matrix I -> Matrix I -> Matrix t -> Matrix t remap i j m | minElement i >= 0 && maxElement i < fromIntegral (rows m) && minElement j >= 0 && maxElement j < fromIntegral (cols m) = remapM i' j' m | otherwise = error $ "out of range index in remap" where [i',j'] = conformMs [i,j] hmatrix-0.19.0.0/src/Internal/Sparse.hs0000644000000000000000000001247613260621005015742 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Internal.Sparse( GMatrix(..), CSR(..), mkCSR, fromCSR, mkSparse, mkDiagR, mkDense, AssocMatrix, toDense, gmXv, (!#>) )where import Internal.Vector import Internal.Matrix import Internal.Numeric import qualified Data.Vector.Storable as V import Data.Function(on) import Control.Arrow((***)) import Control.Monad(when) import Data.List(groupBy, sort) import Foreign.C.Types(CInt(..)) import Internal.Devel import System.IO.Unsafe(unsafePerformIO) import Foreign(Ptr) import Text.Printf(printf) infixl 0 ~!~ c ~!~ msg = when c (error msg) type AssocMatrix = [((Int,Int),Double)] data CSR = CSR { csrVals :: Vector Double , csrCols :: Vector CInt , csrRows :: Vector CInt , csrNRows :: Int , csrNCols :: Int } deriving Show data CSC = CSC { cscVals :: Vector Double , cscRows :: Vector CInt , cscCols :: Vector CInt , cscNRows :: Int , cscNCols :: Int } deriving Show mkCSR :: AssocMatrix -> CSR mkCSR sm' = CSR{..} where sm = sort sm' rws = map ((fromList *** fromList) . unzip . map ((succ.fi.snd) *** id) ) . groupBy ((==) `on` (fst.fst)) $ sm rszs = map (fi . dim . fst) rws csrRows = fromList (scanl (+) 1 rszs) csrVals = vjoin (map snd rws) csrCols = vjoin (map fst rws) csrNRows = dim csrRows - 1 csrNCols = fromIntegral (V.maximum csrCols) {- | General matrix with specialized internal representations for dense, sparse, diagonal, banded, and constant elements. >>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)] >>> m SparseR {gmCSR = CSR {csrVals = fromList [1.0,2.0], csrCols = fromList [1000,2000], csrRows = fromList [1,2,3], csrNRows = 2, csrNCols = 2000}, nRows = 2, nCols = 2000} >>> let m = mkDense (mat 2 [1..4]) >>> m Dense {gmDense = (2><2) [ 1.0, 2.0 , 3.0, 4.0 ], nRows = 2, nCols = 2} -} data GMatrix = SparseR { gmCSR :: CSR , nRows :: Int , nCols :: Int } | SparseC { gmCSC :: CSC , nRows :: Int , nCols :: Int } | Diag { diagVals :: Vector Double , nRows :: Int , nCols :: Int } | Dense { gmDense :: Matrix Double , nRows :: Int , nCols :: Int } -- | Banded deriving Show mkDense :: Matrix Double -> GMatrix mkDense m = Dense{..} where gmDense = m nRows = rows m nCols = cols m mkSparse :: AssocMatrix -> GMatrix mkSparse = fromCSR . mkCSR fromCSR :: CSR -> GMatrix fromCSR csr = SparseR {..} where gmCSR @ CSR {..} = csr nRows = csrNRows nCols = csrNCols mkDiagR r c v | dim v <= min r c = Diag{..} | otherwise = error $ printf "mkDiagR: incorrect sizes (%d,%d) [%d]" r c (dim v) where nRows = r nCols = c diagVals = v type IV t = CInt -> Ptr CInt -> t type V t = CInt -> Ptr Double -> t type SMxV = V (IV (IV (V (V (IO CInt))))) gmXv :: GMatrix -> Vector Double -> Vector Double gmXv SparseR { gmCSR = CSR{..}, .. } v = unsafePerformIO $ do dim v /= nCols ~!~ printf "gmXv (CSR): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) r <- createVector nRows (csrVals # csrCols # csrRows # v #! r) c_smXv #|"CSRXv" return r gmXv SparseC { gmCSC = CSC{..}, .. } v = unsafePerformIO $ do dim v /= nCols ~!~ printf "gmXv (CSC): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) r <- createVector nRows (cscVals # cscRows # cscCols # v #! r) c_smTXv #|"CSCXv" return r gmXv Diag{..} v | dim v == nCols = vjoin [ subVector 0 (dim diagVals) v `mul` diagVals , konst 0 (nRows - dim diagVals) ] | otherwise = error $ printf "gmXv (Diag): incorrect sizes: (%d,%d) [%d] x %d" nRows nCols (dim diagVals) (dim v) gmXv Dense{..} v | dim v == nCols = mXv gmDense v | otherwise = error $ printf "gmXv (Dense): incorrect sizes: (%d,%d) x %d" nRows nCols (dim v) {- | general matrix - vector product >>> let m = mkSparse [((0,999),1.0),((1,1999),2.0)] >>> m !#> vector [1..2000] fromList [1000.0,4000.0] -} infixr 8 !#> (!#>) :: GMatrix -> Vector Double -> Vector Double (!#>) = gmXv -------------------------------------------------------------------------------- foreign import ccall unsafe "smXv" c_smXv :: SMxV foreign import ccall unsafe "smTXv" c_smTXv :: SMxV -------------------------------------------------------------------------------- toDense :: AssocMatrix -> Matrix Double toDense asm = assoc (r+1,c+1) 0 asm where (r,c) = (maximum *** maximum) . unzip . map fst $ asm instance Transposable CSR CSC where tr (CSR vs cs rs n m) = CSC vs cs rs m n tr' = tr instance Transposable CSC CSR where tr (CSC vs rs cs n m) = CSR vs rs cs m n tr' = tr instance Transposable GMatrix GMatrix where tr (SparseR s n m) = SparseC (tr s) m n tr (SparseC s n m) = SparseR (tr s) m n tr (Diag v n m) = Diag v m n tr (Dense a n m) = Dense (tr a) m n tr' = tr hmatrix-0.19.0.0/src/Internal/Convolution.hs0000644000000000000000000001030413223170642017015 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- {- | Module : Internal.Convolution Copyright : (c) Alberto Ruiz 2012 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- {-# OPTIONS_HADDOCK hide #-} module Internal.Convolution( corr, conv, corrMin, corr2, conv2, separable ) where import qualified Data.Vector.Storable as SV import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Element import Internal.Conversion import Internal.Container #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif vectSS :: Element t => Int -> Vector t -> Matrix t vectSS n v = fromRows [ subVector k n v | k <- [0 .. dim v - n] ] corr :: (Container Vector t, Product t) => Vector t -- ^ kernel -> Vector t -- ^ source -> Vector t {- ^ correlation >>> corr (fromList[1,2,3]) (fromList [1..10]) fromList [14.0,20.0,26.0,32.0,38.0,44.0,50.0,56.0] -} corr ker v | dim ker == 0 = konst 0 (dim v) | dim ker <= dim v = vectSS (dim ker) v <> ker | otherwise = error $ "corr: dim kernel ("++show (dim ker)++") > dim vector ("++show (dim v)++")" conv :: (Container Vector t, Product t, Num t) => Vector t -> Vector t -> Vector t {- ^ convolution ('corr' with reversed kernel and padded input, equivalent to polynomial product) >>> conv (fromList[1,1]) (fromList [-1,1]) fromList [-1.0,0.0,1.0] -} conv ker v | dim ker == 0 = konst 0 (dim v) | otherwise = corr ker' v' where ker' = SV.reverse ker v' = vjoin [z,v,z] z = konst 0 (dim ker -1) corrMin :: (Container Vector t, RealElement t, Product t) => Vector t -> Vector t -> Vector t -- ^ similar to 'corr', using 'min' instead of (*) corrMin ker v | dim ker == 0 = error "corrMin: empty kernel" | otherwise = minEvery ss (asRow ker) <> ones where minEvery a b = cond a b a a b ss = vectSS (dim ker) v ones = konst 1 (dim ker) matSS :: Element t => Int -> Matrix t -> [Matrix t] matSS dr m = map (reshape c) [ subVector (k*c) n v | k <- [0 .. r - dr] ] where v = flatten m c = cols m r = rows m n = dr*c {- | 2D correlation (without padding) >>> disp 5 $ corr2 (konst 1 (3,3)) (ident 10 :: Matrix Double) 8x8 3 2 1 0 0 0 0 0 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 1 0 0 0 0 1 2 3 2 0 0 0 0 0 1 2 3 -} corr2 :: Product a => Matrix a -> Matrix a -> Matrix a corr2 ker mat = dims . concatMap (map (udot ker' . flatten) . matSS c . trans) . matSS r $ mat where r = rows ker c = cols ker ker' = flatten (trans ker) rr = rows mat - r + 1 rc = cols mat - c + 1 dims | rr > 0 && rc > 0 = (rr >< rc) | otherwise = error $ "corr2: dim kernel ("++sz ker++") > dim matrix ("++sz mat++")" sz m = show (rows m)++"x"++show (cols m) -- TODO check empty kernel {- | 2D convolution >>> disp 5 $ conv2 (konst 1 (3,3)) (ident 10 :: Matrix Double) 12x12 1 1 1 0 0 0 0 0 0 0 0 0 1 2 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 3 2 1 0 0 0 0 0 0 0 0 1 2 2 1 0 0 0 0 0 0 0 0 0 1 1 1 -} conv2 :: (Num (Matrix a), Product a, Container Vector a) => Matrix a -- ^ kernel -> Matrix a -> Matrix a conv2 k m | empty = konst 0 (rows m + r -1, cols m + c -1) | otherwise = corr2 (fliprl . flipud $ k) padded where padded = fromBlocks [[z,0,0] ,[0,m,0] ,[0,0,z]] r = rows k c = cols k z = konst 0 (r-1,c-1) empty = r == 0 || c == 0 separable :: Element t => (Vector t -> Vector t) -> Matrix t -> Matrix t -- ^ matrix computation implemented as separated vector operations by rows and columns. separable f = fromColumns . map f . toColumns . fromRows . map f . toRows hmatrix-0.19.0.0/src/Internal/Chain.hs0000644000000000000000000001272613260621005015525 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- | -- Module : Internal.Chain -- Copyright : (c) Vivian McPhail 2010 -- License : BSD3 -- -- Maintainer : Vivian McPhail gmail.com> -- Stability : provisional -- Portability : portable -- -- optimisation of association order for chains of matrix multiplication -- ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-} module Internal.Chain ( optimiseMult, ) where import Data.Maybe import Internal.Matrix import Internal.Numeric import qualified Data.Array.IArray as A ----------------------------------------------------------------------------- {- | Provide optimal association order for a chain of matrix multiplications and apply the multiplications. The algorithm is the well-known O(n\^3) dynamic programming algorithm that builds a pyramid of optimal associations. > m1, m2, m3, m4 :: Matrix Double > m1 = (10><15) [1..] > m2 = (15><20) [1..] > m3 = (20><5) [1..] > m4 = (5><10) [1..] > >>> optimiseMult [m1,m2,m3,m4] will perform @((m1 `multiply` (m2 `multiply` m3)) `multiply` m4)@ The naive left-to-right multiplication would take @4500@ scalar multiplications whereas the optimised version performs @2750@ scalar multiplications. The complexity in this case is 32 (= 4^3/2) * (2 comparisons, 3 scalar multiplications, 3 scalar additions, 5 lookups, 2 updates) + a constant (= three table allocations) -} optimiseMult :: Product t => [Matrix t] -> Matrix t optimiseMult = chain ----------------------------------------------------------------------------- type Matrices a = A.Array Int (Matrix a) type Sizes = A.Array Int (Int,Int) type Cost = A.Array Int (A.Array Int (Maybe Int)) type Indexes = A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int)))) update :: A.Array Int (A.Array Int a) -> (Int,Int) -> a -> A.Array Int (A.Array Int a) update a (r,c) e = a A.// [(r,(a A.! r) A.// [(c,e)])] newWorkSpaceCost :: Int -> A.Array Int (A.Array Int (Maybe Int)) newWorkSpaceCost n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n] where subArray i = A.listArray (1,i) (repeat Nothing) newWorkSpaceIndexes :: Int -> A.Array Int (A.Array Int (Maybe ((Int,Int),(Int,Int)))) newWorkSpaceIndexes n = A.array (1,n) $ map (\i -> (i, subArray i)) [1..n] where subArray i = A.listArray (1,i) (repeat Nothing) matricesToSizes :: [Matrix a] -> Sizes matricesToSizes ms = A.listArray (1,length ms) $ map (\m -> (rows m,cols m)) ms chain :: Product a => [Matrix a] -> Matrix a chain [] = error "chain: zero matrices to multiply" chain [m] = m chain [ml,mr] = ml `multiply` mr chain ms = let ln = length ms ma = A.listArray (1,ln) ms mz = matricesToSizes ms i = chain_cost mz in chain_paren (ln,ln) i ma chain_cost :: Sizes -> Indexes chain_cost mz = let (_,u) = A.bounds mz cost = newWorkSpaceCost u ixes = newWorkSpaceIndexes u (_,_,i) = foldl chain_cost' (mz,cost,ixes) (order u) in i chain_cost' :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes) chain_cost' sci@(mz,cost,ixes) (r,c) | c == 1 = let cost' = update cost (r,c) (Just 0) ixes' = update ixes (r,c) (Just ((r,c),(r,c))) in (mz,cost',ixes') | otherwise = minimum_cost sci (r,c) minimum_cost :: (Sizes,Cost,Indexes) -> (Int,Int) -> (Sizes,Cost,Indexes) minimum_cost sci fu = foldl (smaller_cost fu) sci (fulcrum_order fu) smaller_cost :: (Int,Int) -> (Sizes,Cost,Indexes) -> ((Int,Int),(Int,Int)) -> (Sizes,Cost,Indexes) smaller_cost (r,c) (mz,cost,ixes) ix@((lr,lc),(rr,rc)) = let op_cost = fromJust ((cost A.! lr) A.! lc) + fromJust ((cost A.! rr) A.! rc) + fst (mz A.! (lr-lc+1)) * snd (mz A.! lc) * snd (mz A.! rr) cost' = (cost A.! r) A.! c in case cost' of Nothing -> let cost'' = update cost (r,c) (Just op_cost) ixes'' = update ixes (r,c) (Just ix) in (mz,cost'',ixes'') Just ct -> if op_cost < ct then let cost'' = update cost (r,c) (Just op_cost) ixes'' = update ixes (r,c) (Just ix) in (mz,cost'',ixes'') else (mz,cost,ixes) fulcrum_order (r,c) = let fs' = zip (repeat r) [1..(c-1)] in map (partner (r,c)) fs' partner (r,c) (a,b) = ((r-b, c-b), (a,b)) order 0 = [] order n = order (n-1) ++ zip (repeat n) [1..n] chain_paren :: Product a => (Int,Int) -> Indexes -> Matrices a -> Matrix a chain_paren (r,c) ixes ma = let ((lr,lc),(rr,rc)) = fromJust $ (ixes A.! r) A.! c in if lr == rr && lc == rc then (ma A.! lr) else (chain_paren (lr,lc) ixes ma) `multiply` (chain_paren (rr,rc) ixes ma) -------------------------------------------------------------------------- {- TESTS -- optimal association is ((m1*(m2*m3))*m4) m1, m2, m3, m4 :: Matrix Double m1 = (10><15) [1..] m2 = (15><20) [1..] m3 = (20><5) [1..] m4 = (5><10) [1..] -} hmatrix-0.19.0.0/src/Numeric/Vector.hs0000644000000000000000000001327313260621005015571 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Vector -- Copyright : (c) Alberto Ruiz 2011 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Vector'. -- ----------------------------------------------------------------------------- module Numeric.Vector () where import Internal.Vectorized import Internal.Vector import Internal.Numeric import Internal.Conversion import Foreign.Storable(Storable) ------------------------------------------------------------------- adaptScalar :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2) => (t1 -> Vector t2 -> t) -> (Vector t1 -> Vector t2 -> t) -> (Vector t1 -> t2 -> t) -> Vector t1 -> Vector t2 -> t adaptScalar f1 f2 f3 x y | dim x == 1 = f1 (x@>0) y | dim y == 1 = f3 x (y@>0) | otherwise = f2 x y ------------------------------------------------------------------ instance Num (Vector I) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapI Sign abs = vectorMapI Abs fromInteger = fromList . return . fromInteger instance Num (Vector Z) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapL Sign abs = vectorMapL Abs fromInteger = fromList . return . fromInteger instance Num (Vector Float) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapF Sign abs = vectorMapF Abs fromInteger = fromList . return . fromInteger instance Num (Vector Double) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapR Sign abs = vectorMapR Abs fromInteger = fromList . return . fromInteger instance Num (Vector (Complex Double)) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapC Sign abs = vectorMapC Abs fromInteger = fromList . return . fromInteger instance Num (Vector (Complex Float)) where (+) = adaptScalar addConstant add (flip addConstant) negate = scale (-1) (*) = adaptScalar scale mul (flip scale) signum = vectorMapQ Sign abs = vectorMapQ Abs fromInteger = fromList . return . fromInteger --------------------------------------------------- instance (Container Vector a, Num (Vector a), Fractional a) => Fractional (Vector a) where fromRational n = fromList [fromRational n] (/) = adaptScalar f divide g where r `f` v = scaleRecip r v v `g` r = scale (recip r) v ------------------------------------------------------- instance Floating (Vector Float) where sin = vectorMapF Sin cos = vectorMapF Cos tan = vectorMapF Tan asin = vectorMapF ASin acos = vectorMapF ACos atan = vectorMapF ATan sinh = vectorMapF Sinh cosh = vectorMapF Cosh tanh = vectorMapF Tanh asinh = vectorMapF ASinh acosh = vectorMapF ACosh atanh = vectorMapF ATanh exp = vectorMapF Exp log = vectorMapF Log sqrt = vectorMapF Sqrt (**) = adaptScalar (vectorMapValF PowSV) (vectorZipF Pow) (flip (vectorMapValF PowVS)) pi = fromList [pi] ------------------------------------------------------------- instance Floating (Vector Double) where sin = vectorMapR Sin cos = vectorMapR Cos tan = vectorMapR Tan asin = vectorMapR ASin acos = vectorMapR ACos atan = vectorMapR ATan sinh = vectorMapR Sinh cosh = vectorMapR Cosh tanh = vectorMapR Tanh asinh = vectorMapR ASinh acosh = vectorMapR ACosh atanh = vectorMapR ATanh exp = vectorMapR Exp log = vectorMapR Log sqrt = vectorMapR Sqrt (**) = adaptScalar (vectorMapValR PowSV) (vectorZipR Pow) (flip (vectorMapValR PowVS)) pi = fromList [pi] ------------------------------------------------------------- instance Floating (Vector (Complex Double)) where sin = vectorMapC Sin cos = vectorMapC Cos tan = vectorMapC Tan asin = vectorMapC ASin acos = vectorMapC ACos atan = vectorMapC ATan sinh = vectorMapC Sinh cosh = vectorMapC Cosh tanh = vectorMapC Tanh asinh = vectorMapC ASinh acosh = vectorMapC ACosh atanh = vectorMapC ATanh exp = vectorMapC Exp log = vectorMapC Log sqrt = vectorMapC Sqrt (**) = adaptScalar (vectorMapValC PowSV) (vectorZipC Pow) (flip (vectorMapValC PowVS)) pi = fromList [pi] ----------------------------------------------------------- instance Floating (Vector (Complex Float)) where sin = vectorMapQ Sin cos = vectorMapQ Cos tan = vectorMapQ Tan asin = vectorMapQ ASin acos = vectorMapQ ACos atan = vectorMapQ ATan sinh = vectorMapQ Sinh cosh = vectorMapQ Cosh tanh = vectorMapQ Tanh asinh = vectorMapQ ASinh acosh = vectorMapQ ACosh atanh = vectorMapQ ATanh exp = vectorMapQ Exp log = vectorMapQ Log sqrt = vectorMapQ Sqrt (**) = adaptScalar (vectorMapValQ PowSV) (vectorZipQ Pow) (flip (vectorMapValQ PowVS)) pi = fromList [pi] hmatrix-0.19.0.0/src/Internal/CG.hs0000644000000000000000000001200313260621005014760 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Internal.CG( cgSolve, cgSolve', CGState(..), R, V ) where import Internal.Vector import Internal.Matrix import Internal.Numeric import Internal.Element import Internal.IO import Internal.Container import Internal.Sparse import Numeric.Vector() import Internal.Algorithms(linearSolveLS, linearSolve, relativeError, pnorm, NormType(..)) import Control.Arrow((***)) {- import Util.Misc(debug, debugMat) (//) :: Show a => a -> String -> a infix 0 // -- , /// a // b = debug b id a (///) :: V -> String -> V infix 0 /// v /// b = debugMat b 2 asRow v -} type V = Vector R data CGState = CGState { cgp :: Vector R -- ^ conjugate gradient , cgr :: Vector R -- ^ residual , cgr2 :: R -- ^ squared norm of residual , cgx :: Vector R -- ^ current solution , cgdx :: R -- ^ normalized size of correction } cg :: Bool -> (V -> V) -> (V -> V) -> CGState -> CGState cg sym at a (CGState p r r2 x _) = CGState p' r' r'2 x' rdx where ap1 = a p ap | sym = ap1 | otherwise = at ap1 pap | sym = p <.> ap1 | otherwise = norm2 ap1 ** 2 alpha = r2 / pap dx = scale alpha p x' = x + dx r' = r - scale alpha ap r'2 = r' <.> r' beta = r'2 / r2 p' = r' + scale beta p rdx = norm2 dx / max 1 (norm2 x) conjugrad :: Bool -> GMatrix -> V -> V -> R -> R -> [CGState] conjugrad sym a b = solveG sym (tr a !#>) (a !#>) (cg sym) b solveG :: Bool -> (V -> V) -> (V -> V) -> ((V -> V) -> (V -> V) -> CGState -> CGState) -> V -> V -> R -> R -> [CGState] solveG sym mat ma meth rawb x0' ϵb ϵx = takeUntil ok . iterate (meth mat ma) $ CGState p0 r0 r20 x0 1 where a = if sym then ma else mat . ma b = if sym then rawb else mat rawb x0 = if x0' == 0 then konst 0 (dim b) else x0' r0 = b - a x0 r20 = r0 <.> r0 p0 = r0 nb2 = b <.> b ok CGState {..} = cgr2 Bool) -> [a] -> [a] takeUntil q xs = a++ take 1 b where (a,b) = break q xs -- | Solve a sparse linear system using the conjugate gradient method with default parameters. cgSolve :: Bool -- ^ is symmetric -> GMatrix -- ^ coefficient matrix -> Vector R -- ^ right-hand side -> Vector R -- ^ solution cgSolve sym a b = cgx $ last $ cgSolve' sym 1E-4 1E-3 n a b 0 where n = max 10 (round $ sqrt (fromIntegral (dim b) :: Double)) -- | Solve a sparse linear system using the conjugate gradient method with default parameters. cgSolve' :: Bool -- ^ symmetric -> R -- ^ relative tolerance for the residual (e.g. 1E-4) -> R -- ^ relative tolerance for δx (e.g. 1E-3) -> Int -- ^ maximum number of iterations -> GMatrix -- ^ coefficient matrix -> Vector R -- ^ initial solution -> Vector R -- ^ right-hand side -> [CGState] -- ^ solution cgSolve' sym er es n a b x = take n $ conjugrad sym a b x er es -------------------------------------------------------------------------------- instance Testable GMatrix where checkT _ = (ok,info) where sma = convo2 20 3 x1 = vect [1..20] x2 = vect [1..40] sm = mkSparse sma dm = toDense sma s1 = sm !#> x1 d1 = dm #> x1 s2 = tr sm !#> x2 d2 = tr dm #> x2 sdia = mkDiagR 40 20 (vect [1..10]) s3 = sdia !#> x1 s4 = tr sdia !#> x2 ddia = diagRect 0 (vect [1..10]) 40 20 d3 = ddia #> x1 d4 = tr ddia #> x2 v = testb 40 s5 = cgSolve False sm v d5 = denseSolve dm v symassoc = [((0,0),1.0),((1,1),2.0),((0,1),0.5),((1,0),0.5)] b = vect [3,4] d6 = flatten $ linearSolve (toDense symassoc) (asColumn b) s6 = cgSolve True (mkSparse symassoc) b info = do print sm disp (toDense sma) print s1; print d1 print s2; print d2 print s3; print d3 print s4; print d4 print s5; print d5 print $ relativeError (pnorm Infinity) s5 d5 print s6; print d6 print $ relativeError (pnorm Infinity) s6 d6 ok = s1==d1 && s2==d2 && s3==d3 && s4==d4 && relativeError (pnorm Infinity) s5 d5 < 1E-10 && relativeError (pnorm Infinity) s6 d6 < 1E-10 disp = putStr . dispf 2 vect = fromList :: [Double] -> Vector Double convomat :: Int -> Int -> AssocMatrix convomat n k = [ ((i,j `mod` n),1) | i<-[0..n-1], j <- [i..i+k-1]] convo2 :: Int -> Int -> AssocMatrix convo2 n k = m1 ++ m2 where m1 = convomat n k m2 = map (((+n) *** id) *** id) m1 testb n = vect $ take n $ cycle ([0..10]++[9,8..1]) denseSolve a = flatten . linearSolveLS a . asColumn -- mkDiag v = mkDiagR (dim v) (dim v) v hmatrix-0.19.0.0/src/Numeric/Matrix.hs0000644000000000000000000000717313260621005015575 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Numeric.Matrix -- Copyright : (c) Alberto Ruiz 2014 -- License : BSD3 -- -- Maintainer : Alberto Ruiz -- Stability : provisional -- -- Provides instances of standard classes 'Show', 'Read', 'Eq', -- 'Num', 'Fractional', and 'Floating' for 'Matrix'. -- -- In arithmetic operations one-component -- vectors and matrices automatically expand to match the dimensions of the other operand. ----------------------------------------------------------------------------- module Numeric.Matrix ( ) where ------------------------------------------------------------------- import Internal.Vector import Internal.Matrix import Internal.Element import Internal.Numeric import qualified Data.Monoid as M import Data.List(partition) import qualified Data.Foldable as F import qualified Data.Semigroup as S import Internal.Chain import Foreign.Storable(Storable) ------------------------------------------------------------------- instance Container Matrix a => Eq (Matrix a) where (==) = equal instance (Container Matrix a, Num a, Num (Vector a)) => Num (Matrix a) where (+) = liftMatrix2Auto (+) (-) = liftMatrix2Auto (-) negate = liftMatrix negate (*) = liftMatrix2Auto (*) signum = liftMatrix signum abs = liftMatrix abs fromInteger = (1><1) . return . fromInteger --------------------------------------------------- instance (Container Vector a, Fractional a, Fractional (Vector a), Num (Matrix a)) => Fractional (Matrix a) where fromRational n = (1><1) [fromRational n] (/) = liftMatrix2Auto (/) --------------------------------------------------------- instance (Floating a, Container Vector a, Floating (Vector a), Fractional (Matrix a)) => Floating (Matrix a) where sin = liftMatrix sin cos = liftMatrix cos tan = liftMatrix tan asin = liftMatrix asin acos = liftMatrix acos atan = liftMatrix atan sinh = liftMatrix sinh cosh = liftMatrix cosh tanh = liftMatrix tanh asinh = liftMatrix asinh acosh = liftMatrix acosh atanh = liftMatrix atanh exp = liftMatrix exp log = liftMatrix log (**) = liftMatrix2Auto (**) sqrt = liftMatrix sqrt pi = (1><1) [pi] -------------------------------------------------------------------------------- isScalar :: Matrix t -> Bool isScalar m = rows m == 1 && cols m == 1 adaptScalarM :: (Foreign.Storable.Storable t1, Foreign.Storable.Storable t2) => (t1 -> Matrix t2 -> t) -> (Matrix t1 -> Matrix t2 -> t) -> (Matrix t1 -> t2 -> t) -> Matrix t1 -> Matrix t2 -> t adaptScalarM f1 f2 f3 x y | isScalar x = f1 (x @@>(0,0) ) y | isScalar y = f3 x (y @@>(0,0) ) | otherwise = f2 x y instance (Container Vector t, Eq t, Num (Vector t), Product t) => S.Semigroup (Matrix t) where (<>) = mappend sconcat = mconcat . F.toList instance (Container Vector t, Eq t, Num (Vector t), Product t) => M.Monoid (Matrix t) where mempty = 1 mappend = adaptScalarM scale mXm (flip scale) mconcat xs = work (partition isScalar xs) where work (ss,[]) = product ss work (ss,ms) = scl (product ss) (optimiseMult ms) scl x m | isScalar x && x00 == 1 = m | otherwise = scale x00 m where x00 = x @@> (0,0) hmatrix-0.19.0.0/src/Internal/Util.hs0000644000000000000000000005431613260621005015421 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- {- | Module : Internal.Util Copyright : (c) Alberto Ruiz 2013 License : BSD3 Maintainer : Alberto Ruiz Stability : provisional -} ----------------------------------------------------------------------------- module Internal.Util( -- * Convenience functions vector, matrix, disp, formatSparse, approxInt, dispDots, dispBlanks, formatShort, dispShort, zeros, ones, diagl, row, col, (&), (¦), (|||), (——), (===), (?), (¿), Indexable(..), size, Numeric, rand, randn, cross, norm, ℕ,ℤ,ℝ,ℂ,iC, Normed(..), norm_Frob, norm_nuclear, magnit, normalize, mt, (~!~), pairwiseD2, rowOuters, null1, null1sym, -- * Convolution -- ** 1D corr, conv, corrMin, -- ** 2D corr2, conv2, separable, block2x2,block3x3,view1,unView1,foldMatrix, gaussElim_1, gaussElim_2, gaussElim, luST, luSolve', luSolve'', luPacked', luPacked'', invershur ) where import Internal.Vector import Internal.Matrix hiding (size) import Internal.Numeric import Internal.Element import Internal.Container import Internal.Vectorized import Internal.IO import Internal.Algorithms hiding (Normed,linearSolve',luSolve', luPacked') import Numeric.Matrix() import Numeric.Vector() import Internal.Random import Internal.Convolution import Control.Monad(when,forM_) import Text.Printf import Data.List.Split(splitOn) import Data.List(intercalate,sortBy,foldl') import Control.Arrow((&&&),(***)) import Data.Complex import Data.Function(on) import Internal.ST #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif type ℝ = Double type ℕ = Int type ℤ = Int type ℂ = Complex Double -- | imaginary unit iC :: C iC = 0:+1 {- | Create a real vector. >>> vector [1..5] fromList [1.0,2.0,3.0,4.0,5.0] -} vector :: [R] -> Vector R vector = fromList {- | Create a real matrix. >>> matrix 5 [1..15] (3><5) [ 1.0, 2.0, 3.0, 4.0, 5.0 , 6.0, 7.0, 8.0, 9.0, 10.0 , 11.0, 12.0, 13.0, 14.0, 15.0 ] -} matrix :: Int -- ^ number of columns -> [R] -- ^ elements in row order -> Matrix R matrix c = reshape c . fromList {- | print a real matrix with given number of digits after the decimal point >>> disp 5 $ ident 2 / 3 2x2 0.33333 0.00000 0.00000 0.33333 -} disp :: Int -> Matrix Double -> IO () disp n = putStr . dispf n {- | create a real diagonal matrix from a list >>> diagl [1,2,3] (3><3) [ 1.0, 0.0, 0.0 , 0.0, 2.0, 0.0 , 0.0, 0.0, 3.0 ] -} diagl :: [Double] -> Matrix Double diagl = diag . fromList -- | a real matrix of zeros zeros :: Int -- ^ rows -> Int -- ^ columns -> Matrix Double zeros r c = konst 0 (r,c) -- | a real matrix of ones ones :: Int -- ^ rows -> Int -- ^ columns -> Matrix Double ones r c = konst 1 (r,c) -- | concatenation of real vectors infixl 3 & (&) :: Vector Double -> Vector Double -> Vector Double a & b = vjoin [a,b] {- | horizontal concatenation >>> ident 3 ||| konst 7 (3,4) (3><7) [ 1.0, 0.0, 0.0, 7.0, 7.0, 7.0, 7.0 , 0.0, 1.0, 0.0, 7.0, 7.0, 7.0, 7.0 , 0.0, 0.0, 1.0, 7.0, 7.0, 7.0, 7.0 ] -} infixl 3 ||| (|||) :: Element t => Matrix t -> Matrix t -> Matrix t a ||| b = fromBlocks [[a,b]] -- | a synonym for ('|||') (unicode 0x00a6, broken bar) infixl 3 ¦ (¦) :: Matrix Double -> Matrix Double -> Matrix Double (¦) = (|||) -- | vertical concatenation -- (===) :: Element t => Matrix t -> Matrix t -> Matrix t infixl 2 === a === b = fromBlocks [[a],[b]] -- | a synonym for ('===') (unicode 0x2014, em dash) (——) :: Matrix Double -> Matrix Double -> Matrix Double infixl 2 —— (——) = (===) -- | create a single row real matrix from a list -- -- >>> row [2,3,1,8] -- (1><4) -- [ 2.0, 3.0, 1.0, 8.0 ] -- row :: [Double] -> Matrix Double row = asRow . fromList -- | create a single column real matrix from a list -- -- >>> col [7,-2,4] -- (3><1) -- [ 7.0 -- , -2.0 -- , 4.0 ] -- col :: [Double] -> Matrix Double col = asColumn . fromList {- | extract rows >>> (20><4) [1..] ? [2,1,1] (3><4) [ 9.0, 10.0, 11.0, 12.0 , 5.0, 6.0, 7.0, 8.0 , 5.0, 6.0, 7.0, 8.0 ] -} infixl 9 ? (?) :: Element t => Matrix t -> [Int] -> Matrix t (?) = flip extractRows {- | extract columns (unicode 0x00bf, inverted question mark, Alt-Gr ?) >>> (3><4) [1..] ¿ [3,0] (3><2) [ 4.0, 1.0 , 8.0, 5.0 , 12.0, 9.0 ] -} infixl 9 ¿ (¿) :: Element t => Matrix t -> [Int] -> Matrix t (¿)= flip extractColumns cross :: Product t => Vector t -> Vector t -> Vector t -- ^ cross product (for three-element vectors) cross x y | dim x == 3 && dim y == 3 = fromList [z1,z2,z3] | otherwise = error $ "the cross product requires 3-element vectors (sizes given: " ++show (dim x)++" and "++show (dim y)++")" where [x1,x2,x3] = toList x [y1,y2,y3] = toList y z1 = x2*y3-x3*y2 z2 = x3*y1-x1*y3 z3 = x1*y2-x2*y1 {-# SPECIALIZE cross :: Vector Double -> Vector Double -> Vector Double #-} {-# SPECIALIZE cross :: Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-} norm :: Vector Double -> Double -- ^ 2-norm of real vector norm = pnorm PNorm2 -- | p-norm for vectors, operator norm for matrices class Normed a where norm_0 :: a -> R norm_1 :: a -> R norm_2 :: a -> R norm_Inf :: a -> R instance Normed (Vector R) where norm_0 v = sumElements (step (abs v - scalar (eps*normInf v))) norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Vector C) where norm_0 v = sumElements (step (fst (fromComplex (abs v)) - scalar (eps*normInf v))) norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Matrix R) where norm_0 = norm_0 . flatten norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Matrix C) where norm_0 = norm_0 . flatten norm_1 = pnorm PNorm1 norm_2 = pnorm PNorm2 norm_Inf = pnorm Infinity instance Normed (Vector I) where norm_0 = fromIntegral . sumElements . step . abs norm_1 = fromIntegral . norm1 norm_2 v = sqrt . fromIntegral $ dot v v norm_Inf = fromIntegral . normInf instance Normed (Vector Z) where norm_0 = fromIntegral . sumElements . step . abs norm_1 = fromIntegral . norm1 norm_2 v = sqrt . fromIntegral $ dot v v norm_Inf = fromIntegral . normInf instance Normed (Vector Float) where norm_0 = norm_0 . double norm_1 = norm_1 . double norm_2 = norm_2 . double norm_Inf = norm_Inf . double instance Normed (Vector (Complex Float)) where norm_0 = norm_0 . double norm_1 = norm_1 . double norm_2 = norm_2 . double norm_Inf = norm_Inf . double -- | Frobenius norm (Schatten p-norm with p=2) norm_Frob :: (Normed (Vector t), Element t) => Matrix t -> R norm_Frob = norm_2 . flatten -- | Sum of singular values (Schatten p-norm with p=1) norm_nuclear :: Field t => Matrix t -> R norm_nuclear = sumElements . singularValues {- | Check if the absolute value or complex magnitude is greater than a given threshold >>> magnit 1E-6 (1E-12 :: R) False >>> magnit 1E-6 (3+iC :: C) True >>> magnit 0 (3 :: I ./. 5) True -} magnit :: (Element t, Normed (Vector t)) => R -> t -> Bool magnit e x = norm_1 (fromList [x]) > e -- | Obtains a vector in the same direction with 2-norm=1 normalize :: (Normed (Vector t), Num (Vector t), Field t) => Vector t -> Vector t normalize v = v / real (scalar (norm_2 v)) -- | trans . inv mt :: Matrix Double -> Matrix Double mt = trans . inv -------------------------------------------------------------------------------- {- | >>> size $ vector [1..10] 10 >>> size $ (2><5)[1..10::Double] (2,5) -} size :: Container c t => c t -> IndexOf c size = size' {- | Alternative indexing function. >>> vector [1..10] ! 3 4.0 On a matrix it gets the k-th row as a vector: >>> matrix 5 [1..15] ! 1 fromList [6.0,7.0,8.0,9.0,10.0] >>> matrix 5 [1..15] ! 1 ! 3 9.0 -} class Indexable c t | c -> t , t -> c where infixl 9 ! (!) :: c -> Int -> t instance Indexable (Vector Double) Double where (!) = (@>) instance Indexable (Vector Float) Float where (!) = (@>) instance Indexable (Vector I) I where (!) = (@>) instance Indexable (Vector Z) Z where (!) = (@>) instance Indexable (Vector (Complex Double)) (Complex Double) where (!) = (@>) instance Indexable (Vector (Complex Float)) (Complex Float) where (!) = (@>) instance Element t => Indexable (Matrix t) (Vector t) where m!j = subVector (j*c) c (flatten m) where c = cols m -------------------------------------------------------------------------------- -- | Matrix of pairwise squared distances of row vectors -- (using the matrix product trick in blog.smola.org) pairwiseD2 :: Matrix Double -> Matrix Double -> Matrix Double pairwiseD2 x y | ok = x2 `outer` oy + ox `outer` y2 - 2* x <> trans y | otherwise = error $ "pairwiseD2 with different number of columns: " ++ show (size x) ++ ", " ++ show (size y) where ox = one (rows x) oy = one (rows y) oc = one (cols x) one k = konst 1 k x2 = x * x <> oc y2 = y * y <> oc ok = cols x == cols y -------------------------------------------------------------------------------- {- | outer products of rows >>> a (3><2) [ 1.0, 2.0 , 10.0, 20.0 , 100.0, 200.0 ] >>> b (3><3) [ 1.0, 2.0, 3.0 , 4.0, 5.0, 6.0 , 7.0, 8.0, 9.0 ] >>> rowOuters a (b ||| 1) (3><8) [ 1.0, 2.0, 3.0, 1.0, 2.0, 4.0, 6.0, 2.0 , 40.0, 50.0, 60.0, 10.0, 80.0, 100.0, 120.0, 20.0 , 700.0, 800.0, 900.0, 100.0, 1400.0, 1600.0, 1800.0, 200.0 ] -} rowOuters :: Matrix Double -> Matrix Double -> Matrix Double rowOuters a b = a' * b' where a' = kronecker a (ones 1 (cols b)) b' = kronecker (ones 1 (cols a)) b -------------------------------------------------------------------------------- -- | solution of overconstrained homogeneous linear system null1 :: Matrix R -> Vector R null1 = last . toColumns . snd . rightSV -- | solution of overconstrained homogeneous symmetric linear system null1sym :: Herm R -> Vector R null1sym = last . toColumns . snd . eigSH -------------------------------------------------------------------------------- infixl 0 ~!~ c ~!~ msg = when c (error msg) -------------------------------------------------------------------------------- formatSparse :: String -> String -> String -> Int -> Matrix Double -> String formatSparse zeroI _zeroF sep _ (approxInt -> Just m) = format sep f m where f 0 = zeroI f x = printf "%.0f" x formatSparse zeroI zeroF sep n m = format sep f m where f x | abs (x::Double) < 2*peps = zeroI++zeroF | abs (fromIntegral (round x::Int) - x) / abs x < 2*peps = printf ("%.0f."++replicate n ' ') x | otherwise = printf ("%."++show n++"f") x approxInt m | norm_Inf (v - vi) < 2*peps * norm_Inf v = Just (reshape (cols m) vi) | otherwise = Nothing where v = flatten m vi = roundVector v dispDots n = putStr . formatSparse "." (replicate n ' ') " " n dispBlanks n = putStr . formatSparse "" "" " " n formatShort sep fmt maxr maxc m = auxm4 where (rm,cm) = size m (r1,r2,r3) | rm <= maxr = (rm,0,0) | otherwise = (maxr-3,rm-maxr+1,2) (c1,c2,c3) | cm <= maxc = (cm,0,0) | otherwise = (maxc-3,cm-maxc+1,2) [ [a,_,b] ,[_,_,_] ,[c,_,d]] = toBlocks [r1,r2,r3] [c1,c2,c3] m auxm = fromBlocks [[a,b],[c,d]] auxm2 | cm > maxc = format "|" fmt auxm | otherwise = format sep fmt auxm auxm3 | cm > maxc = map (f . splitOn "|") (lines auxm2) | otherwise = (lines auxm2) f items = intercalate sep (take (maxc-3) items) ++ " .. " ++ intercalate sep (drop (maxc-3) items) auxm4 | rm > maxr = unlines (take (maxr-3) auxm3 ++ vsep : drop (maxr-3) auxm3) | otherwise = unlines auxm3 vsep = map g (head auxm3) g '.' = ':' g _ = ' ' dispShort :: Int -> Int -> Int -> Matrix Double -> IO () dispShort maxr maxc dec m = printf "%dx%d\n%s" (rows m) (cols m) (formatShort " " fmt maxr maxc m) where fmt = printf ("%."++show dec ++"f") -------------------------------------------------------------------------------- -- matrix views block2x2 r c m = [[m11,m12],[m21,m22]] where m11 = m ?? (Take r, Take c) m12 = m ?? (Take r, Drop c) m21 = m ?? (Drop r, Take c) m22 = m ?? (Drop r, Drop c) block3x3 r nr c nc m = [[m ?? (er !! i, ec !! j) | j <- [0..2] ] | i <- [0..2] ] where er = [ Range 0 1 (r-1), Range r 1 (r+nr-1), Drop (nr+r) ] ec = [ Range 0 1 (c-1), Range c 1 (c+nc-1), Drop (nc+c) ] view1 :: Numeric t => Matrix t -> Maybe (View1 t) view1 m | rows m > 0 && cols m > 0 = Just (e, flatten m12, flatten m21 , m22) | otherwise = Nothing where [[m11,m12],[m21,m22]] = block2x2 1 1 m e = m11 `atIndex` (0, 0) unView1 :: Numeric t => View1 t -> Matrix t unView1 (e,r,c,m) = fromBlocks [[scalar e, asRow r],[asColumn c, m]] type View1 t = (t, Vector t, Vector t, Matrix t) foldMatrix :: Numeric t => (Matrix t -> Matrix t) -> (View1 t -> View1 t) -> (Matrix t -> Matrix t) foldMatrix g f ( (f <$>) . view1 . g -> Just (e,r,c,m)) = unView1 (e, r, c, foldMatrix g f m) foldMatrix _ _ m = m swapMax k m | rows m > 0 && j>0 = (j, m ?? (Pos (idxs swapped), All)) | otherwise = (0,m) where j = maxIndex $ abs (tr m ! k) swapped = j:[1..j-1] ++ 0:[j+1..rows m-1] down g a = foldMatrix g f a where f (e,r,c,m) | e /= 0 = (1, r', 0, m - outer c r') | otherwise = error "singular!" where r' = r / scalar e -- | generic reference implementation of gaussian elimination -- -- @a <> gaussElim a b = b@ -- gaussElim_2 :: (Eq t, Fractional t, Num (Vector t), Numeric t) => Matrix t -> Matrix t -> Matrix t gaussElim_2 a b = flipudrl r where flipudrl = flipud . fliprl splitColsAt n = (takeColumns n &&& dropColumns n) go f x y = splitColsAt (cols a) (down f $ x ||| y) (a1,b1) = go (snd . swapMax 0) a b ( _, r) = go id (flipudrl $ a1) (flipudrl $ b1) -------------------------------------------------------------------------------- gaussElim_1 :: (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) => Matrix t -> Matrix t -> Matrix t gaussElim_1 x y = dropColumns (rows x) (flipud $ fromRows s2) where rs = toRows $ x ||| y s1 = fromRows $ pivotDown (rows x) 0 rs -- interesting s2 = pivotUp (rows x-1) (toRows $ flipud s1) pivotDown :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) => Int -> Int -> [Vector t] -> [Vector t] pivotDown t n xs | t == n = [] | otherwise = y : pivotDown t (n+1) ys where y:ys = redu (pivot n xs) pivot k = (const k &&& id) . sortBy (flip compare `on` (abs. (!k))) redu :: (Int, [Vector t]) -> [Vector t] redu (k,x:zs) | p == 0 = error "gauss: singular!" -- FIXME | otherwise = u : map f zs where p = x!k u = scale (recip (x!k)) x f z = z - scale (z!k) u redu (_,[]) = [] pivotUp :: forall t . (Fractional t, Num (Vector t), Ord t, Indexable (Vector t) t, Numeric t) => Int -> [Vector t] -> [Vector t] pivotUp n xs | n == -1 = [] | otherwise = y : pivotUp (n-1) ys where y:ys = redu' (n,xs) redu' :: (Int, [Vector t]) -> [Vector t] redu' (k,x:zs) = u : map f zs where u = x f z = z - scale (z!k) u redu' (_,[]) = [] -------------------------------------------------------------------------------- gaussElim a b = dropColumns (rows a) $ fst $ mutable gaussST (a ||| b) gaussST (r,_) x = do let n = r-1 axpy m a i j = rowOper (AXPY a i j AllCols) m swap m i j = rowOper (SWAP i j AllCols) m scal m a i = rowOper (SCAL a (Row i) AllCols) m forM_ [0..n] $ \i -> do c <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i) swap x i (i+c) a <- readMatrix x i i when (a == 0) $ error "singular!" scal x (recip a) i forM_ [i+1..n] $ \j -> do b <- readMatrix x j i axpy x (-b) i j forM_ [n,n-1..1] $ \i -> do forM_ [i-1,i-2..0] $ \j -> do b <- readMatrix x j i axpy x (-b) i j luST ok (r,_) x = do let axpy m a i j = rowOper (AXPY a i j (FromCol (i+1))) m swap m i j = rowOper (SWAP i j AllCols) m p <- newUndefinedVector r forM_ [0..r-1] $ \i -> do k <- maxIndex . abs . flatten <$> extractMatrix x (FromRow i) (Col i) writeVector p i (k+i) swap x i (i+k) a <- readMatrix x i i when (ok a) $ do forM_ [i+1..r-1] $ \j -> do b <- (/a) <$> readMatrix x j i axpy x (-b) i j writeMatrix x j i b v <- unsafeFreezeVector p return (toList v) {- | Experimental implementation of 'luPacked' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'. >>> let m = ident 5 + (5><5) [0..] :: Matrix (Z ./. 17) (5><5) [ 1, 1, 2, 3, 4 , 5, 7, 7, 8, 9 , 10, 11, 13, 13, 14 , 15, 16, 0, 2, 2 , 3, 4, 5, 6, 8 ] >>> let (l,u,p,s) = luFact $ luPacked' m >>> l (5><5) [ 1, 0, 0, 0, 0 , 6, 1, 0, 0, 0 , 12, 7, 1, 0, 0 , 7, 10, 7, 1, 0 , 8, 2, 6, 11, 1 ] >>> u (5><5) [ 15, 16, 0, 2, 2 , 0, 13, 7, 13, 14 , 0, 0, 15, 0, 11 , 0, 0, 0, 15, 15 , 0, 0, 0, 0, 1 ] -} luPacked' x = LU m p where (m,p) = mutable (luST (magnit 0)) x -------------------------------------------------------------------------------- scalS a (Slice x r0 c0 nr nc) = rowOper (SCAL a (RowRange r0 (r0+nr-1)) (ColRange c0 (c0+nc-1))) x view x k r = do d <- readMatrix x k k let rr = r-1-k o = if k < r-1 then 1 else 0 s = Slice x (k+1) (k+1) rr rr u = Slice x k (k+1) o rr l = Slice x (k+1) k rr o return (d,u,l,s) withVec r f = \s x -> do p <- newUndefinedVector r _ <- f s x p v <- unsafeFreezeVector p return v luPacked'' m = (id *** toList) (mutable (withVec (rows m) lu2) m) where lu2 (r,_) x p = do forM_ [0..r-1] $ \k -> do pivot x p k (d,u,l,s) <- view x k r when (magnit 0 d) $ do scalS (recip d) l gemmm 1 s (-1) l u pivot x p k = do j <- maxIndex . abs . flatten <$> extractMatrix x (FromRow k) (Col k) writeVector p k (j+k) swap k (k+j) where swap i j = rowOper (SWAP i j AllCols) x -------------------------------------------------------------------------------- rowRange m = [0..rows m -1] at k = Pos (idxs[k]) backSust' lup rhs = foldl' f (rhs?[]) (reverse ls) where ls = [ (d k , u k , b k) | k <- rowRange lup ] where d k = lup ?? (at k, at k) u k = lup ?? (at k, Drop (k+1)) b k = rhs ?? (at k, All) f x (d,u,b) = (b - u<>x) / d === x forwSust' lup rhs = foldl' f (rhs?[]) ls where ls = [ (l k , b k) | k <- rowRange lup ] where l k = lup ?? (at k, Take k) b k = rhs ?? (at k, All) f x (l,b) = x === (b - l<>x) luSolve'' (LU lup p) b = backSust' lup (forwSust' lup pb) where pb = b ?? (Pos (fixPerm' p), All) -------------------------------------------------------------------------------- forwSust lup rhs = fst $ mutable f rhs where f (r,c) x = do l <- unsafeThawMatrix lup let go k = gemmm 1 (Slice x k 0 1 c) (-1) (Slice l k 0 1 k) (Slice x 0 0 k c) mapM_ go [0..r-1] backSust lup rhs = fst $ mutable f rhs where f (r,c) m = do l <- unsafeThawMatrix lup let d k = recip (lup `atIndex` (k,k)) u k = Slice l k (k+1) 1 (r-1-k) b k = Slice m k 0 1 c x k = Slice m (k+1) 0 (r-1-k) c scal k = rowOper (SCAL (d k) (Row k) AllCols) m go k = gemmm 1 (b k) (-1) (u k) (x k) >> scal k mapM_ go [r-1,r-2..0] {- | Experimental implementation of 'luSolve' for any Fractional element type, including 'Mod' n 'I' and 'Mod' n 'Z'. >>> let a = (2><2) [1,2,3,5] :: Matrix (Z ./. 13) (2><2) [ 1, 2 , 3, 5 ] >>> b (2><3) [ 5, 1, 3 , 8, 6, 3 ] >>> luSolve' (luPacked' a) b (2><3) [ 4, 7, 4 , 7, 10, 6 ] -} luSolve' (LU lup p) b = backSust lup (forwSust lup pb) where pb = b ?? (Pos (fixPerm' p), All) -------------------------------------------------------------------------------- data MatrixView t b = Elem t | Block b b b b deriving Show viewBlock' r c m | (rt,ct) == (1,1) = Elem (atM' m 0 0) | otherwise = Block m11 m12 m21 m22 where (rt,ct) = size m m11 = subm (0,0) (r,c) m m12 = subm (0,c) (r,ct-c) m m21 = subm (r,0) (rt-r,c) m m22 = subm (r,c) (rt-r,ct-c) m subm = subMatrix viewBlock m = viewBlock' n n m where n = rows m `div` 2 invershur (viewBlock -> Block a b c d) = fromBlocks [[a',b'],[c',d']] where r1 = invershur a r2 = c <> r1 r3 = r1 <> b r4 = c <> r3 r5 = r4-d r6 = invershur r5 b' = r3 <> r6 c' = r6 <> r2 r7 = r3 <> c' a' = r1-r7 d' = -r6 invershur x = recip x -------------------------------------------------------------------------------- instance Testable (Matrix I) where checkT _ = test test :: (Bool, IO()) test = (and ok, return ()) where m = (3><4) [1..12] :: Matrix I r = (2><3) [1,2,3,4,3,2] c = (3><2) [0,4,4,1,2,3] p = (9><10) [0..89] :: Matrix I ep = (2><3) [10,24,32,44,31,23] md = fromInt m :: Matrix Double ok = [ tr m <> m == toInt (tr md <> md) , m <> tr m == toInt (md <> tr md) , m ?? (Take 2, Take 3) == remap (asColumn (range 2)) (asRow (range 3)) m , remap r (tr c) p == ep , tr p ?? (PosCyc (idxs[-5,13]), Pos (idxs[3,7,1])) == (2><3) [35,75,15,33,73,13] ] hmatrix-0.19.0.0/src/Internal/Modular.hs0000644000000000000000000003612613260621005016106 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-} {- | Module : Internal.Modular Copyright : (c) Alberto Ruiz 2015 License : BSD3 Stability : experimental Proof of concept of statically checked modular arithmetic. -} module Internal.Modular( Mod, type (./.) ) where import Internal.Vector import Internal.Matrix hiding (size) import Internal.Numeric import Internal.Element import Internal.Container import Internal.Vectorized (prodI,sumI,prodL,sumL) import Internal.LAPACK (multiplyI, multiplyL) import Internal.Algorithms(luFact,LU(..)) import Internal.Util(Normed(..),Indexable(..), gaussElim, gaussElim_1, gaussElim_2, luST, luSolve', luPacked', magnit, invershur) import Internal.ST(mutable) #if MIN_VERSION_base(4,11,0) import GHC.TypeLits hiding (Mod) #else import GHC.TypeLits #endif import Data.Proxy(Proxy) import Foreign.ForeignPtr(castForeignPtr) import Foreign.Storable import Data.Ratio import Data.Complex import Control.DeepSeq ( NFData(..) ) #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) #endif -- | Wrapper with a phantom integer for statically checked modular arithmetic. newtype Mod (n :: Nat) t = Mod {unMod:: t} deriving (Storable) instance (NFData t) => NFData (Mod n t) where rnf (Mod x) = rnf x infixr 5 ./. type (./.) x n = Mod n x instance (Integral t, Enum t, KnownNat m) => Enum (Mod m t) where toEnum = l0 (\m x -> fromIntegral $ x `mod` (fromIntegral m)) fromEnum = fromIntegral . unMod instance (Eq t, KnownNat m) => Eq (Mod m t) where a == b = (unMod a) == (unMod b) instance (Ord t, KnownNat m) => Ord (Mod m t) where compare a b = compare (unMod a) (unMod b) instance (Integral t, Real t, KnownNat m, Integral (Mod m t)) => Real (Mod m t) where toRational x = toInteger x % 1 instance (Integral t, KnownNat m, Num (Mod m t)) => Integral (Mod m t) where toInteger = toInteger . unMod quotRem a b = (Mod q, Mod r) where (q,r) = quotRem (unMod a) (unMod b) -- | this instance is only valid for prime m instance (Show (Mod m t), Num (Mod m t), Eq t, KnownNat m) => Fractional (Mod m t) where recip x | x*r == 1 = r | otherwise = error $ show x ++" does not have a multiplicative inverse mod "++show m' where r = x^(m'-2 :: Integer) m' = fromIntegral . natVal $ (undefined :: Proxy m) fromRational x = fromInteger (numerator x) / fromInteger (denominator x) l2 :: forall m a b c. (Num c, KnownNat m) => (c -> a -> b -> c) -> Mod m a -> Mod m b -> Mod m c l2 f (Mod u) (Mod v) = Mod (f m' u v) where m' = fromIntegral . natVal $ (undefined :: Proxy m) l1 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> Mod m a -> Mod m b l1 f (Mod u) = Mod (f m' u) where m' = fromIntegral . natVal $ (undefined :: Proxy m) l0 :: forall m a b . (Num b, KnownNat m) => (b -> a -> b) -> a -> Mod m b l0 f u = Mod (f m' u) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance Show t => Show (Mod n t) where show = show . unMod instance (Integral t, KnownNat n) => Num (Mod n t) where (+) = l2 (\m a b -> (a + b) `mod` (fromIntegral m)) (*) = l2 (\m a b -> (a * b) `mod` (fromIntegral m)) (-) = l2 (\m a b -> (a - b) `mod` (fromIntegral m)) abs = l1 (const abs) signum = l1 (const signum) fromInteger = l0 (\m x -> fromInteger x `mod` (fromIntegral m)) instance KnownNat m => Element (Mod m I) where constantD x n = i2f (constantD (unMod x) n) extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js setRect i j m x = setRect i j (f2iM m) (f2iM x) sortI = sortI . f2i sortV = i2f . sortV . f2i compareV u v = compareV (f2i u) (f2i v) selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g)) remapM i j m = i2fM (remap i j (f2iM m)) rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpMI m') c (unMod a) i1 i2 j1 j2 (f2iM x) where m' = fromIntegral . natVal $ (undefined :: Proxy m) gemm u a b c = gemmg (c_gemmMI m') (f2i u) (f2iM a) (f2iM b) (f2iM c) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Element (Mod m Z) where constantD x n = i2f (constantD (unMod x) n) extractR ord m mi is mj js = i2fM <$> extractR ord (f2iM m) mi is mj js setRect i j m x = setRect i j (f2iM m) (f2iM x) sortI = sortI . f2i sortV = i2f . sortV . f2i compareV u v = compareV (f2i u) (f2i v) selectV c l e g = i2f (selectV c (f2i l) (f2i e) (f2i g)) remapM i j m = i2fM (remap i j (f2iM m)) rowOp c a i1 i2 j1 j2 x = rowOpAux (c_rowOpML m') c (unMod a) i1 i2 j1 j2 (f2iM x) where m' = fromIntegral . natVal $ (undefined :: Proxy m) gemm u a b c = gemmg (c_gemmML m') (f2i u) (f2iM a) (f2iM b) (f2iM c) where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => CTrans (Mod m I) instance KnownNat m => CTrans (Mod m Z) instance KnownNat m => Container Vector (Mod m I) where conj' = id size' = dim scale' s x = vmod (scale (unMod s) (f2i x)) addConstant c x = vmod (addConstant (unMod c) (f2i x)) add' a b = vmod (add' (f2i a) (f2i b)) sub a b = vmod (sub (f2i a) (f2i b)) mul a b = vmod (mul (f2i a) (f2i b)) equal u v = equal (f2i u) (f2i v) scalar' x = fromList [x] konst' x = i2f . konst (unMod x) build' n f = build n (fromIntegral . f) cmap' = mapVector atIndex' x k = fromIntegral (atIndex (f2i x) k) minIndex' = minIndex . f2i maxIndex' = maxIndex . f2i minElement' = Mod . minElement . f2i maxElement' = Mod . maxElement . f2i sumElements' = fromIntegral . sumI m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) prodElements' = fromIntegral . prodI m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) step' = i2f . step . f2i find' = findV assoc' = assocV accum' = accumV ccompare' a b = ccompare (f2i a) (f2i b) cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g) scaleRecip s x = scale' s (cmap recip x) divide x y = mul x (cmap recip y) arctan2' = undefined cmod' m = vmod . cmod' (unMod m) . f2i fromInt' = vmod toInt' = f2i fromZ' = vmod . fromZ' toZ' = toZ' . f2i instance KnownNat m => Container Vector (Mod m Z) where conj' = id size' = dim scale' s x = vmod (scale (unMod s) (f2i x)) addConstant c x = vmod (addConstant (unMod c) (f2i x)) add' a b = vmod (add' (f2i a) (f2i b)) sub a b = vmod (sub (f2i a) (f2i b)) mul a b = vmod (mul (f2i a) (f2i b)) equal u v = equal (f2i u) (f2i v) scalar' x = fromList [x] konst' x = i2f . konst (unMod x) build' n f = build n (fromIntegral . f) cmap' = mapVector atIndex' x k = fromIntegral (atIndex (f2i x) k) minIndex' = minIndex . f2i maxIndex' = maxIndex . f2i minElement' = Mod . minElement . f2i maxElement' = Mod . maxElement . f2i sumElements' = fromIntegral . sumL m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) prodElements' = fromIntegral . prodL m' . f2i where m' = fromIntegral . natVal $ (undefined :: Proxy m) step' = i2f . step . f2i find' = findV assoc' = assocV accum' = accumV ccompare' a b = ccompare (f2i a) (f2i b) cselect' c l e g = i2f $ cselect c (f2i l) (f2i e) (f2i g) scaleRecip s x = scale' s (cmap recip x) divide x y = mul x (cmap recip y) arctan2' = undefined cmod' m = vmod . cmod' (unMod m) . f2i fromInt' = vmod . fromInt' toInt' = toInt . f2i fromZ' = vmod toZ' = f2i instance (Storable t, Indexable (Vector t) t) => Indexable (Vector (Mod m t)) (Mod m t) where (!) = (@>) type instance RealOf (Mod n I) = I type instance RealOf (Mod n Z) = Z instance KnownNat m => Product (Mod m I) where norm2 = undefined absSum = undefined norm1 = undefined normInf = undefined multiply = lift2m (multiplyI m') where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Product (Mod m Z) where norm2 = undefined absSum = undefined norm1 = undefined normInf = undefined multiply = lift2m (multiplyL m') where m' = fromIntegral . natVal $ (undefined :: Proxy m) instance KnownNat m => Normed (Vector (Mod m I)) where norm_0 = norm_0 . toInt norm_1 = norm_1 . toInt norm_2 = norm_2 . toInt norm_Inf = norm_Inf . toInt instance KnownNat m => Normed (Vector (Mod m Z)) where norm_0 = norm_0 . toZ norm_1 = norm_1 . toZ norm_2 = norm_2 . toZ norm_Inf = norm_Inf . toZ instance KnownNat m => Numeric (Mod m I) instance KnownNat m => Numeric (Mod m Z) i2f :: Storable t => Vector t -> Vector (Mod n t) i2f v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n) where (fp,i,n) = unsafeToForeignPtr v f2i :: Storable t => Vector (Mod n t) -> Vector t f2i v = unsafeFromForeignPtr (castForeignPtr fp) (i) (n) where (fp,i,n) = unsafeToForeignPtr v f2iM :: (Element t, Element (Mod n t)) => Matrix (Mod n t) -> Matrix t f2iM m = m { xdat = f2i (xdat m) } i2fM :: (Element t, Element (Mod n t)) => Matrix t -> Matrix (Mod n t) i2fM m = m { xdat = i2f (xdat m) } vmod :: forall m t. (KnownNat m, Storable t, Integral t, Numeric t) => Vector t -> Vector (Mod m t) vmod = i2f . cmod' m' where m' = fromIntegral . natVal $ (undefined :: Proxy m) lift1 f a = vmod (f (f2i a)) lift2 f a b = vmod (f (f2i a) (f2i b)) lift2m f a b = liftMatrix vmod (f (f2iM a) (f2iM b)) instance KnownNat m => Num (Vector (Mod m I)) where (+) = lift2 (+) (*) = lift2 (*) (-) = lift2 (-) abs = lift1 abs signum = lift1 signum negate = lift1 negate fromInteger x = fromInt (fromInteger x) instance KnownNat m => Num (Vector (Mod m Z)) where (+) = lift2 (+) (*) = lift2 (*) (-) = lift2 (-) abs = lift1 abs signum = lift1 signum negate = lift1 negate fromInteger x = fromZ (fromInteger x) -------------------------------------------------------------------------------- instance (KnownNat m) => Testable (Matrix (Mod m I)) where checkT _ = test test = (ok, info) where v = fromList [3,-5,75] :: Vector (Mod 11 I) m = (3><3) [1..] :: Matrix (Mod 11 I) a = (3><3) [1,2 , 3 ,4,5 , 6 ,0,10,-3] :: Matrix I b = (3><2) [0..] :: Matrix I am = fromInt a :: Matrix (Mod 13 I) bm = fromInt b :: Matrix (Mod 13 I) ad = fromInt a :: Matrix Double bd = fromInt b :: Matrix Double g = (3><3) (repeat (40000)) :: Matrix I gm = fromInt g :: Matrix (Mod 100000 I) lg = (3><3) (repeat (3*10^(9::Int))) :: Matrix Z lgm = fromZ lg :: Matrix (Mod 10000000000 Z) gen n = diagRect 1 (konst 5 n) n n :: Numeric t => Matrix t rgen n = gen n :: Matrix R cgen n = complex (rgen n) + fliprl (complex (rgen n)) * scalar (0:+1) :: Matrix C sgen n = single (cgen n) checkGen x = norm_Inf $ flatten $ invg x <> x - ident (rows x) invg t = gaussElim t (ident (rows t)) checkLU okf t = norm_Inf $ flatten (l <> u <> p - t) where (l,u,p,_) = luFact (LU x' p') where (x',p') = mutable (luST okf) t checkSolve aa = norm_Inf $ flatten (aa <> x - bb) where bb = flipud aa x = luSolve' (luPacked' aa) bb tmm = diagRect 1 (fromList [2..6]) 5 5 :: Matrix (Mod 19 I) info = do print v print m print (tr m) print $ v+v print $ m+m print $ m <> m print $ m #> v print $ am <> gaussElim am bm - bm print $ ad <> gaussElim ad bd - bd print g print $ g <> g print gm print $ gm <> gm print lg print $ lg <> lg print lgm print $ lgm <> lgm putStrLn "checkGen" print (checkGen (gen 5 :: Matrix R)) print (checkGen (gen 5 :: Matrix Float)) print (checkGen (cgen 5 :: Matrix C)) print (checkGen (sgen 5 :: Matrix (Complex Float))) print (invg (gen 5) :: Matrix (Mod 7 I)) print (invg (gen 5) :: Matrix (Mod 7 Z)) print $ mutable (luST (const True)) (gen 5 :: Matrix R) print $ mutable (luST (const True)) (gen 5 :: Matrix (Mod 11 Z)) putStrLn "checkLU" print $ checkLU (magnit 0) (gen 5 :: Matrix R) print $ checkLU (magnit 0) (gen 5 :: Matrix Float) print $ checkLU (magnit 0) (cgen 5 :: Matrix C) print $ checkLU (magnit 0) (sgen 5 :: Matrix (Complex Float)) print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I)) print $ checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z)) putStrLn "checkSolve" print $ checkSolve (gen 5 :: Matrix R) print $ checkSolve (gen 5 :: Matrix Float) print $ checkSolve (cgen 5 :: Matrix C) print $ checkSolve (sgen 5 :: Matrix (Complex Float)) print $ checkSolve (gen 5 :: Matrix (Mod 7 I)) print $ checkSolve (gen 5 :: Matrix (Mod 7 Z)) putStrLn "luSolve'" print $ luSolve' (luPacked' tmm) (ident (rows tmm)) print $ invershur tmm ok = and [ toInt (m #> v) == cmod 11 (toInt m #> toInt v ) , am <> gaussElim_1 am bm == bm , am <> gaussElim_2 am bm == bm , am <> gaussElim am bm == bm , (checkGen (gen 5 :: Matrix R)) < 1E-15 , (checkGen (gen 5 :: Matrix Float)) < 2E-7 , (checkGen (cgen 5 :: Matrix C)) < 1E-15 , (checkGen (sgen 5 :: Matrix (Complex Float))) < 3E-7 , (checkGen (gen 5 :: Matrix (Mod 7 I))) == 0 , (checkGen (gen 5 :: Matrix (Mod 7 Z))) == 0 , (checkLU (magnit 1E-10) (gen 5 :: Matrix R)) < 2E-15 , (checkLU (magnit 1E-5) (gen 5 :: Matrix Float)) < 1E-6 , (checkLU (magnit 1E-10) (cgen 5 :: Matrix C)) < 5E-15 , (checkLU (magnit 1E-5) (sgen 5 :: Matrix (Complex Float))) < 1E-6 , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 I))) == 0 , (checkLU (magnit 0) (gen 5 :: Matrix (Mod 7 Z))) == 0 , checkSolve (gen 5 :: Matrix R) < 2E-15 , checkSolve (gen 5 :: Matrix Float) < 1E-6 , checkSolve (cgen 5 :: Matrix C) < 4E-15 , checkSolve (sgen 5 :: Matrix (Complex Float)) < 1E-6 , checkSolve (gen 5 :: Matrix (Mod 7 I)) == 0 , checkSolve (gen 5 :: Matrix (Mod 7 Z)) == 0 , prodElements (konst (9:: Mod 10 I) (12::Int)) == product (replicate 12 (9:: Mod 10 I)) , gm <> gm == konst 0 (3,3) , lgm <> lgm == konst 0 (3,3) , invershur tmm == luSolve' (luPacked' tmm) (ident (rows tmm)) , luSolve' (luPacked' (tr $ ident 5 :: Matrix (I ./. 2))) (ident 5) == ident 5 ] hmatrix-0.19.0.0/src/Internal/Static.hs0000644000000000000000000004067713267060772015757 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 708 {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints #-} {- | Module : Internal.Static Copyright : (c) Alberto Ruiz 2006-14 License : BSD3 Stability : provisional -} module Internal.Static where import GHC.TypeLits import qualified Numeric.LinearAlgebra as LA import Numeric.LinearAlgebra hiding (konst,size,R,C) import Internal.Vector as D hiding (R,C) import Internal.ST import Control.DeepSeq import Data.Proxy(Proxy) import Foreign.Storable(Storable) import Text.Printf import Data.Binary import GHC.Generics (Generic) import Data.Proxy (Proxy(..)) -------------------------------------------------------------------------------- type ℝ = Double type ℂ = Complex Double newtype Dim (n :: Nat) t = Dim t deriving (Show, Generic) instance (KnownNat n, Binary a) => Binary (Dim n a) where get = do k <- get let n = natVal (Proxy :: Proxy n) if n == k then Dim <$> get else fail ("Expected dimension " ++ (show n) ++ ", but found dimension " ++ (show k)) put (Dim x) = do put (natVal (Proxy :: Proxy n)) put x lift1F :: (c t -> c t) -> Dim n (c t) -> Dim n (c t) lift1F f (Dim v) = Dim (f v) lift2F :: (c t -> c t -> c t) -> Dim n (c t) -> Dim n (c t) -> Dim n (c t) lift2F f (Dim u) (Dim v) = Dim (f u v) instance NFData t => NFData (Dim n t) where rnf (Dim (force -> !_)) = () -------------------------------------------------------------------------------- newtype R n = R (Dim n (Vector ℝ)) deriving (Num,Fractional,Floating,Generic,Binary) newtype C n = C (Dim n (Vector ℂ)) deriving (Num,Fractional,Floating,Generic) newtype L m n = L (Dim m (Dim n (Matrix ℝ))) deriving (Generic, Binary) newtype M m n = M (Dim m (Dim n (Matrix ℂ))) deriving (Generic) mkR :: Vector ℝ -> R n mkR = R . Dim mkC :: Vector ℂ -> C n mkC = C . Dim mkL :: Matrix ℝ -> L m n mkL x = L (Dim (Dim x)) mkM :: Matrix ℂ -> M m n mkM x = M (Dim (Dim x)) instance NFData (R n) where rnf (R (force -> !_)) = () instance NFData (C n) where rnf (C (force -> !_)) = () instance NFData (L n m) where rnf (L (force -> !_)) = () instance NFData (M n m) where rnf (M (force -> !_)) = () -------------------------------------------------------------------------------- type V n t = Dim n (Vector t) ud :: Dim n (Vector t) -> Vector t ud (Dim v) = v mkV :: forall (n :: Nat) t . t -> Dim n t mkV = Dim vconcat :: forall n m t . (KnownNat n, KnownNat m, Numeric t) => V n t -> V m t -> V (n+m) t (ud -> u) `vconcat` (ud -> v) = mkV (vjoin [u', v']) where du = fromIntegral . natVal $ (undefined :: Proxy n) dv = fromIntegral . natVal $ (undefined :: Proxy m) u' | du > 1 && LA.size u == 1 = LA.konst (u D.@> 0) du | otherwise = u v' | dv > 1 && LA.size v == 1 = LA.konst (v D.@> 0) dv | otherwise = v gvec2 :: Storable t => t -> t -> V 2 t gvec2 a b = mkV $ runSTVector $ do v <- newUndefinedVector 2 writeVector v 0 a writeVector v 1 b return v gvec3 :: Storable t => t -> t -> t -> V 3 t gvec3 a b c = mkV $ runSTVector $ do v <- newUndefinedVector 3 writeVector v 0 a writeVector v 1 b writeVector v 2 c return v gvec4 :: Storable t => t -> t -> t -> t -> V 4 t gvec4 a b c d = mkV $ runSTVector $ do v <- newUndefinedVector 4 writeVector v 0 a writeVector v 1 b writeVector v 2 c writeVector v 3 d return v gvect :: forall n t . (Show t, KnownNat n, Numeric t) => String -> [t] -> V n t gvect st xs' | ok = mkV v | not (null rest) && null (tail rest) = abort (show xs') | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]") | otherwise = abort (show xs) where (xs,rest) = splitAt d xs' ok = LA.size v == d && null rest v = LA.fromList xs d = fromIntegral . natVal $ (undefined :: Proxy n) abort info = error $ st++" "++show d++" can't be created from elements "++info -------------------------------------------------------------------------------- type GM m n t = Dim m (Dim n (Matrix t)) gmat :: forall m n t . (Show t, KnownNat m, KnownNat n, Numeric t) => String -> [t] -> GM m n t gmat st xs' | ok = Dim (Dim x) | not (null rest) && null (tail rest) = abort (show xs') | not (null rest) = abort (init (show (xs++take 1 rest))++", ... ]") | otherwise = abort (show xs) where (xs,rest) = splitAt (m'*n') xs' v = LA.fromList xs x = reshape n' v ok = null rest && ((n' == 0 && dim v == 0) || n'> 0 && (rem (LA.size v) n' == 0) && LA.size x == (m',n')) m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int abort info = error $ st ++" "++show m' ++ " " ++ show n'++" can't be created from elements " ++ info -------------------------------------------------------------------------------- class Num t => Sized t s d | s -> t, s -> d where konst :: t -> s unwrap :: s -> d t fromList :: [t] -> s extract :: s -> d t create :: d t -> Maybe s size :: s -> IndexOf d singleV v = LA.size v == 1 singleM m = rows m == 1 && cols m == 1 instance KnownNat n => Sized ℂ (C n) Vector where size _ = fromIntegral . natVal $ (undefined :: Proxy n) konst x = mkC (LA.scalar x) unwrap (C (Dim v)) = v fromList xs = C (gvect "C" xs) extract s@(unwrap -> v) | singleV v = LA.konst (v!0) (size s) | otherwise = v create v | LA.size v == size r = Just r | otherwise = Nothing where r = mkC v :: C n instance KnownNat n => Sized ℝ (R n) Vector where size _ = fromIntegral . natVal $ (undefined :: Proxy n) konst x = mkR (LA.scalar x) unwrap (R (Dim v)) = v fromList xs = R (gvect "R" xs) extract s@(unwrap -> v) | singleV v = LA.konst (v!0) (size s) | otherwise = v create v | LA.size v == size r = Just r | otherwise = Nothing where r = mkR v :: R n instance (KnownNat m, KnownNat n) => Sized ℝ (L m n) Matrix where size _ = ((fromIntegral . natVal) (undefined :: Proxy m) ,(fromIntegral . natVal) (undefined :: Proxy n)) konst x = mkL (LA.scalar x) fromList xs = L (gmat "L" xs) unwrap (L (Dim (Dim m))) = m extract (isDiag -> Just (z,y,(m',n'))) = diagRect z y m' n' extract s@(unwrap -> a) | singleM a = LA.konst (a `atIndex` (0,0)) (size s) | otherwise = a create x | LA.size x == size r = Just r | otherwise = Nothing where r = mkL x :: L m n instance (KnownNat m, KnownNat n) => Sized ℂ (M m n) Matrix where size _ = ((fromIntegral . natVal) (undefined :: Proxy m) ,(fromIntegral . natVal) (undefined :: Proxy n)) konst x = mkM (LA.scalar x) fromList xs = M (gmat "M" xs) unwrap (M (Dim (Dim m))) = m extract (isDiagC -> Just (z,y,(m',n'))) = diagRect z y m' n' extract s@(unwrap -> a) | singleM a = LA.konst (a `atIndex` (0,0)) (size s) | otherwise = a create x | LA.size x == size r = Just r | otherwise = Nothing where r = mkM x :: M m n -------------------------------------------------------------------------------- instance (KnownNat n, KnownNat m) => Transposable (L m n) (L n m) where tr a@(isDiag -> Just _) = mkL (extract a) tr (extract -> a) = mkL (tr a) tr' = tr instance (KnownNat n, KnownNat m) => Transposable (M m n) (M n m) where tr a@(isDiagC -> Just _) = mkM (extract a) tr (extract -> a) = mkM (tr a) tr' a@(isDiagC -> Just _) = mkM (extract a) tr' (extract -> a) = mkM (tr' a) -------------------------------------------------------------------------------- isDiag :: forall m n . (KnownNat m, KnownNat n) => L m n -> Maybe (ℝ, Vector ℝ, (Int,Int)) isDiag (L x) = isDiagg x isDiagC :: forall m n . (KnownNat m, KnownNat n) => M m n -> Maybe (ℂ, Vector ℂ, (Int,Int)) isDiagC (M x) = isDiagg x isDiagg :: forall m n t . (Numeric t, KnownNat m, KnownNat n) => GM m n t -> Maybe (t, Vector t, (Int,Int)) isDiagg (Dim (Dim x)) | singleM x = Nothing | rows x == 1 && m' > 1 || cols x == 1 && n' > 1 = Just (z,yz,(m',n')) | otherwise = Nothing where m' = fromIntegral . natVal $ (undefined :: Proxy m) :: Int n' = fromIntegral . natVal $ (undefined :: Proxy n) :: Int v = flatten x z = v `atIndex` 0 y = subVector 1 (LA.size v-1) v ny = LA.size y zeros = LA.konst 0 (max 0 (min m' n' - ny)) yz = vjoin [y,zeros] -------------------------------------------------------------------------------- instance KnownNat n => Show (R n) where show s@(R (Dim v)) | singleV v = "("++show (v!0)++" :: R "++show d++")" | otherwise = "(vector"++ drop 8 (show v)++" :: R "++show d++")" where d = size s instance KnownNat n => Show (C n) where show s@(C (Dim v)) | singleV v = "("++show (v!0)++" :: C "++show d++")" | otherwise = "(vector"++ drop 8 (show v)++" :: C "++show d++")" where d = size s instance (KnownNat m, KnownNat n) => Show (L m n) where show (isDiag -> Just (z,y,(m',n'))) = printf "(diag %s %s :: L %d %d)" (show z) (drop 9 $ show y) m' n' show s@(L (Dim (Dim x))) | singleM x = printf "(%s :: L %d %d)" (show (x `atIndex` (0,0))) m' n' | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: L "++show m'++" "++show n'++")" where (m',n') = size s instance (KnownNat m, KnownNat n) => Show (M m n) where show (isDiagC -> Just (z,y,(m',n'))) = printf "(diag %s %s :: M %d %d)" (show z) (drop 9 $ show y) m' n' show s@(M (Dim (Dim x))) | singleM x = printf "(%s :: M %d %d)" (show (x `atIndex` (0,0))) m' n' | otherwise = "(matrix"++ dropWhile (/='\n') (show x)++" :: M "++show m'++" "++show n'++")" where (m',n') = size s -------------------------------------------------------------------------------- instance (Num (Vector t), Numeric t )=> Num (Dim n (Vector t)) where (+) = lift2F (+) (*) = lift2F (*) (-) = lift2F (-) abs = lift1F abs signum = lift1F signum negate = lift1F negate fromInteger x = Dim (fromInteger x) instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim n (Vector t)) where fromRational x = Dim (fromRational x) (/) = lift2F (/) instance (Fractional t, Floating (Vector t), Numeric t) => Floating (Dim n (Vector t)) where sin = lift1F sin cos = lift1F cos tan = lift1F tan asin = lift1F asin acos = lift1F acos atan = lift1F atan sinh = lift1F sinh cosh = lift1F cosh tanh = lift1F tanh asinh = lift1F asinh acosh = lift1F acosh atanh = lift1F atanh exp = lift1F exp log = lift1F log sqrt = lift1F sqrt (**) = lift2F (**) pi = Dim pi instance (Num (Matrix t), Numeric t) => Num (Dim m (Dim n (Matrix t))) where (+) = (lift2F . lift2F) (+) (*) = (lift2F . lift2F) (*) (-) = (lift2F . lift2F) (-) abs = (lift1F . lift1F) abs signum = (lift1F . lift1F) signum negate = (lift1F . lift1F) negate fromInteger x = Dim (Dim (fromInteger x)) instance (Num (Vector t), Num (Matrix t), Fractional t, Numeric t) => Fractional (Dim m (Dim n (Matrix t))) where fromRational x = Dim (Dim (fromRational x)) (/) = (lift2F.lift2F) (/) instance (Num (Vector t), Floating (Matrix t), Fractional t, Numeric t) => Floating (Dim m (Dim n (Matrix t))) where sin = (lift1F . lift1F) sin cos = (lift1F . lift1F) cos tan = (lift1F . lift1F) tan asin = (lift1F . lift1F) asin acos = (lift1F . lift1F) acos atan = (lift1F . lift1F) atan sinh = (lift1F . lift1F) sinh cosh = (lift1F . lift1F) cosh tanh = (lift1F . lift1F) tanh asinh = (lift1F . lift1F) asinh acosh = (lift1F . lift1F) acosh atanh = (lift1F . lift1F) atanh exp = (lift1F . lift1F) exp log = (lift1F . lift1F) log sqrt = (lift1F . lift1F) sqrt (**) = (lift2F . lift2F) (**) pi = Dim (Dim pi) -------------------------------------------------------------------------------- adaptDiag f a@(isDiag -> Just _) b | isFull b = f (mkL (extract a)) b adaptDiag f a b@(isDiag -> Just _) | isFull a = f a (mkL (extract b)) adaptDiag f a b = f a b isFull m = isDiag m == Nothing && not (singleM (unwrap m)) lift1L f (L v) = L (f v) lift2L f (L a) (L b) = L (f a b) lift2LD f = adaptDiag (lift2L f) instance (KnownNat n, KnownNat m) => Num (L n m) where (+) = lift2LD (+) (*) = lift2LD (*) (-) = lift2LD (-) abs = lift1L abs signum = lift1L signum negate = lift1L negate fromInteger = L . Dim . Dim . fromInteger instance (KnownNat n, KnownNat m) => Fractional (L n m) where fromRational = L . Dim . Dim . fromRational (/) = lift2LD (/) instance (KnownNat n, KnownNat m) => Floating (L n m) where sin = lift1L sin cos = lift1L cos tan = lift1L tan asin = lift1L asin acos = lift1L acos atan = lift1L atan sinh = lift1L sinh cosh = lift1L cosh tanh = lift1L tanh asinh = lift1L asinh acosh = lift1L acosh atanh = lift1L atanh exp = lift1L exp log = lift1L log sqrt = lift1L sqrt (**) = lift2LD (**) pi = konst pi -------------------------------------------------------------------------------- adaptDiagC f a@(isDiagC -> Just _) b | isFullC b = f (mkM (extract a)) b adaptDiagC f a b@(isDiagC -> Just _) | isFullC a = f a (mkM (extract b)) adaptDiagC f a b = f a b isFullC m = isDiagC m == Nothing && not (singleM (unwrap m)) lift1M f (M v) = M (f v) lift2M f (M a) (M b) = M (f a b) lift2MD f = adaptDiagC (lift2M f) instance (KnownNat n, KnownNat m) => Num (M n m) where (+) = lift2MD (+) (*) = lift2MD (*) (-) = lift2MD (-) abs = lift1M abs signum = lift1M signum negate = lift1M negate fromInteger = M . Dim . Dim . fromInteger instance (KnownNat n, KnownNat m) => Fractional (M n m) where fromRational = M . Dim . Dim . fromRational (/) = lift2MD (/) instance (KnownNat n, KnownNat m) => Floating (M n m) where sin = lift1M sin cos = lift1M cos tan = lift1M tan asin = lift1M asin acos = lift1M acos atan = lift1M atan sinh = lift1M sinh cosh = lift1M cosh tanh = lift1M tanh asinh = lift1M asinh acosh = lift1M acosh atanh = lift1M atanh exp = lift1M exp log = lift1M log sqrt = lift1M sqrt (**) = lift2MD (**) pi = M pi instance Additive (R n) where add = (+) instance Additive (C n) where add = (+) instance (KnownNat m, KnownNat n) => Additive (L m n) where add = (+) instance (KnownNat m, KnownNat n) => Additive (M m n) where add = (+) -------------------------------------------------------------------------------- class Disp t where disp :: Int -> t -> IO () instance (KnownNat m, KnownNat n) => Disp (L m n) where disp n x = do let a = extract x let su = LA.dispf n a printf "L %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su) instance (KnownNat m, KnownNat n) => Disp (M m n) where disp n x = do let a = extract x let su = LA.dispcf n a printf "M %d %d" (rows a) (cols a) >> putStr (dropWhile (/='\n') $ su) instance KnownNat n => Disp (R n) where disp n v = do let su = LA.dispf n (asRow $ extract v) putStr "R " >> putStr (tail . dropWhile (/='x') $ su) instance KnownNat n => Disp (C n) where disp n v = do let su = LA.dispcf n (asRow $ extract v) putStr "C " >> putStr (tail . dropWhile (/='x') $ su) -------------------------------------------------------------------------------- overMatL' :: (KnownNat m, KnownNat n) => (LA.Matrix ℝ -> LA.Matrix ℝ) -> L m n -> L m n overMatL' f = mkL . f . unwrap {-# INLINE overMatL' #-} overMatM' :: (KnownNat m, KnownNat n) => (LA.Matrix ℂ -> LA.Matrix ℂ) -> M m n -> M m n overMatM' f = mkM . f . unwrap {-# INLINE overMatM' #-} #else module Numeric.LinearAlgebra.Static.Internal where #endif hmatrix-0.19.0.0/src/Internal/C/lapack-aux.c0000644000000000000000000013304713223170642016530 0ustar0000000000000000#include #include #include #include #include #include #include typedef double complex TCD; typedef float complex TCF; #undef complex #include "lapack-aux.h" #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) // #define DBGL #ifdef DBGL #define DEBUGMSG(M) printf("\nLAPACK "M"\n"); #else #define DEBUGMSG(M) #endif #define OK return 0; // #ifdef DBGL // #define DEBUGMSG(M) printf("LAPACK Wrapper "M"\n: "); size_t t0 = time(NULL); // #define OK MACRO(printf("%ld s\n",time(0)-t0); return 0;); // #else // #define DEBUGMSG(M) // #define OK return 0; // #endif #define INFOMAT(M) printf("%dx%d %d:%d\n",M##r,M##c,M##Xr,M##Xc); #define TRACEMAT(M) {int q; printf(" %d x %d: ",M##r,M##c); \ for(q=0;q=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveR_l"); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; dgesv_ (&n,&nhrs, ap, &n, ipiv, bp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); OK } //////////////////// general complex linear system //////////// int zgesv_(integer *n, integer *nrhs, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, integer * info); int linearSolveC_l(OCMAT(a),OCMAT(b)) { integer n = ar; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("linearSolveC_l"); integer * ipiv = (integer*)malloc(n*sizeof(integer)); integer res; zgesv_ (&n,&nhrs, ap, &n, ipiv, bp, &n, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(ipiv); OK } //////// symmetric positive definite real linear system using Cholesky //////////// int dpotrs_(char *uplo, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * info); int cholSolveR_l(KODMAT(a),ODMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveR_l"); integer res; dpotrs_ ("U", &n,&nhrs, (double*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////// Hermitian positive definite real linear system using Cholesky //////////// int zpotrs_(char *uplo, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info); int cholSolveC_l(KOCMAT(a),OCMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("cholSolveC_l"); integer res; zpotrs_ ("U", &n,&nhrs, (doublecomplex*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////// triangular real linear system //////////// int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * info); int triSolveR_l_u(KODMAT(a),ODMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("triSolveR_l_u"); integer res; dtrtrs_ ("U", "N", "N", &n,&nhrs, (double*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } int triSolveR_l_l(KODMAT(a),ODMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("triSolveR_l_l"); integer res; dtrtrs_ ("L", "N", "N", &n,&nhrs, (double*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////// triangular complex linear system //////////// int ztrtrs_(char *uplo, char *trans, char *diag, integer *n, integer *nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, integer *info); int triSolveC_l_u(KOCMAT(a),OCMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("triSolveC_l_u"); integer res; ztrtrs_ ("U", "N", "N", &n,&nhrs, (doublecomplex*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } int triSolveC_l_l(KOCMAT(a),OCMAT(b)) { integer n = ar; integer lda = aXc; integer nhrs = bc; REQUIRES(n>=1 && ar==ac && ar==br,BAD_SIZE); DEBUGMSG("triSolveC_l_u"); integer res; ztrtrs_ ("L", "N", "N", &n,&nhrs, (doublecomplex*)ap, &lda, bp, &n, &res); CHECK(res,res); OK } //////// tridiagonal real linear system //////////// int dgttrf_(integer *n, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, integer *info); int dgttrs_(char *trans, integer *n, integer *nrhs, doublereal *dl, doublereal *d, doublereal *du, doublereal *du2, integer *ipiv, doublereal *b, integer *ldb, integer *info); int triDiagSolveR_l(DVEC(dl), DVEC(d), DVEC(du), ODMAT(b)) { integer n = dn; integer nhrs = bc; REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE); DEBUGMSG("triDiagSolveR_l"); integer res; integer* ipiv = (integer*)malloc(n*sizeof(integer)); double* du2 = (double*)malloc((n - 2)*sizeof(double)); dgttrf_ (&n, dlp, dp, dup, du2, ipiv, &res); CHECK(res,res); dgttrs_ ("N", &n,&nhrs, dlp, dp, dup, du2, ipiv, bp, &n, &res); CHECK(res,res); free(ipiv); free(du2); OK } //////// tridiagonal complex linear system //////////// int zgttrf_(integer *n, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, integer *info); int zgttrs_(char *trans, integer *n, integer *nrhs, doublecomplex *dl, doublecomplex *d, doublecomplex *du, doublecomplex *du2, integer *ipiv, doublecomplex *b, integer *ldb, integer *info); int triDiagSolveC_l(CVEC(dl), CVEC(d), CVEC(du), OCMAT(b)) { integer n = dn; integer nhrs = bc; REQUIRES(n >= 1 && dln == dn - 1 && dun == dn - 1 && br == n, BAD_SIZE); DEBUGMSG("triDiagSolveC_l"); integer res; integer* ipiv = (integer*)malloc(n*sizeof(integer)); doublecomplex* du2 = (doublecomplex*)malloc((n - 2)*sizeof(doublecomplex)); zgttrf_ (&n, dlp, dp, dup, du2, ipiv, &res); CHECK(res,res); zgttrs_ ("N", &n,&nhrs, dlp, dp, dup, du2, ipiv, bp, &n, &res); CHECK(res,res); free(ipiv); free(du2); OK } //////////////////// least squares real linear system //////////// int dgels_(char *trans, integer *m, integer *n, integer * nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info); int linearSolveLSR_l(ODMAT(a),ODMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveLSR_l"); integer res; integer lwork = -1; double ans; dgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, &ans,&lwork, &res); lwork = ceil(ans); double * work = (double*)malloc(lwork*sizeof(double)); dgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, work,&lwork, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(work); OK } //////////////////// least squares complex linear system //////////// int zgels_(char *trans, integer *m, integer *n, integer * nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer *lwork, integer *info); int linearSolveLSC_l(OCMAT(a),OCMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveLSC_l"); integer res; integer lwork = -1; doublecomplex ans; zgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, &ans,&lwork, &res); lwork = ceil(ans.r); doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zgels_ ("N",&m,&n,&nrhs, ap,&m, bp,&ldb, work,&lwork, &res); if(res>0) { return SINGULAR; } CHECK(res,res); free(work); OK } //////////////////// least squares real linear system using SVD //////////// int dgelss_(integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, integer *info); int linearSolveSVDR_l(double rcond,ODMAT(a),ODMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveSVDR_l"); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); integer res; integer lwork = -1; integer rank; double ans; dgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, &ans,&lwork, &res); lwork = ceil(ans); double * work = (double*)malloc(lwork*sizeof(double)); dgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, work,&lwork, &res); if(res>0) { return NOCONVER; } CHECK(res,res); free(work); free(S); OK } //////////////////// least squares complex linear system using SVD //////////// int zgelss_(integer *m, integer *n, integer *nhrs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *s, doublereal *rcond, integer* rank, doublecomplex *work, integer* lwork, doublereal* rwork, integer *info); int linearSolveSVDC_l(double rcond, OCMAT(a),OCMAT(b)) { integer m = ar; integer n = ac; integer nrhs = bc; integer ldb = bXc; REQUIRES(m>=1 && n>=1 && br==MAX(m,n), BAD_SIZE); DEBUGMSG("linearSolveSVDC_l"); double*S = (double*)malloc(MIN(m,n)*sizeof(double)); double*RWORK = (double*)malloc(5*MIN(m,n)*sizeof(double)); integer res; integer lwork = -1; integer rank; doublecomplex ans; zgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, &ans,&lwork, RWORK, &res); lwork = ceil(ans.r); doublecomplex * work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zgelss_ (&m,&n,&nrhs, ap,&m, bp,&ldb, S, &rcond,&rank, work,&lwork, RWORK, &res); if(res>0) { return NOCONVER; } CHECK(res,res); free(work); free(RWORK); free(S); OK } //////////////////// Cholesky factorization ///////////////////////// int zpotrf_(char *uplo, integer *n, doublecomplex *a, integer *lda, integer *info); int chol_l_H(OCMAT(l)) { integer n = lr; REQUIRES(n>=1 && lc == n,BAD_SIZE); DEBUGMSG("chol_l_H"); char uplo = 'U'; integer res; zpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); doublecomplex zero = {0.,0.}; int r,c; for (r=0; r=1 && lc == n,BAD_SIZE); DEBUGMSG("chol_l_S"); char uplo = 'U'; integer res; dpotrf_ (&uplo,&n,lp,&n,&res); CHECK(res>0,NODEFPOS); CHECK(res,res); int r,c; for (r=0; r=1 && n >=1 && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_R"); double *WORK = (double*)malloc(n*sizeof(double)); CHECK(!WORK,MEM); integer res; dgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } int zgeqr2_(integer *m, integer *n, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *work, integer *info); int qr_l_C(CVEC(tau), OCMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && taun == mn, BAD_SIZE); DEBUGMSG("qr_l_C"); doublecomplex *WORK = (doublecomplex*)malloc(n*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; zgeqr2_ (&m,&n,rp,&m,taup,WORK,&res); CHECK(res,res); free(WORK); OK } int dorgqr_(integer *m, integer *n, integer *k, doublereal * a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); int c_dorgqr(KDVEC(tau), ODMAT(r)) { integer m = rr; integer n = MIN(rc,rr); integer k = taun; DEBUGMSG("c_dorgqr"); integer lwork = 8*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); CHECK(!WORK,MEM); integer res; dorgqr_ (&m,&n,&k,rp,&m,(double*)taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } int zungqr_(integer *m, integer *n, integer *k, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info); int c_zungqr(KCVEC(tau), OCMAT(r)) { integer m = rr; integer n = MIN(rc,rr); integer k = taun; DEBUGMSG("z_ungqr"); integer lwork = 8*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; zungqr_ (&m,&n,&k,rp,&m,(doublecomplex*)taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } //////////////////// Hessenberg factorization ///////////////////////// int dgehrd_(integer *n, integer *ilo, integer *ihi, doublereal *a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, integer *info); int hess_l_R(DVEC(tau), ODMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_R"); integer lwork = 5*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); CHECK(!WORK,MEM); integer res; integer one = 1; dgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } int zgehrd_(integer *n, integer *ilo, integer *ihi, doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * work, integer *lwork, integer *info); int hess_l_C(CVEC(tau), OCMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n == m && taun == mn-1, BAD_SIZE); DEBUGMSG("hess_l_C"); integer lwork = 5*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); CHECK(!WORK,MEM); integer res; integer one = 1; zgehrd_ (&n,&one,&n,rp,&n,taup,WORK,&lwork,&res); CHECK(res,res); free(WORK); OK } //////////////////// Schur factorization ///////////////////////// int dgees_(char *jobvs, char *sort, L_fp select, integer *n, doublereal *a, integer *lda, integer *sdim, doublereal *wr, doublereal *wi, doublereal *vs, integer *ldvs, doublereal *work, integer *lwork, logical *bwork, integer *info); int schur_l_R(ODMAT(u), ODMAT(s)) { integer m = sr; integer n = sc; REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE); DEBUGMSG("schur_l_R"); integer lwork = 6*n; // FIXME double *WORK = (double*)malloc(lwork*sizeof(double)); double *WR = (double*)malloc(n*sizeof(double)); double *WI = (double*)malloc(n*sizeof(double)); // WR and WI not really required in this call logical *BWORK = (logical*)malloc(n*sizeof(logical)); integer res; integer sdim; dgees_ ("V","N",NULL,&n,sp,&n,&sdim,WR,WI,up,&n,WORK,&lwork,BWORK,&res); if(res>0) { return NOCONVER; } CHECK(res,res); free(WR); free(WI); free(BWORK); free(WORK); OK } int zgees_(char *jobvs, char *sort, L_fp select, integer *n, doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, doublereal *rwork, logical *bwork, integer *info); int schur_l_C(OCMAT(u), OCMAT(s)) { integer m = sr; integer n = sc; REQUIRES(m>=1 && n==m && ur==n && uc==n, BAD_SIZE); DEBUGMSG("schur_l_C"); integer lwork = 6*n; // FIXME doublecomplex *WORK = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); doublecomplex *W = (doublecomplex*)malloc(n*sizeof(doublecomplex)); // W not really required in this call logical *BWORK = (logical*)malloc(n*sizeof(logical)); double *RWORK = (double*)malloc(n*sizeof(double)); integer res; integer sdim; zgees_ ("V","N",NULL,&n,sp,&n,&sdim,W, up,&n, WORK,&lwork,RWORK,BWORK,&res); if(res>0) { return NOCONVER; } CHECK(res,res); free(W); free(BWORK); free(WORK); OK } //////////////////// LU factorization ///////////////////////// int dgetrf_(integer *m, integer *n, doublereal *a, integer * lda, integer *ipiv, integer *info); int lu_l_R(DVEC(ipiv), ODMAT(r)) { integer m = rr; integer n = rc; integer mn = MIN(m,n); REQUIRES(m>=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_R"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); integer res; dgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // FIXME } CHECK(res,res); int k; for (k=0; k=1 && n >=1 && ipivn == mn, BAD_SIZE); DEBUGMSG("lu_l_C"); integer* auxipiv = (integer*)malloc(mn*sizeof(integer)); integer res; zgetrf_ (&m,&n,rp,&m,auxipiv,&res); if(res>0) { res = 0; // FIXME } CHECK(res,res); int k; for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); DEBUGMSG("ldl_R"); integer* auxipiv = (integer*)malloc(n*sizeof(integer)); integer res; integer lda = rXc; integer lwork = -1; doublereal ans; dsytrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res); lwork = ceil(ans); doublereal* work = (doublereal*)malloc(lwork*sizeof(doublereal)); dsytrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); CHECK(res,res); int k; for (k=0; k=1 && rc==n && ipivn == n, BAD_SIZE); DEBUGMSG("ldl_R"); integer* auxipiv = (integer*)malloc(n*sizeof(integer)); integer res; integer lda = rXc; integer lwork = -1; doublecomplex ans; zhetrf_ ("L",&n,rp,&lda,auxipiv,&ans,&lwork,&res); lwork = ceil(ans.r); doublecomplex* work = (doublecomplex*)malloc(lwork*sizeof(doublecomplex)); zhetrf_ ("L",&n,rp,&lda,auxipiv,work,&lwork,&res); CHECK(res,res); int k; for (k=0; k=0 && x=0 && y #include typedef double complex TCD; typedef float complex TCF; #undef complex #include "lapack-aux.h" #define V(x) x##n,x##p #include #include #include #include #include #define MACRO(B) do {B} while (0) #define ERROR(CODE) MACRO(return CODE;) #define REQUIRES(COND, CODE) MACRO(if(!(COND)) {ERROR(CODE);}) #define OK return 0; #define MIN(A,B) ((A)<(B)?(A):(B)) #define MAX(A,B) ((A)>(B)?(A):(B)) #ifdef DBG #define DEBUGMSG(M) printf("*** calling aux C function: %s\n",M); #else #define DEBUGMSG(M) #endif #define CHECK(RES,CODE) MACRO(if(RES) return CODE;) #define BAD_SIZE 2000 #define BAD_CODE 2001 #define MEM 2002 #define BAD_FILE 2003 int sumF(KFVEC(x),FVEC(r)) { DEBUGMSG("sumF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumR(KDVEC(x),DVEC(r)) { DEBUGMSG("sumR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 0; for (i = 0; i < xn; i++) res += xp[i]; rp[0] = res; OK } int sumI(int m, KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 0; if (m==1) { for (i = 0; i < xn; i++) res += xp[i]; } else { for (i = 0; i < xn; i++) res = (res + xp[i]) % m; } rp[0] = res; OK } int sumL(int64_t m, KLVEC(x),LVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 0; if (m==1) { for (i = 0; i < xn; i++) res += xp[i]; } else { for (i = 0; i < xn; i++) res = (res + xp[i]) % m; } rp[0] = res; OK } int sumQ(KQVEC(x),QVEC(r)) { DEBUGMSG("sumQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int sumC(KCVEC(x),CVEC(r)) { DEBUGMSG("sumC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; res.r = 0; res.i = 0; for (i = 0; i < xn; i++) { res.r += xp[i].r; res.i += xp[i].i; } rp[0] = res; OK } int prodF(KFVEC(x),FVEC(r)) { DEBUGMSG("prodF"); REQUIRES(rn==1,BAD_SIZE); int i; float res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodR(KDVEC(x),DVEC(r)) { DEBUGMSG("prodR"); REQUIRES(rn==1,BAD_SIZE); int i; double res = 1; for (i = 0; i < xn; i++) res *= xp[i]; rp[0] = res; OK } int prodI(int m, KIVEC(x),IVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 1; if (m==1) { for (i = 0; i < xn; i++) res *= xp[i]; } else { for (i = 0; i < xn; i++) res = (res * xp[i]) % m; } rp[0] = res; OK } int prodL(int64_t m, KLVEC(x),LVEC(r)) { REQUIRES(rn==1,BAD_SIZE); int i; int res = 1; if (m==1) { for (i = 0; i < xn; i++) res *= xp[i]; } else { for (i = 0; i < xn; i++) res = (res * xp[i]) % m; } rp[0] = res; OK } int prodQ(KQVEC(x),QVEC(r)) { DEBUGMSG("prodQ"); REQUIRES(rn==1,BAD_SIZE); int i; complex res; float temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } int prodC(KCVEC(x),CVEC(r)) { DEBUGMSG("prodC"); REQUIRES(rn==1,BAD_SIZE); int i; doublecomplex res; double temp; res.r = 1; res.i = 0; for (i = 0; i < xn; i++) { temp = res.r * xp[i].r - res.i * xp[i].i; res.i = res.r * xp[i].i + res.i * xp[i].r; res.r = temp; } rp[0] = res; OK } double dnrm2_(integer*, const double*, integer*); double dasum_(integer*, const double*, integer*); double vector_max(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kr) { r = xp[k]; } } return r; } double vector_min(KDVEC(x)) { double r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index(KDVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } float vector_min_f(KFVEC(x)) { float r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_f(KFVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } int vector_min_i(KIVEC(x)) { int r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_i(KIVEC(x)) { int k, r = 0; for (k = 1; kr) { r = xp[k]; } } return r; } int64_t vector_min_l(KLVEC(x)) { int64_t r = xp[0]; int k; for (k = 1; kxp[r]) { r = k; } } return r; } int vector_min_index_l(KLVEC(x)) { int k, r = 0; for (k = 1; k0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } inline float float_sign(float x) { if(x>0) { return +1.0; } else if (x<0) { return -1.0; } else { return 0.0; } } #define OP(C,F) case C: { for(k=0;k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } #if defined(_WIN32) || defined(WIN32) int random_vector(unsigned int seed, int code, DVEC(r)) { int phase = 0; double V1,V2,S; srand(seed); int k; switch (code) { case 0: { // uniform for (k=0; k= 1 || S == 0); X = V1 * sqrt(-2 * log(S) / S); } else X = V2 * sqrt(-2 * log(S) / S); *phase = 1 - *phase; *pV1=V1; *pV2=V2; *pS=S; return X; } int random_vector(unsigned int seed, int code, DVEC(r)) { struct random_data buffer; char random_state[128]; memset(&buffer, 0, sizeof(struct random_data)); memset(random_state, 0, sizeof(random_state)); initstate_r(seed,random_state,sizeof(random_state),&buffer); // setstate_r(random_state,&buffer); // srandom_r(seed,&buffer); int phase = 0; double V1,V2,S; int k; switch (code) { case 0: { // uniform for (k=0; k *(double*)b; } int sort_valuesD(KDVEC(v),DVEC(r)) { memcpy(rp,vp,vn*sizeof(double)); qsort(rp,rn,sizeof(double),compare_doubles); OK } int compare_floats (const void *a, const void *b) { return *(float*)a > *(float*)b; } int sort_valuesF(KFVEC(v),FVEC(r)) { memcpy(rp,vp,vn*sizeof(float)); qsort(rp,rn,sizeof(float),compare_floats); OK } int compare_ints(const void *a, const void *b) { return *(int*)a > *(int*)b; } int sort_valuesI(KIVEC(v),IVEC(r)) { memcpy(rp,vp,vn*sizeof(int)); qsort(rp,rn,sizeof(int),compare_ints); OK } int compare_longs(const void *a, const void *b) { return *(int64_t*)a > *(int64_t*)b; } int sort_valuesL(KLVEC(v),LVEC(r)) { memcpy(rp,vp,vn*sizeof(int64_t)); qsort(rp,rn,sizeof(int64_t),compare_ints); OK } //////////////////////////////////////// #define SORTIDX_IMP(T,C) \ T* x = (T*)malloc(sizeof(T)*vn); \ int k; \ for (k=0;kval > ((DI*)b)->val; } int sort_indexD(KDVEC(v),IVEC(r)) { SORTIDX_IMP(DI,compare_doubles_i) } typedef struct FI { int pos; float val;} FI; int compare_floats_i (const void *a, const void *b) { return ((FI*)a)->val > ((FI*)b)->val; } int sort_indexF(KFVEC(v),IVEC(r)) { SORTIDX_IMP(FI,compare_floats_i) } typedef struct II { int pos; int val;} II; int compare_ints_i (const void *a, const void *b) { return ((II*)a)->val > ((II*)b)->val; } int sort_indexI(KIVEC(v),IVEC(r)) { SORTIDX_IMP(II,compare_ints_i) } typedef struct LI { int pos; int64_t val;} LI; int compare_longs_i (const void *a, const void *b) { return ((II*)a)->val > ((II*)b)->val; } int sort_indexL(KLVEC(v),LVEC(r)) { SORTIDX_IMP(II,compare_longs_i) } //////////////////////////////////////////////////////////////////////////////// int round_vector(KDVEC(v),DVEC(r)) { int k; for(k=0; k0; \ } \ OK int stepF(KFVEC(x),FVEC(y)) { STEP_IMP } int stepD(KDVEC(x),DVEC(y)) { STEP_IMP } int stepI(KIVEC(x),IVEC(y)) { STEP_IMP } int stepL(KLVEC(x),LVEC(y)) { STEP_IMP } //////////////////// cond ///////////////////////// #define COMPARE_IMP \ REQUIRES(xn==yn && xn==rn ,BAD_SIZE); \ int k; \ for(k=0;kyp[k]?1:0); \ } \ OK int compareF(KFVEC(x),KFVEC(y),IVEC(r)) { COMPARE_IMP } int compareD(KDVEC(x),KDVEC(y),IVEC(r)) { COMPARE_IMP } int compareI(KIVEC(x),KIVEC(y),IVEC(r)) { COMPARE_IMP } int compareL(KLVEC(x),KLVEC(y),IVEC(r)) { COMPARE_IMP } #define CHOOSE_IMP \ REQUIRES(condn==ltn && ltn==eqn && ltn==gtn && ltn==rn ,BAD_SIZE); \ int k; \ for(k=0;k0?gtp[k]:eqp[k]); \ } \ OK int chooseF(KIVEC(cond),KFVEC(lt),KFVEC(eq),KFVEC(gt),FVEC(r)) { CHOOSE_IMP } int chooseD(KIVEC(cond),KDVEC(lt),KDVEC(eq),KDVEC(gt),DVEC(r)) { CHOOSE_IMP } int chooseI(KIVEC(cond),KIVEC(lt),KIVEC(eq),KIVEC(gt),IVEC(r)) { CHOOSE_IMP } int chooseL(KIVEC(cond),KLVEC(lt),KLVEC(eq),KLVEC(gt),LVEC(r)) { CHOOSE_IMP } int chooseC(KIVEC(cond),KCVEC(lt),KCVEC(eq),KCVEC(gt),CVEC(r)) { CHOOSE_IMP } int chooseQ(KIVEC(cond),KQVEC(lt),KQVEC(eq),KQVEC(gt),QVEC(r)) { CHOOSE_IMP } //////////////////// reorder ///////////////////////// #define REORDER_IMP \ REQUIRES(kn == stridesn && stridesn == dimsn ,BAD_SIZE); \ int i,j,l; \ for (i=1,j=0,l=0;l import Distribution.Simple > main = defaultMain hmatrix-0.19.0.0/hmatrix.cabal0000644000000000000000000001140513267061276014254 0ustar0000000000000000Name: hmatrix Version: 0.19.0.0 License: BSD3 License-file: LICENSE Author: Alberto Ruiz Maintainer: Alberto Ruiz Stability: provisional Homepage: https://github.com/albertoruiz/hmatrix Synopsis: Numeric Linear Algebra Description: Linear systems, matrix decompositions, and other numerical computations based on BLAS and LAPACK. . Standard interface: "Numeric.LinearAlgebra". . Safer interface with statically checked dimensions: "Numeric.LinearAlgebra.Static". . Code examples: Category: Math tested-with: GHC==8.2, GHC==8.4 cabal-version: >=1.8 build-type: Simple extra-source-files: THANKS.md CHANGELOG extra-source-files: src/Internal/C/lapack-aux.h flag openblas description: Link with OpenBLAS (https://github.com/xianyi/OpenBLAS) optimized libraries. default: False manual: True flag disable-default-paths description: When enabled, don't add default hardcoded include/link dirs by default. Needed for hermetic builds like in nix. default: False manual: True library Build-Depends: base >= 4.8 && < 5, binary, array, deepseq, random, split, bytestring, storable-complex, semigroups, vector >= 0.8 hs-source-dirs: src exposed-modules: Numeric.LinearAlgebra Numeric.LinearAlgebra.Devel Numeric.LinearAlgebra.Data Numeric.LinearAlgebra.HMatrix Numeric.LinearAlgebra.Static other-modules: Internal.Vector Internal.Devel Internal.Vectorized Internal.Matrix Internal.ST Internal.IO Internal.Element Internal.Conversion Internal.LAPACK Internal.Numeric Internal.Algorithms Internal.Random Internal.Container Internal.Sparse Internal.Convolution Internal.Chain Numeric.Vector Internal.CG Numeric.Matrix Internal.Util Internal.Modular Internal.Static C-sources: src/Internal/C/lapack-aux.c src/Internal/C/vector-aux.c extensions: ForeignFunctionInterface ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans -fno-prof-auto cc-options: -O4 -Wall if arch(x86_64) cc-options: -msse2 if arch(i386) cc-options: -msse2 if os(OSX) if flag(openblas) if !flag(disable-default-paths) extra-lib-dirs: /opt/local/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack if !flag(disable-default-paths) extra-lib-dirs: /opt/local/lib/ include-dirs: /opt/local/include/ extra-lib-dirs: /usr/local/lib/ include-dirs: /usr/local/include/ if arch(i386) cc-options: -arch i386 frameworks: Accelerate if os(freebsd) if flag(openblas) if !flag(disable-default-paths) extra-lib-dirs: /usr/local/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack if !flag(disable-default-paths) extra-lib-dirs: /usr/local/lib include-dirs: /usr/local/include extra-libraries: gfortran if os(windows) if flag(openblas) extra-libraries: libopenblas, libgcc_s_seh-1, libgfortran, libquadmath-0 else extra-libraries: blas lapack if os(linux) if flag(openblas) if !flag(disable-default-paths) extra-lib-dirs: /usr/lib/openblas/lib extra-libraries: openblas else extra-libraries: blas lapack if arch(x86_64) cc-options: -fPIC source-repository head type: git location: https://github.com/albertoruiz/hmatrix hmatrix-0.19.0.0/THANKS.md0000644000000000000000000002166213245244501013122 0ustar0000000000000000I thank Don Stewart, Henning Thielemann, Bulat Ziganshin, Heinrich Apfelmus, and all the people in the Haskell mailing lists for their help. I am particularly grateful to Vivian McPhail for his excellent contributions: improved configure.hs, Binary instances for Vector and Matrix, support for Float and Complex Float elements, module reorganization, monadic mapVectorM, and many other improvements. - Nico Mahlo discovered a bug in the eigendecomposition wrapper. - Frederik Eaton discovered a bug in the design of the wrappers. - Eric Kidd has created a wiki page explaining the installation on MacOS X: http://www.haskell.org/haskellwiki/GSLHaskell_on_MacOS_X - Fawzi Mohamed discovered a portability bug in the lapack wrappers. - Pedro E. López de Teruel fixed the interface to lapack. - Antti Siira discovered a bug in the plotting functions. - Paulo Tanimoto helped to fix the configuration of the required libraries. He also discovered the segfault of minimize.hs in ghci. - Xiao-Yong Jin reported a bug on x86_64 caused by the assumptions in f2c.h, which are wrong for this architecture. - Jason Schroeder reported an error in the documentation. - Bulat Ziganshin gave invaluable help for the ST monad interface to in-place modifications. - Don Stewart fixed the implementation of the internal data structures to achieve excellent, C-like performance in Haskell functions which explicitly work with the elements of vectors and matrices. - Dylan Alex Simon improved the numeric instances to allow optimized implementations of signum and abs on Vectors. - Pedro E. López de Teruel discovered the need of asm("finit") to avoid the wrong NaNs produced by foreign functions. - Reiner Pope added support for luSolve, based on (d|z)getrs. Made Matrix a product type and added changes to improve the code generated by hmatrix-syntax. - Simon Beaumont reported the need of QuickCheck<2 and the invalid asm("finit") on ppc. He also contributed the configuration options for the accelerate framework on OS X. - Daniel Schüssler added compatibility with QuickCheck 2 as well as QuickCheck 1 using the C preprocessor. He also added some implementations for the new "shrink" method of class Arbitrary. - Tracy Wadleigh improved the definitions of (|>) and (><), which now apply an appropriate 'take' to the given lists so that they may be safely used on lists that are too long (or infinite). - Chris Waterson improved the configure.hs program for OS/X. - Erik de Castro Lopo added buildVector and buildMatrix, which take a size parameter(s) and a function that maps vector/matrix indices to the values at that position. - Jean-Francois Tremblay discovered an error in the tutorial. - Gilberto Camara contributed improved blas and lapack dlls for Windows. - Heinrich Apfelmus fixed hmatrix.cabal for OS/X. He also tested the package on PPC discovering a problem in zgesdd. - Felipe Lessa tested the performance of GSL special function bindings and contributed the cabal flag "safe-cheap". - Ozgur Akgun suggested better symbols for the Bound constructors in the Linear Programming package. - Tim Sears reported the zgesdd problem also in intel mac. - Max Suica simplified the installation on Windows and improved the instructions. - John Billings first reported an incompatibility with QuickCheck>=2.1.1 - Alexey Khudyakov cleaned up PRAGMAS and fixed some hlint suggestions. - Torsten Kemps-Benedix reported an installation problem in OS/X. - Stefan Kersten fixed hmatrix.cabal for 64-bit ghc-7 in OS/X - Sacha Sokoloski reported an installation problem on Arch Linux and helped with the configuration. - Carter Schonwald helped with the configuration for Homebrew OS X and found a tolerance problem in test "1E5 rots". He also discovered a bug in the signature of cmap and fixed the cabal file. - Duncan Coutts reported a problem with configure.hs and contributed a solution and a simplified Setup.lhs. - Mark Wright fixed the import of vector >= 0.8. - Bas van Dijk fixed the import of vector >= 0.8, got rid of some deprecation warnings, used more explicit imports, and updated to ghc-7.4. - Tom Nielsen discovered a problem in Config.hs, exposed by link problems in Ubuntu 11.10 beta, and fixed the link options on freebsd. - Daniel Fischer reported some Haddock markup errors. - Danny Chan added support for integration over infinite intervals, and fixed Configure.hs using platform independent functions. - Clark Gaebel removed superfluous thread safety. - Jeffrey Burdges reported a glpk link problem on OS/X - Jian Zhang reported the Windows installation problem due to new ODE interface. - Mihaly Barasz and Ben Gamari fixed mapMatrix* and mapMatrixWithIndex - Takano Akio fixed off-by-one errors in gsl-aux.c producing segfaults. - Alex Lang implemented uniRoot and uniRootJ for one-dimensional root-finding, and fixed asRow and asColumn for empty vectors. - Mike Ledger contributed alternative FFI helpers for matrix interoperation with C - Stephen J. Barr suggested flipping argument order in the double integral example - Greg Horn fixed the bus error on ghci 64-bit. - Kristof Bastiaensen added bindings for one-dimensional minimization. - Matthew Peddie added bindings for gsl_integrate_cquad doubly-adaptive quadrature for difficult integrands. - Ben Gamari exposed matrixFromVector for Development. - greg94301 reported tolerance issues in the tests. - Clemens Lang updated the MacPort installation instructions. - Henning Thielemann reported the pinv inefficient implementation and the need of pkgconfig-depends. - bdoering reported the problem of zero absolute tolerance in the integration functions. - Alexei Uimanov replaced fromList by Vector.fromList. - Adam Vogt updated the code for ghc-7.7 - Mike Meyer (mwm) added freeBSD library configuration information. - tfgit updated the OSX installation instructions via Homebrew - "yokto" and "ttylec" reported the problem with the dot product of complex vectors. - Samium Gromoff reported a build failure caused by a size_t - int mismatch. - Denis Laxalde separated the gsl tests from the base ones. - Dominic Steinitz (idontgetoutmuch) reported a bug in the static diagonal creation functions and added Cholesky to Static. He also added support for tridiagonal matrix solver and fixed several bugs. - Dylan Thurston reported an error in the glpk documentation and ambiguity in the description of linearSolve. - Adrian Victor Crisciu developed an installation method for platforms which don't provide shared lapack libraries. - Ian Ross reported the max/minIndex bug. - Niklas Hambüchen improved the documentation and fixed compilation with GHC-8.2 adding type signatures. Added disable-default-paths flag. - "erdeszt" optimized "conv" using a direct vector reverse. - John Shahbazian added support for openBLAS. - "yongqli" reported the bug in randomVector (rand() is not thread-safe and drand48_r() is not portable). - Kiwamu Ishikura improved randomVector for OSX - C.J. East fixed the examples for simplex. - Ben Gamari contributed fixes for ghc 7.10 - Piotr Mardziel added general sparse constraints to simplex and the interface to glp_exact - Maxim Baz fixed an instance declaration for ghc 7.11 - Thomas M. DuBuisson fixed a C include file. - Matt Peddie wrote the interfaces to the interpolation and simulated annealing modules. - "maxc01" solved uninstallability in FreeBSD, improved urandom, and fixed a Windows link error using rand_s. - "ntfrgl" added {take,drop}Last{Rows,Columns} and odeSolveVWith with generalized step control function and fixed link errors related to mod/mod_l. - "cruegge" discovered a bug in the conjugate gradient solver for sparse symmetric systems. - Ilan Godik and Douglas McClean helped with Windows support. - Vassil Keremidchiev fixed the cabal options for OpenBlas, fixed several installation issues, and added support for stack-based build. He also added support for LTS 8.15 under Windows. - Greg Nwosu fixed arm compilation - Patrik Jansson changed meanCov and gaussianSample to use Herm type. Fixed stack.yaml. - Justin Le added NFData instances for Static types, added mapping and outer product methods to Domain, and many other functions to the Static module. - Sidharth Kapur added Normed and numeric instances for several Static types, fixed the CPP issue in cabal files, and made many other contributions. - Matt Renaud improved the documentation. - Joshua Moerman fixed cabal/stack flags for windows. - Francesco Mazzoli, Niklas Hambüchen, Patrick Chilton, and Andras Slemmer discovered a serious and subtle bug in the wrapper helpers causing memory corruption. Andras Slemmer fixed the bug. Thank you all. - Kevin Slagle implemented thinQR and thinRQ, much faster than the original qr, and added compactSVDTol. He also added an optimized reorderVector for hTensor. - "fedeinthemix" suggested a better name and a more general type for unitary. - Huw Campbell fixed a bug in equal. - Hiromi Ishii fixed compilation problems for ghc-8.4 hmatrix-0.19.0.0/CHANGELOG0000644000000000000000000001514013267060772013026 0ustar00000000000000000.18.0.0 -------- * Many new functions and instances in the Static module * meanCov and gaussianSample use Herm type * thinQR, thinRQ * compactSVDTol * unitary changed to normalize, also admits Vector (Complex Double) 0.17.0.0 -------- * eigSH, chol, and other functions that work with Hermitian or symmetric matrices now take a special "Herm" argument that can be created by means of "sym" or "mTm". The unchecked versions of those functions have been removed and we use "trustSym" to create the Herm type when the matrix is known to be Hermitian/symmetric. * Improved matrix extraction (??) and rectangular matrix slices without data copy * Basic support of Int32 and Int64 elements * remap, more general cond, sortIndex * Experimental support of type safe modular arithmetic, including linear system solver and LU factorization * Elementary row operations and inplace matrix slice products in the ST monad * Improved development tools. * Old compatibility modules removed, simpler organization of internal modules * unitary, pairwiseD2, tr' * ldlPacked, ldlSolve for indefinite symmetric systems (apparently not faster than the general solver based on the LU) * LU, LDL, and QR types for these compact decompositions. 0.16.1.0 -------- * Added (|||) and (===) for "besides" and "above" * rowOuters 0.16.0.0 -------- * The modules Numeric.GSL.* have been moved to the new package hmatrix-gsl. * The package "hmatrix" now depends only on BLAS and LAPACK and the license has been changed to BSD3. * Added more organized reexport modules: Numeric.LinearAlgebra.HMatrix Numeric.LinearAlgebra.Data Numeric.LinearAlgebra.Devel For normal usage we only need to import Numeric.LinearAlgebra.HMatrix. (The documentation is now hidden for Data.Packed.*, Numeric.Container, and the other Numeric.LinearAlgebra.* modules, but they continue to be exposed for backwards compatibility.) * Added support for empty arrays, extending automatic conformability (very useful for construction of block matrices). * Added experimental support for sparse linear systems. * Added experimental support for static dimension checking and inference using type-level literals. * Added a different operator for the matrix-vector product. (available from the new reexport module). * "join" deprecated (use "vjoin"). * "dot" now conjugates the first input vector. * Added "udot" (unconjugated dot product). * Added to/from ByteString * Added "sortVector", "roundVector" * Added Monoid instance for Matrix using matrix product. * Added several pretty print functions * Improved "build", "konst", "linspace", "LSDiv", loadMatrix', and other small changes. * In hmatrix-glpk: (:=>:) change to (:>=:). Added L_1 linear system solvers. * Improved error messages. * Added many usage examples in the documentation. 0.15.2.0 -------- * general pinvTol and improved pinv 0.15.1.0 -------- * One-dimensional minimization * Doubly-adaptive quadrature for difficult integrands 0.15.0.0 -------- * Data.Packed.Foreign (additional FFI helpers) * NFData instance of Matrix * Unidimensional root finding * In Numeric.LinearAlgebra.Util: pairwise2D, rowOuters, null1, null1sym, size, unitary, mt, (¦), (?), (¿) * diagBlock * meanCov moved to Container 0.14.1.0 -------- * In Numeric.LinearAlgebra.Util: convolution: corr, conv, corr2, conv2, separable, corrMin kronecker: vec, vech, dup, vtrans 0.14.0.0 -------- * integration over infinite intervals * msadams and msbdf methods for ode * Numeric.LinearAlgebra.Util * (<\>) extended to multiple right-hand sides * orth 0.13.0.0 -------- * tests moved to new package hmatrix-tests 0.11.2.0 -------- * geigSH' (symmetric generalized eigensystem) * mapVectorWithIndex 0.11.1.0 -------- * exported Mul * mapMatrixWithIndex{,M,M_} 0.11.0.0 -------- * flag -fvector default = True * invlndet (inverse and log of determinant) * step, cond * find * assoc, accum 0.10.0.0 -------- * Module reorganization * Support for Float and Complex Float elements (excluding LAPACK computations) * Binary instances for Vector and Matrix * optimiseMult * mapVectorM, mapVectorWithIndexM, unzipVectorWith, and related functions. * diagRect admits diagonal vectors of any length without producing an error, and takes an additional argument for the off-diagonal elements. * different signatures in some functions 0.9.3.0 -------- * flag -fvector to optionally use Data.Vector.Storable.Vector without any conversion. * Simpler module structure. * toBlocks, toBlocksEvery * cholSolve, mbCholSH * GSL Nonlinear Least-Squares fitting using Levenberg-Marquardt. * GSL special functions moved to separate package hmatrix-special. * Added offset of Vector, allowing fast, noncopy subVector (slice). Vector is now identical to Roman Leshchinskiy's Data.Vector.Storable.Vector, so we can convert from/to them in O(1). * Removed Data.Packed.Convert, see examples/vector.hs 0.8.3.0 -------- * odeSolve * Matrix arithmetic automatically replicates matrix with single row/column * latexFormat, dispcf 0.8.2.0 -------- * fromRows/fromColumns now automatically expand vectors of dim 1 to match the common dimension. fromBlocks also replicates single row/column matrices. Previously all dimensions had to be exactly the same. * display utilities: dispf, disps, vecdisp * scalar * minimizeV, minimizeVD, using Vector instead of lists. 0.8.1.0 -------- * runBenchmarks 0.8.0.0 -------- * singularValues, fullSVD, thinSVD, compactSVD, leftSV, rightSV and complete interface to [d|z]gesdd. Algorithms based on the SVD of large matrices can now be significantly faster. * eigenvalues, eigenvaluesSH * linearSolveLS, rq 0.7.2.0 -------- * ranksv 0.7.1.0 -------- * buildVector/buildMatrix * removed NFData instances 0.6.0.0 -------- * added randomVector, gaussianSample, uniformSample, meanCov * added rankSVD, nullspaceSVD * rank, nullspacePrec, and economy svd defined in terms of ranksvd. * economy svd now admits zero rank matrices and return a "degenerate rank 1" decomposition with zero singular value. * added NFData instances for Matrix and Vector. * liftVector, liftVector2 replaced by mapVector, zipVector. hmatrix-0.19.0.0/src/Internal/C/lapack-aux.h0000644000000000000000000000663513223170642016537 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 IVEC(A) int A##n, int*A##p #define LVEC(A) int A##n, int64_t*A##p #define FVEC(A) int A##n, float*A##p #define DVEC(A) int A##n, double*A##p #define QVEC(A) int A##n, complex*A##p #define CVEC(A) int A##n, doublecomplex*A##p #define PVEC(A) int A##n, void* A##p, int A##s #define IMAT(A) int A##r, int A##c, int* A##p #define LMAT(A) int A##r, int A##c, int64_t* A##p #define FMAT(A) int A##r, int A##c, float* A##p #define DMAT(A) int A##r, int A##c, double* A##p #define QMAT(A) int A##r, int A##c, complex* A##p #define CMAT(A) int A##r, int A##c, doublecomplex* A##p #define PMAT(A) int A##r, int A##c, void* A##p, int A##s #define KIVEC(A) int A##n, const int*A##p #define KLVEC(A) int A##n, const int64_t*A##p #define KFVEC(A) int A##n, const float*A##p #define KDVEC(A) int A##n, const double*A##p #define KQVEC(A) int A##n, const complex*A##p #define KCVEC(A) int A##n, const doublecomplex*A##p #define KPVEC(A) int A##n, const void* A##p, int A##s #define KIMAT(A) int A##r, int A##c, const int* A##p #define KLMAT(A) int A##r, int A##c, const int64_t* A##p #define KFMAT(A) int A##r, int A##c, const float* A##p #define KDMAT(A) int A##r, int A##c, const double* A##p #define KQMAT(A) int A##r, int A##c, const complex* A##p #define KCMAT(A) int A##r, int A##c, const doublecomplex* A##p #define KPMAT(A) int A##r, int A##c, const void* A##p, int A##s #define VECG(T,A) int A##n, T* A##p #define MATG(T,A) int A##r, int A##c, int A##Xr, int A##Xc, T* A##p #define OIMAT(A) MATG(int,A) #define OLMAT(A) MATG(int64_t,A) #define OFMAT(A) MATG(float,A) #define ODMAT(A) MATG(double,A) #define OQMAT(A) MATG(complex,A) #define OCMAT(A) MATG(doublecomplex,A) #define KOIMAT(A) MATG(const int,A) #define KOLMAT(A) MATG(const int64_t,A) #define KOFMAT(A) MATG(const float,A) #define KODMAT(A) MATG(const double,A) #define KOQMAT(A) MATG(const complex,A) #define KOCMAT(A) MATG(const doublecomplex,A) #define AT(m,i,j) (m##p[(i)*m##Xr + (j)*m##Xc]) #define TRAV(m,i,j) int i,j; for (i=0;i0) { return m >=0 ? m : m+b; } else { return m <=0 ? m : m+b; } } static inline int64_t mod_l (int64_t a, int64_t b) { int64_t m = a % b; if (b>0) { return m >=0 ? m : m+b; } else { return m <=0 ? m : m+b; } }