diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,5 +1,35 @@ # Change log for the `lapack` package +## 0.4 + + * Unified `Matrix` type that provides the same type parameters + across all special types. + This reduces the use of type functions and improves type inference. + + * Unified `transpose` and `adjoint` functions enabled by the new `Matrix` type. + + * `Unpacked` format: + We now support data type and according functions + for unpacked triangular, symmetric and Hermitian matrices. + Enables declaration e.g. of Hessenberg matrices. + + * There are now two types of square matrices: + + * `Square`: height and width shapes match exactly + + * `LiberalSquare`: only the sizes of height and width match + + * `Square.eigensystem`: + Use liberal square as transformation matrix, + such that the eigenvalue array has `ShapeInt` shape. + The dimension of the input square matrix does not make sense + as shape for the eigenvalue array. + + * `Square.fromGeneral` -> `fromFull` + + * `Orthogonal.affineKernelFromSpan` -> `affineFiberFromFrame`, + `Orthogonal.affineSpanFromKernel` -> `affineFrameFromFiber` + ## 0.3.2 * `Orthogonal`: `project`, `affineKernelFromSpan`, `affineSpanFromKernel`, diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) Henning Thielemann 2018 +Copyright (c) Henning Thielemann 2018-2021 All rights reserved. diff --git a/ReadMe.md b/ReadMe.md --- a/ReadMe.md +++ b/ReadMe.md @@ -93,7 +93,22 @@ [HTML](https://hackage.haskell.org/package/blaze-html) for HyperHaskell. +You may tell GHCi to use `Format` class instead of `Show`: +~~~~ +Fmt> let lapackPrint x = x##"%.3f" +Fmt> :set -interactive-print lapackPrint +~~~~ + +You may permanently configure this one in your local `.ghci` file. +If you want to display values via `Show` class, +you can always fall back by: + +~~~~ +Fmt> print "Hello" +~~~~ + + ## Matrix vs. Vector Vectors are `Storable.Array`s from the @@ -140,53 +155,157 @@ or use the decompositions for solving simultaneous linear equations. -## Type tags for content constraints +## Matrix type parameters -Full matrices have additional type tags to distinguish -between four cases of the size relations between -the height and the width of a full matrix. -In a matrix of type `Matrix.Full vert horiz height width a` -the type variables mean: +LAPACK supports a variety of special matrix types, +e.g. dense, banded, triangular, symmetric, Hermitian matrices +and our Haskell interface supports them, too. +There are two layers: +The low level layer addresses how matrices are stored for LAPACK. +Matrices and vectors are stored in the `Array` type +from `comfort-array:Data.Array.Comfort.Storable` +using shape types from `Numeric.LAPACK.Matrix.Layout`. +The high level layer provides a matrix type +in `Numeric.LAPACK.Matrix.Array` +with mathematically relevant type parameters. +The matrix type is: -~~~~ -vert height -Small Small - Square matrix height==width -Big Small - Tall matrix size height >= size width -Small Big - Wide matrix size height <= size width -Big Big - General matrix height and width arbitrary -~~~~ + ArrayMatrix pack property lower upper meas vert horiz height width a -The relations are defined using two type tags -in order to support matrix transposition without hassle. -Using `Small Small` for square matrices -and `Big Big` for general matrices appears to be arbitrary, -but is chosen such that altering `Small` to `Big` -generalizes the size relation. +The type parameters are from right to left: -Likewise we use the `Triangular` matrix type -also to represent diagonal and symmetric matrices. -For `Matrix.Triangular lo diag up size a` we have the cases: + * `a` - the element type -~~~~ -lo up -Empty Empty - Diagonal matrix -Empty Full - Upper triangular matrix -Full Empty - Lower triangular matrix -Full Full - Symmetric matrix -~~~~ + * `height` and `width` are the vertical and horizontal shapes of the matrix -The `diag` type tag can be `NonUnit` or `Unit`. -`Unit` can be used for matrices -that always have a unit diagonal by construction. -The property of a unit diagonal is preserved by some operations -and enables some optimizations by LAPACK. -E.g. solving with a unit triangular matrix does not require division -and thus cannot fail due to division by zero. -`NonUnit` is a bit of a misnomer. -A `NonUnit` matrix can still have a unit diagonal, -but in general it has not and no optimizations will take place. + * `meas vert horiz` form a group with following possible assignments: + meas | vert | horiz | name | condition + --------|---------|---------|----------------|:-------------------------: + `Shape` | `Small` | `Small` | Square matrix | height == width + `Size` | `Small` | `Small` | Liberal square | size height == size width + `Size` | `Big` | `Small` | Tall matrix | size height >= size width + `Size` | `Small` | `Big` | Wide matrix | size height <= size width + `Size` | `Big` | `Big` | General matrix | arbitrary height and width + Think of `meas` as the measurement + that goes into the relation of dimensions. + You can either compare shapes (`meas ~ Shape`) + or their sizes (`meas ~ Size`). + For `vert` and `horiz` the possible values mean: + + * `Small`: The corresponding dimension is equal + to the minimum of `height` and `width`. + + * `Big`: The corresponding dimension has no further restrictions, + but it is of course at least the minimum of `height` and `width`. + + The names `Small` and `Big` fit best to tall and wide matrices. + The remaining combinations `Small Small` for `Square` + and `Big Big` for `General` appear to be arbitrary, but they help to + e.g. treat square and tall matrices the same way, where sensible. + Turning `Shape` into `Size` or `Small` into `Big` + relaxes a dimension relation. + + * `lower upper` count the numbers of non-zero off-diagonals. + + Off course, stored off-diagonals can consist entirely of zeros. + Thus more precisely we have to say, that `lower` and `upper` tell + that all values outside the numbered bands are zero. + + `lower` and `upper` can be: + + * `Filled` - no restriction on the number of off-diagonals. + + * `Bands n`, + where `n` is a natural number unarily encoded in types. + + `Empty` is a synonym for `Bands U0`. + + * `property` can be + + * `Arbitrary` - + this type does not make any further promises about the matrix elements + + * `Unit` - matrix is triangular with a unit diagonal + + It can be used for matrices + that always have a unit diagonal by construction. + This property is preserved by some operations + and enables optimizations by LAPACK. + Solving with a unit triangular matrix does not require division + and thus cannot fail due to division by zero. + + * `Symmetric` - matrix is symmetric + + * `Hermitian` - matrix is Hermitian (also supported for real elements) + + The internal `Hermitian` property also has three type tags `neg zero pos` + to restrict the range of values of bilinear-forms. + This way you can denote positive definiteness and semidefiniteness. + + * `pack` can `Packed` or `Unpacked`. + + `Unpacked` means that the full matrix + bounded by `height` and `width` is stored. + `Packed` format is supported + for triangular, symmetric, Hermitian and banded matrices. + + For banded matrices you should always prefer the packed format. + For triangular, symmetric and Hermitian matrices + LAPACK does not always support packed format natively + and our Haskell interface converts forth and back silently. + I also think that unpacked triangular formats + enjoy better support by vectorized block algorithms. + Thus, the unpacked triangular format may be better for performance + although it requires twice as much space as the packed format. + The packed triangular format however is still + the default format for conversion to and from lists, + because this prevents the user from declaring non-zero values + in the empty area of a triangular matrix. + + +Let us examine some examples: + + * Diagonal matrix: + + `ArrayMatrix Packed Arbitrary Empty Empty Shape Small Small sh sh a` + + * Packed upper triangular matrix: + + `ArrayMatrix Packed Arbitrary Empty Filled Shape Small Small sh sh a` + + * Unpacked unit lower triangular matrix: + + `ArrayMatrix Unpacked Unit Filled Empty Shape Small Small sh sh a` + + * Complex-valued symmetric matrix: + + `ArrayMatrix Packed Symmetric Filled Filled Shape Small Small sh sh (Complex a)` + + * Tall banded matrix: + + `ArrayMatrix Packed Arbitrary (Bands sub) (Bands super) Size Big Small height width a` + +The type tags have a mathematical meaning +and this pays off for operations on matrices. +E.g. matrix multiplication adds off-diagonals. +Matrix inversion fills non-zero triangular matrix parts. +The five supported relations for matrix dimensions are transitive, +and thus matrix multiplication maintains a dimension relation, +e.g. tall times tall is tall. + +Please note, that not all type parameter combinations are supported. +Some restrictions are dictated by mathematics, +e.g. Hermitian matrices must always be square, +matrices with unit diagonal must always be triangular and so on. +Some combinations are simply not supported, because they do not add value. +E.g. a (square) diagonal matrix is always symmetric +but we allow `Symmetric` only together with `Filled`. +Forbidden combinations are often not prevented at the type level, +but you will not be able to construct a matrix of a forbidden type. + + ## Infix operators The package provides fancy infix operators like `#*|` and `\*#`. @@ -225,3 +344,30 @@ But sometimes this may mean that you have to mix left and right associative operators, and thus you may still need parentheses. + + +## Type errors + +You might encounter cryptic type errors +that refer to the encoding of particular matrix types +via matrix type parameters. + +E.g. the error + + Couldn't match type `Numeric.LAPACK.Matrix.Extent.Big` + with `Numeric.LAPACK.Matrix.Extent.Small` + +may mean that you passed `Square` +where `General` or `Tall` was expected. +You may solve the problem with a function +like `Square.toFull` or `Square.fromFull`. + +The error + + Couldn't match type `Type.Data.Bool.False` + with `Type.Data.Bool.True` + +most likely refers to non-matching definiteness warranties +in a `Hermitian` matrix. +You may try a function like `Hermitian.assureFullRank` +or `Hermitian.relaxIndefinite` to fix the issue. diff --git a/lapack.cabal b/lapack.cabal --- a/lapack.cabal +++ b/lapack.cabal @@ -1,12 +1,12 @@ Cabal-Version: 2.2 Name: lapack -Version: 0.3.2 +Version: 0.4 License: BSD-3-Clause License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: https://hub.darcs.net/thielema/lapack/ -Category: Data Structures +Category: Math Synopsis: Numerical Linear Algebra using LAPACK Description: This is a high-level interface to LAPACK. @@ -29,6 +29,9 @@ * Dependency only on BLAS and LAPACK, no GSL . * Works with matrices and vectors with zero dimensions. + This one is tricky and still leads to surprises + since different LAPACK implementations + consider different situations as corner cases. . * No automatic (and dangerous) implicit expansion of singleton vectors or matrices. @@ -41,7 +44,7 @@ Support for nice formatting in HyperHaskell. . See also: @hmatrix@. -Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.2.2 +Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.6.5 Build-Type: Simple Extra-Source-Files: ReadMe.md @@ -50,7 +53,7 @@ test-module.list Source-Repository this - Tag: 0.3.2 + Tag: 0.4 Type: darcs Location: https://hub.darcs.net/thielema/lapack/ @@ -64,44 +67,54 @@ Library Build-Depends: - lapack-ffi >=0.0.1 && <0.1, + lapack-ffi >=0.0.3 && <0.1, blas-ffi >=0.0 && <0.2, netlib-ffi >=0.1.1 && <0.2, - comfort-array >=0.4 && <0.5, + comfort-array-shape >=0.0 && <0.1, + comfort-array >=0.5 && <0.6, guarded-allocation >=0.0 && <0.1, - hyper >=0.1 && <0.2, + hyper >=0.1 && <0.3, blaze-html >=0.7 && <0.10, text >=1.2 && <1.3, boxes >=0.1.5 && <0.2, deepseq >=1.3 && <1.5, lazyio >=0.1 && <0.2, transformers >=0.4 && <0.6, - tfp >=1.0.1 && <1.1, + tfp >=1.0.2 && <1.1, fixed-length >=0.2 && <0.3, semigroups >=0.18.3 && <1.0, non-empty >=0.3 && <0.4, - utility-ht >=0.0.10 && <0.1, + Stream >=0.4.7 && <0.5, + tagged >=0.7 && <0.9, + utility-ht >=0.0.13 && <0.1, base >=4.5 && <5 Default-Language: Haskell98 GHC-Options: -Wall Hs-Source-Dirs: src Exposed-Modules: + Numeric.LAPACK.Matrix.Shape.Omni + Numeric.LAPACK.Matrix Numeric.LAPACK.Matrix.Special + Numeric.LAPACK.Matrix.Superscript Numeric.LAPACK.Matrix.Array Numeric.LAPACK.Matrix.Extent - Numeric.LAPACK.Matrix.Shape.Box Numeric.LAPACK.Matrix.Shape + Numeric.LAPACK.Matrix.Layout + Numeric.LAPACK.Matrix.Full Numeric.LAPACK.Matrix.Square + Numeric.LAPACK.Matrix.Quadratic Numeric.LAPACK.Matrix.Hermitian Numeric.LAPACK.Matrix.HermitianPositiveDefinite Numeric.LAPACK.Matrix.Symmetric Numeric.LAPACK.Matrix.Triangular + Numeric.LAPACK.Matrix.Diagonal Numeric.LAPACK.Matrix.Banded Numeric.LAPACK.Matrix.BandedHermitian Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite Numeric.LAPACK.Matrix.Permutation + Numeric.LAPACK.Matrix.Function Numeric.LAPACK.Vector Numeric.LAPACK.Scalar Numeric.LAPACK.Orthogonal @@ -109,7 +122,6 @@ Numeric.LAPACK.Permutation Numeric.LAPACK.Linear.LowerUpper Numeric.LAPACK.Singular - Numeric.LAPACK.ShapeStatic Numeric.LAPACK.Shape Numeric.LAPACK.Format Numeric.LAPACK.Output @@ -118,7 +130,7 @@ Other-Modules: Numeric.LAPACK.Singular.Plain Numeric.LAPACK.Orthogonal.Plain - Numeric.LAPACK.Orthogonal.Private + Numeric.LAPACK.Orthogonal.Basic Numeric.LAPACK.Linear.Plain Numeric.LAPACK.Linear.Private Numeric.LAPACK.Split @@ -126,7 +138,7 @@ Numeric.LAPACK.Matrix.Square.Basic Numeric.LAPACK.Matrix.Square.Linear Numeric.LAPACK.Matrix.Square.Eigen - Numeric.LAPACK.Matrix.Triangular.Private + Numeric.LAPACK.Matrix.Mosaic.Private Numeric.LAPACK.Matrix.Triangular.Basic Numeric.LAPACK.Matrix.Triangular.Linear Numeric.LAPACK.Matrix.Triangular.Eigen @@ -136,30 +148,40 @@ Numeric.LAPACK.Matrix.Hermitian.Eigen Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear Numeric.LAPACK.Matrix.Symmetric.Basic - Numeric.LAPACK.Matrix.Symmetric.Private + Numeric.LAPACK.Matrix.Symmetric.Linear + Numeric.LAPACK.Matrix.Symmetric.Unified + Numeric.LAPACK.Matrix.Mosaic.Unpacked + Numeric.LAPACK.Matrix.Mosaic.Packed + Numeric.LAPACK.Matrix.Mosaic.Basic + Numeric.LAPACK.Matrix.Mosaic.Generic Numeric.LAPACK.Matrix.Banded.Basic Numeric.LAPACK.Matrix.Banded.Linear Numeric.LAPACK.Matrix.BandedHermitian.Basic Numeric.LAPACK.Matrix.BandedHermitian.Eigen Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear - Numeric.LAPACK.Matrix.Shape.Private + Numeric.LAPACK.Matrix.Layout.Private Numeric.LAPACK.Matrix.Extent.Private + Numeric.LAPACK.Matrix.Extent.Strict Numeric.LAPACK.Matrix.Divide Numeric.LAPACK.Matrix.Multiply Numeric.LAPACK.Matrix.Class Numeric.LAPACK.Matrix.Basic Numeric.LAPACK.Matrix.Plain.Class - Numeric.LAPACK.Matrix.Plain.Divide - Numeric.LAPACK.Matrix.Plain.Multiply - Numeric.LAPACK.Matrix.Plain.Indexed Numeric.LAPACK.Matrix.Plain.Format Numeric.LAPACK.Matrix.Plain Numeric.LAPACK.Matrix.Indexed Numeric.LAPACK.Matrix.Type Numeric.LAPACK.Matrix.Inverse + Numeric.LAPACK.Matrix.Array.Indexed Numeric.LAPACK.Matrix.Array.Banded - Numeric.LAPACK.Matrix.Array.Triangular + Numeric.LAPACK.Matrix.Array.Mosaic + Numeric.LAPACK.Matrix.Array.Hermitian + Numeric.LAPACK.Matrix.Array.Unpacked Numeric.LAPACK.Matrix.Array.Basic + Numeric.LAPACK.Matrix.Array.Divide + Numeric.LAPACK.Matrix.Array.Multiply + Numeric.LAPACK.Matrix.Lazy.UpperTriangular + Numeric.LAPACK.Matrix.ModifierTyped Numeric.LAPACK.Matrix.Modifier Numeric.LAPACK.Matrix.RowMajor Numeric.LAPACK.Matrix.Private @@ -174,6 +196,7 @@ lapack, netlib-ffi, tfp, + comfort-array-shape, comfort-array, data-ref >=0.0.1 && <0.1, unique-logic-tf >=0.5.1 && <0.6, @@ -200,6 +223,7 @@ DocTest.Main Test.Shape Test.Indexed + Test.Function Test.Divide Test.Multiply Test.Generic @@ -210,6 +234,7 @@ Test.Triangular Test.Symmetric Test.Hermitian + Test.Mosaic Test.Orthogonal Test.LowerUpper Test.Banded @@ -220,6 +245,8 @@ Test.Logic Test.Format Test.Utility + Numeric.LAPACK.Matrix.Banded.Naive + Numeric.LAPACK.Matrix.BandedHermitian.Naive Executable lapack-debug Default-Language: Haskell98 diff --git a/src/Numeric/LAPACK/Example/DividedDifference.hs b/src/Numeric/LAPACK/Example/DividedDifference.hs --- a/src/Numeric/LAPACK/Example/DividedDifference.hs +++ b/src/Numeric/LAPACK/Example/DividedDifference.hs @@ -12,7 +12,7 @@ import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Square as Square -import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix (ShapeInt, (#+#), (#-#)) @@ -21,6 +21,7 @@ import qualified Data.Array.Comfort.Shape as Shape import qualified Data.Array.Comfort.Storable as Array +import Foreign.Storable (Storable) import qualified Data.List as List import Data.Semigroup ((<>)) @@ -30,9 +31,10 @@ >>> import qualified Test.Utility as Util >>> import Test.Utility (approxArray) >>> +>>> import qualified Numeric.LAPACK.Example.DividedDifference as DD >>> import qualified Numeric.LAPACK.Vector as Vector >>> import Numeric.LAPACK.Example.DividedDifference (dividedDifferencesMatrix) ->>> import Numeric.LAPACK.Matrix (ShapeInt, (#+#)) +>>> import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (#+#)) >>> import Numeric.LAPACK.Vector ((|+|)) >>> >>> import qualified Data.Array.Comfort.Storable as Array @@ -51,7 +53,7 @@ >>> fmap (mapPair (Vector.autoFromList, Vector.autoFromList) . >>> unzip . take 10) $ >>> QC.listOf $ liftM2 (,) (Util.genElement 10) (Util.genElement 10) ->>> xs <- Util.genDistinct 10 10 $ Array.shape ys0 +>>> xs <- Util.genDistinct [-10..10] [-10..10] $ Array.shape ys0 >>> return (xs,(ys0,ys1)) -} @@ -73,6 +75,12 @@ ys (parameterDifferences xs) +upperFromPyramid :: + (Shape.C sh, Storable a) => sh -> [Vector sh a] -> Triangular.Upper sh a +upperFromPyramid sh = + Triangular.upperFromList Layout.RowMajor sh . + concat . List.transpose . map Vector.toList + {- | prop> QC.forAll genDD $ \(xs, (ys0,ys1)) -> approxArray (dividedDifferencesMatrix xs (ys0|+|ys1)) (dividedDifferencesMatrix xs ys0 #+# dividedDifferencesMatrix xs ys1) prop> QC.forAll genDD $ \(xs, (ys0,ys1)) -> approxArray (dividedDifferencesMatrix xs (Vector.mul ys0 ys1)) (dividedDifferencesMatrix xs ys0 <> dividedDifferencesMatrix xs ys1) @@ -81,16 +89,18 @@ Vector ShapeInt Float -> Vector ShapeInt Float -> Triangular.Upper ShapeInt Float dividedDifferencesMatrix xs ys = - Triangular.upperFromList MatrixShape.RowMajor (Array.shape xs) $ - concat $ List.transpose $ map Vector.toList $ dividedDifferences xs ys + upperFromPyramid (Array.shape xs) $ dividedDifferences xs ys +{- | +prop> QC.forAll (QC.choose (0,10)) $ \n -> let sh = shapeInt n in QC.forAll (Util.genDistinct [-10..10] [-10..10] sh) $ \xs -> approxArray (DD.parameterDifferencesMatrix xs) (DD.upperFromPyramid sh (Vector.zero sh : DD.parameterDifferences xs)) +-} parameterDifferencesMatrix :: Vector ShapeInt Float -> Triangular.Upper ShapeInt Float parameterDifferencesMatrix xs = let ones = Vector.one $ Array.shape xs - tp = Matrix.tensorProduct MatrixShape.RowMajor - in Triangular.takeUpper $ Square.fromGeneral $ tp ones xs #-# tp xs ones + tp = Matrix.tensorProduct Layout.RowMajor + in Triangular.takeUpper $ Square.fromFull $ tp ones xs #-# tp xs ones main :: IO () diff --git a/src/Numeric/LAPACK/Example/EconomicAllocation.hs b/src/Numeric/LAPACK/Example/EconomicAllocation.hs --- a/src/Numeric/LAPACK/Example/EconomicAllocation.hs +++ b/src/Numeric/LAPACK/Example/EconomicAllocation.hs @@ -14,9 +14,11 @@ import Numeric.LAPACK.Format ((##)) import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) +import qualified Data.Stream as Stream + {- $setup >>> import Numeric.LAPACK.Example.EconomicAllocation >>> import Test.Utility (approxVector) @@ -28,7 +30,7 @@ -} -type ZeroInt2 = ShapeInt:+:ShapeInt +type ZeroInt2 = ShapeInt::+ShapeInt type Vector sh = Vector.Vector sh Double type Matrix height width = Matrix.General height width Double type SquareMatrix size = Square.Square size Double @@ -36,12 +38,12 @@ balances0 :: Vector ZeroInt2 balances0 = - Vector.fromList (shapeInt 2 :+: shapeInt 2) + Vector.fromList (shapeInt 2 ::+ shapeInt 2) [100000, 90000, -50000, -120000] expenses0 :: Matrix ShapeInt ZeroInt2 expenses0 = - Matrix.fromList (shapeInt 2) (shapeInt 2 :+: shapeInt 2) $ + Matrix.fromList (shapeInt 2) (shapeInt 2 ::+ shapeInt 2) $ [16000, 4000, 8000, 12000, 10000, 30000, 40000, 20000] @@ -52,15 +54,15 @@ normalizeSplit :: (Shape.C sh0, Shape.C sh1, Eq sh1) => - Matrix sh1 (sh0:+:sh1) -> (Matrix sh0 sh1, SquareMatrix sh1) + Matrix sh1 (sh0::+sh1) -> (Matrix sh0 sh1, SquareMatrix sh1) normalizeSplit expenses = let a = Matrix.transpose $ normalize expenses - in (Matrix.takeTop a, Square.fromGeneral $ Matrix.takeBottom a) + in (Matrix.takeTop a, Square.fromFull $ Matrix.takeBottom a) completeIdSquare :: (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1) => - Matrix sh1 (sh0:+:sh1) -> SquareMatrix (sh0:+:sh1) + Matrix sh1 (sh0::+sh1) -> SquareMatrix (sh0::+sh1) completeIdSquare x = let (p,k) = normalizeSplit x in (Square.identityFromHeight p, p) @@ -69,16 +71,16 @@ iterated :: (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1) => - Matrix sh1 (sh0:+:sh1) -> Vector (sh0:+:sh1) -> Vector (sh0:+:sh1) + Matrix sh1 (sh0::+sh1) -> Vector (sh0::+sh1) -> Vector (sh0::+sh1) iterated expenses = - -- 'Stream.head' would be total - head . dropWhile ((>=1e-5) . Vector.normInf . Vector.takeRight) . - iterate (completeIdSquare expenses #*|) + Stream.head . + Stream.dropWhile ((>=1e-5) . Vector.normInf . Vector.takeRight) . + Stream.iterate (completeIdSquare expenses #*|) compensated :: (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1) => - Matrix sh1 (sh0:+:sh1) -> Vector (sh0:+:sh1) -> Vector sh0 + Matrix sh1 (sh0::+sh1) -> Vector (sh0::+sh1) -> Vector sh0 compensated expenses balances = let (p,k) = normalizeSplit expenses x = Vector.takeLeft balances diff --git a/src/Numeric/LAPACK/Format.hs b/src/Numeric/LAPACK/Format.hs --- a/src/Numeric/LAPACK/Format.hs +++ b/src/Numeric/LAPACK/Format.hs @@ -1,18 +1,19 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} module Numeric.LAPACK.Format ( (##), + print, hyper, Format(format), FormatArray(formatArray), - Type.FormatMatrix(formatMatrix), + FormatMatrix(formatMatrix), ArrFormat.deflt, ) where import qualified Numeric.LAPACK.Matrix.Plain.Format as ArrFormat -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Output as Output import qualified Numeric.LAPACK.Permutation.Private as Perm +import Numeric.LAPACK.Matrix.Type (Matrix, FormatMatrix(formatMatrix)) import Numeric.LAPACK.Matrix.Plain.Format (FormatArray, formatArray, printfComplex) import Numeric.LAPACK.Output (Output, (/+/)) @@ -31,11 +32,16 @@ import Data.Complex (Complex) import Data.Char (isSpace) +import Prelude hiding (print) + infix 0 ## +print :: (Format a) => String -> a -> IO () +print fmt a = putStr $ trim $ TextBox.render $ format fmt a + (##) :: (Format a) => a -> String -> IO () -a ## fmt = putStr $ trim $ TextBox.render $ format fmt a +(##) = flip print trim :: String -> String trim = unlines . map (ListRev.dropWhile isSpace) . lines @@ -75,6 +81,8 @@ format = formatArray instance - (Type.FormatMatrix typ, Class.Floating a) => - Format (Type.Matrix typ a) where - format = Type.formatMatrix + (FormatMatrix typ, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Class.Floating a) => + Format + (Matrix typ xl xu lower upper meas vert horiz height width a) where + format = formatMatrix diff --git a/src/Numeric/LAPACK/Linear/LowerUpper.hs b/src/Numeric/LAPACK/Linear/LowerUpper.hs --- a/src/Numeric/LAPACK/Linear/LowerUpper.hs +++ b/src/Numeric/LAPACK/Linear/LowerUpper.hs @@ -1,9 +1,10 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Linear.LowerUpper ( LowerUpper, - Plain.Square, Plain.Tall, Plain.Wide, + Plain.Square, + Plain.LiberalSquare, Plain.Transposition(..), Plain.Conjugation(..), Plain.Inversion(..), @@ -34,11 +35,13 @@ import qualified Numeric.LAPACK.Linear.Plain as Plain import Numeric.LAPACK.Linear.Plain (LowerUpper) -import qualified Numeric.LAPACK.Matrix.Array.Triangular as Tri +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as Tri import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Permutation as PermMatrix import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Shape as ExtShape import Numeric.LAPACK.Matrix.Array (Full) import Numeric.LAPACK.Matrix.Modifier (Transposition, Conjugation, Inversion) @@ -57,49 +60,52 @@ > LU.multiplyP NonInverted lu $ LU.wideExtractL lu #*## LU.extractU lu -} fromMatrix :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - LowerUpper vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + LowerUpper meas vert horiz height width a fromMatrix = Plain.fromMatrix . ArrMatrix.toVector solve :: - (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq height, Shape.C height, Shape.C width, Class.Floating a) => Plain.Square height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a solve = ArrMatrix.lift1 . Plain.solve extractP :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Inversion -> LowerUpper vert horiz height width a -> + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width) => + Inversion -> LowerUpper meas vert horiz height width a -> Matrix.Permutation height a extractP inverted = PermMatrix.fromPermutation . Plain.extractP inverted multiplyP :: - (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB, - Eq height, Shape.C height, Shape.C widthA, Shape.C widthB, + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB, + Eq height, ExtShape.Permutable height, Shape.C widthA, Shape.C widthB, Class.Floating a) => Inversion -> - LowerUpper vertA horizA height widthA a -> - Full vertB horizB height widthB a -> - Full vertB horizB height widthB a + LowerUpper measA vertA horizA height widthA a -> + Full measB vertB horizB height widthB a -> + Full measB vertB horizB height widthB a multiplyP inverted = ArrMatrix.lift1 . Plain.multiplyP inverted extractL :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a -extractL = ArrMatrix.lift0 . Plain.extractL + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, ExtShape.Permutable width, Class.Floating a) => + LowerUpper meas vert horiz height width a -> + Unpacked.LowerTrapezoid meas vert horiz height width a +extractL = ArrMatrix.liftUnpacked0 . Plain.extractL wideExtractL :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - LowerUpper Extent.Small horiz height width a -> Tri.UnitLower height a + (Extent.Measure meas, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + LowerUpper meas Extent.Small horiz height width a -> Tri.UnitLower height a wideExtractL = ArrMatrix.lift0 . Plain.wideExtractL {- | @@ -110,34 +116,39 @@ > wideMultiplyL Transposed lu a == Tri.transpose (wideExtractL lu) #*## a -} wideMultiplyL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Eq height, Shape.C widthA, Shape.C widthB, Class.Floating a) => Transposition -> - LowerUpper Extent.Small horizA height widthA a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + LowerUpper measA Extent.Small horizA height widthA a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a wideMultiplyL transposed = ArrMatrix.lift1 . Plain.wideMultiplyL transposed wideSolveL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Eq height, Shape.C width, Shape.C nrhs, + Class.Floating a) => Transposition -> Conjugation -> - LowerUpper Extent.Small horizA height width a -> - Full vert horiz height nrhs a -> Full vert horiz height nrhs a + LowerUpper measA Extent.Small horizA height width a -> + Full meas vert horiz height nrhs a -> Full meas vert horiz height nrhs a wideSolveL transposed conjugated = ArrMatrix.lift1 . Plain.wideSolveL transposed conjugated extractU :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a -extractU = ArrMatrix.lift0 . Plain.extractU + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, ExtShape.Permutable width, Class.Floating a) => + LowerUpper meas vert horiz height width a -> + Unpacked.UpperTrapezoid meas vert horiz height width a +extractU = ArrMatrix.liftUnpacked0 . Plain.extractU tallExtractU :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - LowerUpper vert Extent.Small height width a -> Tri.Upper width a + (Extent.Measure meas, Extent.C vert, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + LowerUpper meas vert Extent.Small height width a -> Tri.Upper width a tallExtractU = ArrMatrix.lift0 . Plain.tallExtractU {- | @@ -148,38 +159,42 @@ > tallMultiplyU Transposed lu a == Tri.transpose (tallExtractU lu) #*## a -} tallMultiplyU :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Eq height, Shape.C heightA, Shape.C widthB, Class.Floating a) => Transposition -> - LowerUpper vertA Extent.Small heightA height a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + LowerUpper measA vertA Extent.Small heightA height a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a tallMultiplyU transposed = ArrMatrix.lift1 . Plain.tallMultiplyU transposed tallSolveU :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, ExtShape.Permutable width, Eq width, Shape.C nrhs, + Class.Floating a) => Transposition -> Conjugation -> - LowerUpper vertA Extent.Small height width a -> - Full vert horiz width nrhs a -> Full vert horiz width nrhs a + LowerUpper measA vertA Extent.Small height width a -> + Full meas vert horiz width nrhs a -> Full meas vert horiz width nrhs a tallSolveU transposed conjugated = ArrMatrix.lift1 . Plain.tallSolveU transposed conjugated toMatrix :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a + LowerUpper meas vert horiz height width a -> + Full meas vert horiz height width a toMatrix = ArrMatrix.lift0 . Plain.toMatrix multiplyFull :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - LowerUpper vert horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpper meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a multiplyFull = ArrMatrix.lift1 . Plain.multiplyFull diff --git a/src/Numeric/LAPACK/Linear/Plain.hs b/src/Numeric/LAPACK/Linear/Plain.hs --- a/src/Numeric/LAPACK/Linear/Plain.hs +++ b/src/Numeric/LAPACK/Linear/Plain.hs @@ -1,8 +1,12 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module Numeric.LAPACK.Linear.Plain ( LowerUpper, - Square, Tall, Wide, + Tall, Wide, Square, LiberalSquare, Transposition(..), Conjugation(..), Inversion(..), @@ -32,21 +36,23 @@ import qualified Numeric.LAPACK.Matrix.Divide as Divide import qualified Numeric.LAPACK.Matrix.Multiply as Multiply -import qualified Numeric.LAPACK.Matrix.Type as Type -import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Matrix.Extent as ExtentMap +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Layout as LayoutPub +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.Private as MatrixPriv import qualified Numeric.LAPACK.Permutation.Private as Perm -import qualified Numeric.LAPACK.Shape as ExtShape import qualified Numeric.LAPACK.Split as Split import Numeric.LAPACK.Output ((/+/)) import Numeric.LAPACK.Matrix.Plain.Format (formatArray) -import Numeric.LAPACK.Matrix.Type (FormatMatrix(formatMatrix)) -import Numeric.LAPACK.Matrix.Triangular.Basic (UnitLower, Upper) -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Type (Matrix, FormatMatrix(formatMatrix)) +import Numeric.LAPACK.Matrix.Triangular.Basic (Lower, Upper) +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), Triangle(Triangle)) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed, Transposed), @@ -55,6 +61,7 @@ import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Linear.Private (solver, withInfo) import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked), deconsUnchecked) import Numeric.LAPACK.Private (copyBlock, copyTransposed, copyToColumnMajor, copyToColumnMajorTemp) @@ -69,8 +76,9 @@ import Data.Array.Comfort.Storable.Unchecked (Array(Array), (!)) import Foreign.Marshal.Array (advancePtr) -import Foreign.ForeignPtr (withForeignPtr) +import Foreign.ForeignPtr (withForeignPtr, castForeignPtr) import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) @@ -79,52 +87,97 @@ import Data.Monoid ((<>)) -data LU vert horiz height width +data LU -data instance Type.Matrix (LU vert horiz height width) a = - LowerUpper { - _pivot :: - Vector (ExtShape.Min width (Perm.Shape height)) (Perm.Element height), - split_ :: - Array - (MatrixShape.Split MatrixShape.Triangle vert horiz height width) a - } deriving (Show) +data instance Matrix LU xl xu lower upper meas vert horiz height width a where + LowerUpper :: + Banded.RectangularDiagonal meas vert horiz + height width (Perm.Element height) -> + SplitArray meas vert horiz height width a -> + LowerUpperFlex lower upper meas vert horiz height width a -type LowerUpper vert horiz height width = - Type.Matrix (LU vert horiz height width) -type Square sh = LowerUpper Extent.Small Extent.Small sh sh -type Tall height width = LowerUpper Extent.Big Extent.Small height width -type Wide height width = LowerUpper Extent.Small Extent.Big height width +deriving instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Storable a, + Show height, Show width, Show a) => + Show (Matrix LU xl xu lower upper meas vert horiz height width a) -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - FormatMatrix (LU vert horiz height width) where +type SplitArray meas vert horiz height width a = + Split.Split Layout.Triangle meas vert horiz height width a + +split_ :: + Matrix LU xl xu lower upper meas vert horiz height width a -> + SplitArray meas vert horiz height width a +split_ (LowerUpper _pivot split) = split + +type LowerUpperFlex = Matrix LU () () +type LowerUpper = LowerUpperFlex Layout.Filled Layout.Filled +type Tall height width = + LowerUpper Extent.Size Extent.Big Extent.Small height width +type Wide height width = + LowerUpper Extent.Size Extent.Small Extent.Big height width +type LiberalSquare height width = SquareMeas Extent.Size height width +type Square sh = SquareMeas Extent.Shape sh sh +type SquareMeas meas height width = + LowerUpper meas Extent.Small Extent.Small height width + +instance FormatMatrix LU where formatMatrix fmt lu@(LowerUpper _ipiv m) = Perm.format (extractP NonInverted lu) /+/ formatArray fmt m + mapExtent :: (Extent.C vertA, Extent.C horizA) => (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - LowerUpper vertA horizA height width a -> - LowerUpper vertB horizB height width a + ExtentStrict.Map measA vertA horizA measB vertB horizB height width -> + LowerUpperFlex lower upper measA vertA horizA height width a -> + LowerUpperFlex lower upper measB vertB horizB height width a mapExtent f (LowerUpper pivot split) = - LowerUpper pivot $ Array.mapShape (MatrixShape.splitMapExtent f) split + let g = ExtentStrict.apply f + in LowerUpper (Banded.mapExtent g pivot) $ + Array.mapShape (Layout.splitMapExtent g) split + +mapPivotHeight :: + (sh0 -> sh1) -> + Vector shape (Perm.Element sh0) -> Vector shape (Perm.Element sh1) +mapPivotHeight _f (Array shape xs) = Array shape (castForeignPtr xs) + +mapHeight :: + (Extent.C vert, Extent.C horiz) => + (heightA -> heightB) -> + LowerUpperFlex lower upper Extent.Size vert horiz heightA width a -> + LowerUpperFlex lower upper Extent.Size vert horiz heightB width a +mapHeight f (LowerUpper pivot split) = + LowerUpper + (Banded.mapHeight f $ mapPivotHeight f pivot) + (Split.mapHeight f split) + +mapWidth :: + (Extent.C vert, Extent.C horiz) => + (widthA -> widthB) -> + LowerUpperFlex lower upper Extent.Size vert horiz height widthA a -> + LowerUpperFlex lower upper Extent.Size vert horiz height widthB a +mapWidth f (LowerUpper pivot split) = + LowerUpper + (Banded.mapWidth f pivot) + (Split.mapWidth f split) + + fromMatrix :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - LowerUpper vert horiz height width a -fromMatrix (Array (MatrixShape.Full order extent) a) = + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + LowerUpper meas vert horiz height width a +fromMatrix (Array (Layout.Full order extent) a) = let (height,width) = Extent.dimensions extent in uncurry LowerUpper $ Array.unsafeCreateWithSizeAndResult - (ExtShape.Min width $ Perm.Shape height) $ \_ ipivPtr -> + (snd $ Layout.rectangularDiagonal extent) $ \_ ipivPtr -> ArrayIO.unsafeCreate - (MatrixShape.Split MatrixShape.Triangle ColumnMajor extent) $ \luPtr -> + (Layout.Split Layout.Triangle ColumnMajor extent) $ \luPtr -> evalContT $ do let m = Shape.size height @@ -140,23 +193,25 @@ (Perm.deconsElementPtr ipivPtr) solve :: - (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq height, Shape.C height, Shape.C width, Class.Floating a) => Square height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a solve = solveTrans NonTransposed solveTrans :: - (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, - Class.Floating a) => - Transposition -> Square height a -> - Full vert horiz height width a -> - Full vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq height, Shape.C height, Shape.C width, Class.Floating a) => + Transposition -> + LowerUpperFlex lower upper + Extent.Shape Extent.Small Extent.Small height height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a solveTrans trans (LowerUpper (Array _ ipiv) - (Array (MatrixShape.Split MatrixShape.Triangle orderLU extentLU) lu)) = + (Array (Layout.Split Layout.Triangle orderLU extentLU) lu)) = solver "LowerUpper.solve" (Extent.squareSize extentLU) $ \n nPtr nrhsPtr xPtr ldxPtr -> do @@ -180,30 +235,37 @@ Caution: @LU.determinant . LU.fromMatrix@ will fail for singular matrices. -} -determinant :: (Shape.C sh, Class.Floating a) => Square sh a -> a +determinant :: + (Extent.Measure meas, Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas Extent.Small Extent.Small height width a -> a determinant (LowerUpper ipiv split) = Perm.condNegate (map Perm.deconsElement $ Array.toList ipiv) $ Split.determinantR split extractP :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Inversion -> LowerUpper vert horiz height width a -> Perm.Permutation height + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Inversion -> + LowerUpperFlex lower upper meas vert horiz height width a -> + Perm.Permutation height extractP inverted (LowerUpper ipiv _) = - Perm.fromTruncatedPivots (Inverted <> inverted) ipiv + Perm.fromTruncatedPivots (Inverted <> inverted) + (Array.mapShape Perm.Shape ipiv) multiplyP :: - (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB, + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB, Eq height, Shape.C height, Shape.C widthA, Shape.C widthB, Class.Floating a) => Inversion -> - LowerUpper vertA horizA height widthA a -> - Full vertB horizB height widthB a -> - Full vertB horizB height widthB a + LowerUpperFlex lower upper measA vertA horizA height widthA a -> + Full measB vertB horizB height widthB a -> + Full measB vertB horizB height widthB a multiplyP inverted (LowerUpper ipiv@(Array shapeIPiv ipivFPtr) - (Array (MatrixShape.Split _ _ extentLU) _lu)) - (Array shape@(MatrixShape.Full order extent) a) = + (Array (Layout.Split _ _ extentLU) _lu)) + (Array shape@(Layout.Full order extent) a) = Array.unsafeCreate shape $ \bPtr -> do Call.assert "multiplyP: heights mismatch" @@ -233,232 +295,278 @@ LapackGen.laswp nPtr bPtr ldaPtr k1Ptr k2Ptr (Perm.deconsElementPtr ipivPtr) incxPtr RowMajor -> - liftIO $ swapColumns height n bPtr ipiv $ - Perm.indices (Inverted <> inverted) shapeIPiv + liftIO $ + swapColumns + (Perm.Shape height) n bPtr (Array.mapShape Perm.Shape ipiv) $ + Perm.indices (Inverted <> inverted) (Perm.Shape shapeIPiv) {-# INLINE swapColumns #-} swapColumns :: - (Shape.C sh, Shape.C width, Class.Floating a) => - sh -> Int -> Ptr a -> - Array (ExtShape.Min width (Perm.Shape sh)) (Perm.Element sh) -> - [Perm.Element sh] -> IO () + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + (diagShape ~ Layout.RectangularDiagonal meas vert horiz height width) => + Perm.Shape height -> Int -> Ptr a -> + Array (Perm.Shape diagShape) (Perm.Element height) -> + [Perm.Element diagShape] -> IO () swapColumns sh n xPtr ipiv is = evalContT $ do nPtr <- Call.cint n incPtr <- Call.cint 1 - let columnPtr ix = - advancePtr xPtr (n * Shape.uncheckedOffset (Perm.Shape sh) ix) + let mapIx (Perm.Element i) = Perm.Element i + let columnPtr ix = advancePtr xPtr (n * Shape.uncheckedOffset sh ix) liftIO $ forM_ is $ \i -> - BlasGen.swap nPtr (columnPtr i) incPtr (columnPtr (ipiv!i)) incPtr + BlasGen.swap nPtr (columnPtr $ mapIx i) incPtr (columnPtr (ipiv!i)) incPtr extractL :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas vert horiz height width a -> + Full meas vert horiz height width a extractL = Split.extractTriangle (Left Triangle) . split_ wideExtractL :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - LowerUpper Extent.Small horiz height width a -> UnitLower height a + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas Extent.Small horiz height width a -> + Lower height a wideExtractL = Split.wideExtractL . split_ wideMultiplyL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C widthA, Shape.C widthB, Class.Floating a) => Transposition -> - LowerUpper Extent.Small horizA height widthA a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + LowerUpperFlex lower upper measA Extent.Small horizA height widthA a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a wideMultiplyL transposed = Split.wideMultiplyL transposed . split_ wideSolveL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => Transposition -> Conjugation -> - LowerUpper Extent.Small horizA height width a -> - Full vert horiz height nrhs a -> Full vert horiz height nrhs a + LowerUpperFlex lower upper measA Extent.Small horizA height width a -> + Full meas vert horiz height nrhs a -> Full meas vert horiz height nrhs a wideSolveL transposed conjugated = Split.wideSolveL transposed conjugated . split_ extractU :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas vert horiz height width a -> + Full meas vert horiz height width a extractU = Split.extractTriangle (Right Triangle) . split_ tallExtractU :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - LowerUpper vert Extent.Small height width a -> Upper width a + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas vert Extent.Small height width a -> + Upper width a tallExtractU = Split.tallExtractR . split_ tallMultiplyU :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C heightA, Shape.C widthB, Class.Floating a) => Transposition -> - LowerUpper vertA Extent.Small heightA height a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + LowerUpperFlex lower upper measA vertA Extent.Small heightA height a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a tallMultiplyU transposed = Split.tallMultiplyR transposed . split_ tallSolveU :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => Transposition -> Conjugation -> - LowerUpper vertA Extent.Small height width a -> - Full vert horiz width nrhs a -> Full vert horiz width nrhs a + LowerUpperFlex lower upper measA vertA Extent.Small height width a -> + Full meas vert horiz width nrhs a -> Full meas vert horiz width nrhs a tallSolveU transposed conjugated = Split.tallSolveR transposed conjugated . split_ toMatrix :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - LowerUpper vert horiz height width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas vert horiz height width a -> + Full meas vert horiz height width a toMatrix = getToMatrix $ - Extent.switchTagPair + ExtentPriv.switchTagTriple (ToMatrix wideToMatrix) (ToMatrix wideToMatrix) + (ToMatrix wideToMatrix) (ToMatrix tallToMatrix) (ToMatrix $ either - (Matrix.fromFull . tallToMatrix) - (Matrix.fromFull . wideToMatrix) . + (MatrixPriv.fromFull . tallToMatrix) + (MatrixPriv.fromFull . wideToMatrix) . caseTallWide) -newtype ToMatrix height width a vert horiz = +newtype ToMatrix lower upper height width a meas vert horiz = ToMatrix { getToMatrix :: - LowerUpper vert horiz height width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas vert horiz height width a -> + Full meas vert horiz height width a } tallToMatrix :: - (Extent.C vert, Shape.C height, Shape.C width, Eq height, Eq width, - Class.Floating a) => - LowerUpper vert Extent.Small height width a -> - Full vert Extent.Small height width a + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Eq height, Eq width, Class.Floating a) => + LowerUpperFlex lower upper meas vert Extent.Small height width a -> + Full meas vert Extent.Small height width a tallToMatrix a = multiplyP NonInverted a $ Basic.transpose $ tallMultiplyU Transposed a $ Basic.transpose $ extractL a wideToMatrix :: - (Extent.C horiz, Shape.C height, Shape.C width, Eq height, Eq width, - Class.Floating a) => - LowerUpper Extent.Small horiz height width a -> - Full Extent.Small horiz height width a + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Eq height, Eq width, Class.Floating a) => + LowerUpperFlex lower upper meas Extent.Small horiz height width a -> + Full meas Extent.Small horiz height width a wideToMatrix a = multiplyP NonInverted a $ wideMultiplyL NonTransposed a $ extractU a multiplyFull :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + LowerUpperFlex lower upper meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +multiplyFull a = + case Matrix.extent a of + ExtentPriv.Square _ -> multiplyFullAux a + ExtentPriv.Separate _ _ -> + Basic.mapHeight deconsUnchecked . + multiplyFullAux (mapHeight Unchecked a) + +multiplyFullAux :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - LowerUpper vert horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -multiplyFull = + LowerUpperFlex lower upper meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +multiplyFullAux = getMultiplyFullRight $ - Extent.switchTagPair + ExtentPriv.switchTagTriple {- We cannot simply use squareFull here, because this requires height~width. -} (MultiplyFullRight wideMultiplyFullRight) (MultiplyFullRight wideMultiplyFullRight) + (MultiplyFullRight wideMultiplyFullRight) (MultiplyFullRight tallMultiplyFullRight) (MultiplyFullRight $ either tallMultiplyFullRight wideMultiplyFullRight . caseTallWide) -newtype MultiplyFullRight height fuse width a vert horiz = +newtype MultiplyFullRight lower upper height fuse width a meas vert horiz = MultiplyFullRight { getMultiplyFullRight :: - LowerUpper vert horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a } tallMultiplyFullRight :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, Class.Floating a) => - LowerUpper vert Extent.Small height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas vert Extent.Small height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a tallMultiplyFullRight a = multiplyP NonInverted a . - Basic.multiply (Matrix.generalizeTall (extractL a)) . + Basic.multiply (MatrixPriv.weakenTall (extractL a)) . tallMultiplyU NonTransposed a wideMultiplyFullRight :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, Class.Floating a) => - LowerUpper Extent.Small horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas Extent.Small horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a wideMultiplyFullRight a = multiplyP NonInverted a . wideMultiplyL NonTransposed a . - Basic.multiply (Matrix.generalizeWide (extractU a)) + Basic.multiply (MatrixPriv.weakenWide (extractU a)) +transMultiplyVector :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, + Eq height, Eq width, Class.Floating a) => + LowerUpperFlex lower upper meas vert horiz height width a -> + Vector height a -> Vector width a +transMultiplyVector = + Basic.unliftColumn Layout.ColumnMajor . + either tallTransMultiplyFullRight wideTransMultiplyFullRight . caseTallWide + tallTransMultiplyFullRight :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, Class.Floating a) => - LowerUpper horiz Extent.Small fuse height a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas horiz Extent.Small fuse height a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a tallTransMultiplyFullRight a = tallMultiplyU Transposed a . - Basic.multiply (Basic.transpose $ Matrix.generalizeTall $ extractL a) . + Basic.multiply (Basic.transpose $ MatrixPriv.weakenTall $ extractL a) . multiplyP Inverted a wideTransMultiplyFullRight :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq height, Eq fuse, Class.Floating a) => - LowerUpper Extent.Small vert fuse height a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + LowerUpperFlex lower upper meas Extent.Small vert fuse height a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a wideTransMultiplyFullRight a = - Basic.multiply (Basic.transpose $ Matrix.generalizeWide $ extractU a) . + Basic.multiply (Basic.transpose $ MatrixPriv.weakenWide $ extractU a) . wideMultiplyL Transposed a . multiplyP Inverted a caseTallWide :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - LowerUpper vert horiz height width a -> + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + LowerUpperFlex lower upper meas vert horiz height width a -> Either (Tall height width a) (Wide height width a) caseTallWide (LowerUpper ipiv (Array shape a)) = - either - (Left . LowerUpper ipiv . flip Array a) - (Right . LowerUpper ipiv . flip Array a) $ - MatrixShape.caseTallWideSplit shape + let consLU ipivb b newShape = + LowerUpper + (Array.mapShape + (\bandShape -> + bandShape{Layout.bandedExtent = Layout.splitExtent newShape}) + ipivb) + (Array newShape b) + in either (Left . consLU ipiv a) (Right . consLU ipiv a) $ + Layout.caseTallWideSplit shape _toRowMajor :: - (Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, - Class.Floating a) => - LowerUpper vert horiz height width a -> - LowerUpper vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq height, Shape.C height, Shape.C width, Class.Floating a) => + LowerUpperFlex lower upper meas vert horiz height width a -> + LowerUpperFlex lower upper meas vert horiz height width a _toRowMajor (LowerUpper ipiv - arr@(Array (MatrixShape.Split MatrixShape.Triangle order extent) a)) = + arr@(Array (Layout.Split Layout.Triangle order extent) a)) = LowerUpper ipiv $ case order of RowMajor -> arr ColumnMajor -> Array.unsafeCreate - (MatrixShape.Split MatrixShape.Triangle RowMajor extent) $ \bPtr -> + (Layout.Split Layout.Triangle RowMajor extent) $ \bPtr -> withForeignPtr a $ \aPtr -> do let (height, width) = Extent.dimensions extent let n = Shape.size width @@ -466,32 +574,38 @@ copyTransposed n m aPtr n bPtr -instance - (Extent.C vert, Extent.C horiz) => - Type.Box (LU vert horiz height width) where - type HeightOf (LU vert horiz height width) = height - type WidthOf (LU vert horiz height width) = width - height = MatrixShape.splitHeight . Array.shape . split_ - width = MatrixShape.splitWidth . Array.shape . split_ +instance Matrix.Box LU where + extent = Layout.splitExtent . Array.shape . split_ -instance - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width) => - Multiply.MultiplyVector (LU vert horiz height width) where - matrixVector lu x = - Basic.unliftColumn MatrixShape.ColumnMajor - (multiplyFull (mapExtent ExtentMap.toGeneral lu)) x - vectorMatrix x lu = - Basic.unliftColumn MatrixShape.ColumnMajor - (either tallTransMultiplyFullRight wideTransMultiplyFullRight $ - caseTallWide lu) - x +instance Matrix.ToQuadratic LU where + heightToQuadratic (LowerUpper pivot split) = + LowerUpper + (Array.mapShape (layoutPivotSquare . Layout.bandedHeight) pivot) + (Split.heightToQuadratic split) + widthToQuadratic (LowerUpper pivot split) = + LowerUpper + (mapPivotHeight (const $ Layout.bandedWidth $ Array.shape pivot) $ + Array.mapShape (layoutPivotSquare . Layout.bandedWidth) pivot) + (Split.widthToQuadratic split) -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Multiply.MultiplySquare (LU vert horiz height width) where +layoutPivotSquare :: sh -> Layout.Diagonal sh +layoutPivotSquare = LayoutPub.diagonal Layout.ColumnMajor +instance (xl ~ (), xu ~ ()) => Matrix.MapExtent LU xl xu lower upper where + mapExtent = mapExtent + +instance (xl ~ (), xu ~ ()) => Multiply.MultiplyVector LU xl xu where + matrixVector lu = + Basic.unliftColumn Layout.ColumnMajor + (multiplyFull (mapExtent Extent.toGeneral lu)) + vectorMatrix = flip $ \lu -> + case Matrix.extent lu of + ExtentPriv.Square _ -> transMultiplyVector lu + ExtentPriv.Separate _ _ -> + Array.mapShape deconsUnchecked . + transMultiplyVector (mapWidth Unchecked lu) + +instance (xl ~ (), xu ~ ()) => Multiply.MultiplySquare LU xl xu where squareFull lu = ArrMatrix.lift1 $ multiplyP NonInverted lu . @@ -506,14 +620,8 @@ multiplyP Inverted lu . Basic.transpose -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Divide.Determinant (LU vert horiz height width) where +instance (xl ~ (), xu ~ ()) => Divide.Determinant LU xl xu where determinant = determinant -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Divide.Solve (LU vert horiz height width) where +instance (xl ~ (), xu ~ ()) => Divide.Solve LU xl xu where solve trans = ArrMatrix.lift1 . solveTrans trans diff --git a/src/Numeric/LAPACK/Linear/Private.hs b/src/Numeric/LAPACK/Linear/Private.hs --- a/src/Numeric/LAPACK/Linear/Private.hs +++ b/src/Numeric/LAPACK/Linear/Private.hs @@ -1,9 +1,9 @@ module Numeric.LAPACK.Linear.Private where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor)) +import Numeric.LAPACK.Matrix.Layout.Private (Order(ColumnMajor)) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Scalar (zero) import Numeric.LAPACK.Private (copyToColumnMajor, peekCInt, argMsg) @@ -27,14 +27,15 @@ solver :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq height, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq height, Class.Floating a) => String -> height -> (Int -> Ptr CInt -> Ptr CInt -> Ptr a -> Ptr CInt -> ContT () IO ()) -> - Full vert horiz height width a -> - Full vert horiz height width a -solver name sh f (Array (MatrixShape.Full order extent) b) = - Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ + Full meas vert horiz height width a -> + Full meas vert horiz height width a +solver name sh f (Array (Layout.Full order extent) b) = + Array.unsafeCreate (Layout.Full ColumnMajor extent) $ \xPtr -> do let (height,width) = Extent.dimensions extent Call.assert (name ++ ": height shapes mismatch") (sh == height) diff --git a/src/Numeric/LAPACK/Matrix.hs b/src/Numeric/LAPACK/Matrix.hs --- a/src/Numeric/LAPACK/Matrix.hs +++ b/src/Numeric/LAPACK/Matrix.hs @@ -1,31 +1,39 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Numeric.LAPACK.Matrix ( - Type.Matrix, + Matrix.Matrix, Full, - General, Tall, Wide, Square.Square, + General, Tall, Wide, Square.Square, ArrMatrix.LiberalSquare, + Matrix.Quadratic, Triangular.Triangular, Triangular.Upper, Triangular.Lower, - Triangular.Diagonal, Triangular.Symmetric, - Hermitian.Hermitian, - Permutation, + Triangular.Symmetric, + Triangular.Hermitian, + Triangular.HermitianPosDef, + Triangular.HermitianPosSemidef, + Triangular.FlexHermitian, + Banded.Diagonal, Banded.FlexDiagonal, + Banded.RectangularDiagonal, + Banded.Banded, + BandedHermitian.BandedHermitian, + PermMatrix.Permutation, ShapeInt, shapeInt, - transpose, adjoint, - Type.height, Type.width, - Type.HeightOf, Type.WidthOf, - Type.Box, Type.indices, + Matrix.Transpose, Matrix.transpose, MatrixClass.adjoint, + Matrix.height, Matrix.width, + Matrix.Box, Matrix.indices, ArrMatrix.reshape, ArrMatrix.mapShape, caseTallWide, fromScalar, toScalar, fromList, - mapExtent, fromFull, + Matrix.mapExtent, fromFull, OmniMatrix.toFull, OmniMatrix.unpack, asGeneral, asTall, asWide, tallFromGeneral, wideFromGeneral, generalizeTall, generalizeWide, - mapHeight, mapWidth, - identity, - diagonal, + MatrixClass.mapHeight, MatrixClass.mapWidth, + MatrixClass.mapSquareSize, + Quadratic.identity, + Quadratic.diagonal, fromRowsNonEmpty, fromRowArray, fromRows, fromRowsNonEmptyContainer, fromRowContainer, fromColumnsNonEmpty, fromColumnArray, fromColumns, @@ -62,8 +70,8 @@ MatrixClass.Complex, MatrixClass.conjugate, MatrixClass.fromReal, MatrixClass.toComplex, MatrixClass.SquareShape, MatrixClass.toSquare, + OmniMatrix.identityFromShape, MatrixClass.identityFrom, - MatrixClass.identityFromHeight, MatrixClass.identityFromWidth, MatrixClass.takeDiagonal, MatrixClass.trace, RealOf, @@ -73,9 +81,11 @@ scaleRowsReal, scaleColumnsReal, (\*#), (#*\), (\\#), (#/\), - multiply, - multiplyVector, + Full.multiply, + Full.multiplyVector, + Matrix.ToQuadratic, + ArrMatrix.zero, ArrMatrix.negate, ArrMatrix.scale, ArrMatrix.scaleReal, ArrMatrix.scaleRealReal, (ArrMatrix..*#), @@ -84,7 +94,8 @@ Multiply.Multiply, (Multiply.#*#), Multiply.MultiplyVector, (Multiply.#*|), (Multiply.-*#), Multiply.MultiplySquare, multiplySquare, - Multiply.Power, Multiply.square, Multiply.power, + Multiply.Power, Multiply.square, + Multiply.power, Multiply.powers, Multiply.powers1, (Multiply.##*#), (Multiply.#*##), Indexed.Indexed, (Indexed.#!), @@ -97,23 +108,29 @@ ) where import qualified Numeric.LAPACK.Matrix.Permutation as PermMatrix -import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as Triangular +import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Quadratic as Quadratic import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Full as Full import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Type as Matrix import qualified Numeric.LAPACK.Matrix.Plain as Plain import qualified Numeric.LAPACK.Matrix.Modifier as Mod import qualified Numeric.LAPACK.Matrix.Divide as Divide import qualified Numeric.LAPACK.Matrix.Multiply as Multiply +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Indexed as Indexed import qualified Numeric.LAPACK.Matrix.Class as MatrixClass -import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Private as MatrixPriv import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Shape.Private (Order) +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Layout.Private (Order) import Numeric.LAPACK.Matrix.Array (Full, General, Tall, Wide) import Numeric.LAPACK.Matrix.Private (ShapeInt, shapeInt) import Numeric.LAPACK.Vector (Vector) @@ -126,28 +143,20 @@ import qualified Data.Array.Comfort.Container as Container import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array, (!)) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) import qualified Data.NonEmpty as NonEmpty import qualified Data.Either.HT as EitherHT +import Data.Function.HT (Id) import Prelude hiding (map) -type Permutation sh = Type.Matrix (PermMatrix.Permutation sh) - -mapExtent :: - (Extent.C vertA, Extent.C horizA) => - (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - Full vertA horizA height width a -> Full vertB horizB height width a -mapExtent = ArrMatrix.lift1 . Plain.mapExtent - fromFull :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> General height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> General height width a fromFull = ArrMatrix.lift1 Plain.fromFull tallFromGeneral :: @@ -161,23 +170,25 @@ wideFromGeneral = ArrMatrix.lift1 Plain.wideFromGeneral generalizeTall :: - (Extent.C vert, Extent.C horiz) => - Full vert Extent.Small height width a -> Full vert horiz height width a -generalizeTall = mapExtent Extent.generalizeTall + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert Extent.Small height width a -> + Full Extent.Size vert horiz height width a +generalizeTall = Full.mapExtent Extent.generalizeTall generalizeWide :: - (Extent.C vert, Extent.C horiz) => - Full Extent.Small horiz height width a -> Full vert horiz height width a -generalizeWide = mapExtent Extent.generalizeWide + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas Extent.Small horiz height width a -> + Full Extent.Size vert horiz height width a +generalizeWide = Full.mapExtent Extent.generalizeWide -asGeneral :: General height width a -> General height width a +asGeneral :: Id (General height width a) asGeneral = id -asTall :: Tall height width a -> Tall height width a +asTall :: Id (Tall height width a) asTall = id -asWide :: Wide height width a -> Wide height width a +asWide :: Id (Wide height width a) asWide = id @@ -186,7 +197,8 @@ fromScalar = fromFull . Square.fromScalar toScalar :: (Storable a) => General () () a -> a -toScalar a = either id id (Matrix.revealOrder (ArrMatrix.toVector a)) ! ((),()) +toScalar a = + either id id (MatrixPriv.revealOrder (ArrMatrix.toVector a)) ! ((),()) fromList :: (Shape.C height, Shape.C width, Storable a) => @@ -194,73 +206,19 @@ fromList height width = ArrMatrix.lift0 . Plain.fromList height width -identity :: - (Shape.C sh, Class.Floating a) => - sh -> General sh sh a -identity = ArrMatrix.lift0 . Plain.identity - -diagonal :: - (Shape.C sh, Class.Floating a) => - Vector sh a -> General sh sh a -diagonal = ArrMatrix.lift0 . Plain.diagonal - - {- | Square matrices will be classified as 'Tall'. -} caseTallWide :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Full vert horiz height width a -> + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width a -> Either (Tall height width a) (Wide height width a) caseTallWide = EitherHT.mapBoth ArrMatrix.lift0 ArrMatrix.lift0 . Basic.caseTallWide . ArrMatrix.toVector -transpose :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> Full horiz vert width height a -transpose = ArrMatrix.lift1 Basic.transpose - -{- | -conjugate transpose - -Problem: @adjoint a \<\> a@ is always square, -but how to convince the type checker to choose the Square type? -Anser: Use @Hermitian.toSquare $ Hermitian.gramian a@ instead. --} -adjoint :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> Full horiz vert width height a -adjoint = ArrMatrix.lift1 Basic.adjoint - - -{- | -The number of rows must be maintained by the height mapping function. --} -mapHeight :: - (Shape.C heightA, Shape.C heightB, - Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => - (heightA -> heightB) -> - Full vert horiz heightA width a -> - Full vert horiz heightB width a -mapHeight = ArrMatrix.lift1 . Plain.mapHeight - -{- | -The number of columns must be maintained by the width mapping function. --} -mapWidth :: - (Shape.C widthA, Shape.C widthB, - Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => - (widthA -> widthB) -> - Full vert horiz height widthA a -> - Full vert horiz height widthB a -mapWidth = ArrMatrix.lift1 . Plain.mapWidth - - singleRow :: Order -> Vector width a -> General () width a singleRow order = ArrMatrix.lift0 . Basic.singleRow order @@ -355,39 +313,41 @@ toRows :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> [Vector width a] + Full meas vert horiz height width a -> [Vector width a] toRows = Plain.toRows . ArrMatrix.toVector toColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> [Vector height a] + Full meas vert horiz height width a -> [Vector height a] toColumns = Plain.toColumns . ArrMatrix.toVector toRowArray :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> BoxedArray.Array height (Vector width a) + Full meas vert horiz height width a -> + BoxedArray.Array height (Vector width a) toRowArray = Plain.toRowArray . ArrMatrix.toVector toColumnArray :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> BoxedArray.Array width (Vector height a) + Full meas vert horiz height width a -> + BoxedArray.Array width (Vector height a) toColumnArray = Plain.toColumnArray . ArrMatrix.toVector toRowContainer :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Container.C f, Shape.C width, Class.Floating a) => - Full vert horiz (Container.Shape f) width a -> f (Vector width a) + Full meas vert horiz (Container.Shape f) width a -> f (Vector width a) toRowContainer = Plain.toRowContainer . ArrMatrix.toVector toColumnContainer :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Container.C f, Class.Floating a) => - Full vert horiz height (Container.Shape f) a -> f (Vector height a) + Full meas vert horiz height (Container.Shape f) a -> f (Vector height a) toColumnContainer = Plain.toColumnContainer . ArrMatrix.toVector @@ -397,61 +357,61 @@ but it is the order that is used most oftenly. -} takeRow :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.C width, Shape.Index height ~ ix, Class.Floating a) => - Full vert horiz height width a -> ix -> Vector width a + Full meas vert horiz height width a -> ix -> Vector width a takeRow = Plain.takeRow . ArrMatrix.toVector takeColumn :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.Indexed width, Shape.Index width ~ ix, Class.Floating a) => - Full vert horiz height width a -> ix -> Vector height a + Full meas vert horiz height width a -> ix -> Vector height a takeColumn = Plain.takeColumn . ArrMatrix.toVector takeTop :: (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, Class.Floating a) => - Full vert Extent.Big (height0:+:height1) width a -> - Full vert Extent.Big height0 width a + Full Extent.Size vert Extent.Big (height0::+height1) width a -> + Full Extent.Size vert Extent.Big height0 width a takeTop = ArrMatrix.lift1 Basic.takeTop takeBottom :: (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, Class.Floating a) => - Full vert Extent.Big (height0:+:height1) width a -> - Full vert Extent.Big height1 width a + Full Extent.Size vert Extent.Big (height0::+height1) width a -> + Full Extent.Size vert Extent.Big height1 width a takeBottom = ArrMatrix.lift1 Basic.takeBottom takeLeft :: (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, Class.Floating a) => - Full Extent.Big vert height (width0:+:width1) a -> - Full Extent.Big vert height width0 a + Full Extent.Size Extent.Big vert height (width0::+width1) a -> + Full Extent.Size Extent.Big vert height width0 a takeLeft = ArrMatrix.lift1 Basic.takeLeft takeRight :: (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, Class.Floating a) => - Full Extent.Big vert height (width0:+:width1) a -> - Full Extent.Big vert height width1 a + Full Extent.Size Extent.Big vert height (width0::+width1) a -> + Full Extent.Size Extent.Big vert height width1 a takeRight = ArrMatrix.lift1 Basic.takeRight takeRows, dropRows :: (Extent.C vert, Shape.C width, Class.Floating a) => Int -> - Full vert Extent.Big ShapeInt width a -> - Full vert Extent.Big ShapeInt width a + Full Extent.Size vert Extent.Big ShapeInt width a -> + Full Extent.Size vert Extent.Big ShapeInt width a takeRows = ArrMatrix.lift1 . Basic.takeRows dropRows = ArrMatrix.lift1 . Basic.dropRows takeColumns, dropColumns :: (Extent.C horiz, Shape.C height, Class.Floating a) => Int -> - Full Extent.Big horiz height ShapeInt a -> - Full Extent.Big horiz height ShapeInt a + Full Extent.Size Extent.Big horiz height ShapeInt a -> + Full Extent.Size Extent.Big horiz height ShapeInt a takeColumns = ArrMatrix.lift1 . Basic.takeColumns dropColumns = ArrMatrix.lift1 . Basic.dropColumns @@ -462,10 +422,10 @@ e.g. Square remains Square, Tall remains Tall. -} takeEqually :: - (Extent.C vert, Extent.C horiz, Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Class.Floating a) => Int -> - Full vert horiz ShapeInt ShapeInt a -> - Full vert horiz ShapeInt ShapeInt a + Full meas vert horiz ShapeInt ShapeInt a -> + Full meas vert horiz ShapeInt ShapeInt a takeEqually = ArrMatrix.lift1 . Plain.takeEqually {- | @@ -474,36 +434,40 @@ e.g. Square remains Square, Tall remains Tall. -} dropEqually :: - (Extent.C vert, Extent.C horiz, Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Class.Floating a) => Int -> - Full vert horiz ShapeInt ShapeInt a -> - Full vert horiz ShapeInt ShapeInt a + Full meas vert horiz ShapeInt ShapeInt a -> + Full meas vert horiz ShapeInt ShapeInt a dropEqually = ArrMatrix.lift1 . Plain.dropEqually swapRows :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.C width, Class.Floating a) => Shape.Index height -> Shape.Index height -> - Full vert horiz height width a -> Full vert horiz height width a + Full meas vert horiz height width a -> Full meas vert horiz height width a swapRows i j = ArrMatrix.lift1 $ Plain.swapRows i j swapColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.Indexed width, Class.Floating a) => Shape.Index width -> Shape.Index width -> - Full vert horiz height width a -> Full vert horiz height width a + Full meas vert horiz height width a -> Full meas vert horiz height width a swapColumns i j = ArrMatrix.lift1 $ Plain.swapColumns i j reverseRows :: - (Extent.C vert, Extent.C horiz, Shape.C width, Class.Floating a) => - Full vert horiz ShapeInt width a -> Full vert horiz ShapeInt width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + Full meas vert horiz height width a reverseRows = ArrMatrix.lift1 Plain.reverseRows reverseColumns :: - (Extent.C vert, Extent.C horiz, Shape.C height, Class.Floating a) => - Full vert horiz height ShapeInt a -> Full vert horiz height ShapeInt a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + Full meas vert horiz height width a -> + Full meas vert horiz height width a reverseColumns = ArrMatrix.lift1 Plain.reverseColumns @@ -532,9 +496,9 @@ fromRowMajor = ArrMatrix.lift0 . Plain.fromRowMajor toRowMajor :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Array (height,width) a + Full meas vert horiz height width a -> Array (height,width) a toRowMajor = Plain.toRowMajor . ArrMatrix.toVector @@ -546,9 +510,9 @@ Extent.Append vertA vertB ~ vertC, Shape.C height, Eq height, Shape.C widthA, Shape.C widthB, Class.Floating a) => - Full vertA Extent.Big height widthA a -> - Full vertB Extent.Big height widthB a -> - Full vertC Extent.Big height (widthA:+:widthB) a + Full Extent.Size vertA Extent.Big height widthA a -> + Full Extent.Size vertB Extent.Big height widthB a -> + Full Extent.Size vertC Extent.Big height (widthA::+widthB) a (|||) = beside rightBias Extent.appendAny (===) :: @@ -556,9 +520,9 @@ Extent.Append horizA horizB ~ horizC, Shape.C width, Eq width, Shape.C heightA, Shape.C heightB, Class.Floating a) => - Full Extent.Big horizA heightA width a -> - Full Extent.Big horizB heightB width a -> - Full Extent.Big horizC (heightA:+:heightB) width a + Full Extent.Size Extent.Big horizA heightA width a -> + Full Extent.Size Extent.Big horizB heightB width a -> + Full Extent.Size Extent.Big horizC (heightA::+heightB) width a (===) = above rightBias Extent.appendAny beside :: @@ -567,9 +531,9 @@ Class.Floating a) => Basic.OrderBias -> Extent.AppendMode vertA vertB vertC height widthA widthB -> - Full vertA Extent.Big height widthA a -> - Full vertB Extent.Big height widthB a -> - Full vertC Extent.Big height (widthA:+:widthB) a + Full Extent.Size vertA Extent.Big height widthA a -> + Full Extent.Size vertB Extent.Big height widthB a -> + Full Extent.Size vertC Extent.Big height (widthA::+widthB) a beside orderBias = ArrMatrix.lift2 . Basic.beside orderBias above :: @@ -578,9 +542,9 @@ Class.Floating a) => Basic.OrderBias -> Extent.AppendMode horizA horizB horizC width heightA heightB -> - Full Extent.Big horizA heightA width a -> - Full Extent.Big horizB heightB width a -> - Full Extent.Big horizC (heightA:+:heightB) width a + Full Extent.Size Extent.Big horizA heightA width a -> + Full Extent.Size Extent.Big horizB heightB width a -> + Full Extent.Size Extent.Big horizC (heightA::+heightB) width a above orderBias = ArrMatrix.lift2 . Basic.above orderBias {- | @@ -607,50 +571,50 @@ stack :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Eq heightA, Shape.C heightB, Eq heightB, Shape.C widthA, Eq widthA, Shape.C widthB, Eq widthB, Class.Floating a) => - Full vert horiz heightA widthA a -> General heightA widthB a -> - General heightB widthA a -> Full vert horiz heightB widthB a -> - Full vert horiz (heightA:+:heightB) (widthA:+:widthB) a + Full meas vert horiz heightA widthA a -> General heightA widthB a -> + General heightB widthA a -> Full meas vert horiz heightB widthB a -> + Full meas vert horiz (heightA::+heightB) (widthA::+widthB) a stack = ArrMatrix.lift4 Basic.stack rowSums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Vector height a + Full meas vert horiz height width a -> Vector height a rowSums = Plain.rowSums . ArrMatrix.toVector columnSums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Vector width a + Full meas vert horiz height width a -> Vector width a columnSums = Plain.columnSums . ArrMatrix.toVector rowArgAbsMaximums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.InvIndexed width, Shape.Index width ~ ix, Storable ix, Class.Floating a) => - Full vert horiz height width a -> (Vector height ix, Vector height a) + Full meas vert horiz height width a -> (Vector height ix, Vector height a) rowArgAbsMaximums = Plain.rowArgAbsMaximums . ArrMatrix.toVector columnArgAbsMaximums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.InvIndexed height, Shape.C width, Shape.Index height ~ ix, Storable ix, Class.Floating a) => - Full vert horiz height width a -> (Vector width ix, Vector width a) + Full meas vert horiz height width a -> (Vector width ix, Vector width a) columnArgAbsMaximums = Plain.columnArgAbsMaximums . ArrMatrix.toVector map :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Storable a, Storable b) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Storable a, Storable b) => (a -> b) -> - Full vert horiz height width a -> Full vert horiz height width b + Full meas vert horiz height width a -> Full meas vert horiz height width b map = ArrMatrix.lift1 . Array.map @@ -678,12 +642,12 @@ outer order x y = ArrMatrix.lift0 $ Plain.outer order x y kronecker :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Shape.C widthA, Shape.C heightB, Shape.C widthB, Class.Floating a) => - Full vert horiz heightA widthA a -> - Full vert horiz heightB widthB a -> - Full vert horiz (heightA,heightB) (widthA,widthB) a + Full meas vert horiz heightA widthA a -> + Full meas vert horiz heightB widthB a -> + Full meas vert horiz (heightA,heightB) (widthA,widthB) a kronecker = ArrMatrix.lift2 Plain.kronecker sumRank1 :: @@ -697,84 +661,69 @@ infixr 7 \*#, \\# scaleRows, (\*#) :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Vector height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleRows = ArrMatrix.lift1 . Basic.scaleRows (\*#) = scaleRows scaleColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => Vector width a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleColumns = ArrMatrix.lift1 . Basic.scaleColumns (#*\) :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> + Full meas vert horiz height width a -> Vector width a -> - Full vert horiz height width a + Full meas vert horiz height width a (#*\) = flip scaleColumns scaleRowsReal :: - (Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => Vector height (RealOf a) -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleRowsReal = ArrMatrix.lift1 . Basic.scaleRowsReal scaleColumnsReal :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => Vector width (RealOf a) -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleColumnsReal = ArrMatrix.lift1 . Basic.scaleColumnsReal (\\#) :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Vector height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a (\\#) = scaleRows . Vector.recip (#/\) :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> + Full meas vert horiz height width a -> Vector width a -> - Full vert horiz height width a + Full meas vert horiz height width a (#/\) a x = scaleColumns (Vector.recip x) a multiplySquare :: - (Multiply.MultiplySquare typ, - Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Mod.Transposition -> Type.Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a + (Multiply.MultiplySquare typ xl xu) => + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Mod.Transposition -> + Matrix.Quadratic typ xl xu lower upper height a -> + Full meas vert horiz height width a -> Full meas vert horiz height width a multiplySquare = Multiply.transposableSquare - -multiplyVector :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, - Class.Floating a) => - Full vert horiz height width a -> Vector width a -> Vector height a -multiplyVector = Basic.multiplyVector . ArrMatrix.toVector - -multiply :: - (Extent.C vert, Extent.C horiz, - Shape.C height, - Shape.C fuse, Eq fuse, - Shape.C width, - Class.Floating a) => - Full vert horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -multiply = ArrMatrix.lift2 Basic.multiply diff --git a/src/Numeric/LAPACK/Matrix/Array.hs b/src/Numeric/LAPACK/Matrix/Array.hs --- a/src/Numeric/LAPACK/Matrix/Array.hs +++ b/src/Numeric/LAPACK/Matrix/Array.hs @@ -1,20 +1,42 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} module Numeric.LAPACK.Matrix.Array ( Matrix(Array), ArrayMatrix, Array, + OmniArray, + PlainArray, Full, General, Tall, Wide, + LiberalSquare, Square, + SquareMeas, + Quadratic, + FullQuadratic, + QuadraticMeas, + plainShape, shape, + extent, + subBandsSingleton, + superBandsSingleton, + packTag, + diagTag, + + asPacked, + asUnpacked, + requirePacking, + reshape, mapShape, + unwrap, toVector, fromVector, lift0, @@ -26,33 +48,48 @@ unlift2, unliftRow, unliftColumn, + unpackedToVector, + liftUnpacked0, + liftUnpacked1, + liftUnpacked2, + liftUnpacked3, + liftOmni1, + liftOmni2, - Plain.Homogeneous, zero, negate, scaleReal, scale, scaleRealReal, (.*#), - Plain.ShapeOrder, forceOrder, Plain.shapeOrder, adaptOrder, - Plain.Additive, add, sub, (#+#), (#-#), - Plain.Complex, - Plain.SquareShape, - Multiply.MultiplyVector, - Multiply.MultiplySquare, - Multiply.Power, - Multiply.Multiply, - Divide.Determinant, - Divide.Solve, - Divide.Inverse, + Homogeneous, Scale, zero, negate, scaleReal, scale, scaleRealReal, (.*#), + order, forceOrder, adaptOrder, + Additive, add, (#+#), + Subtractive, sub, (#-#), + + MapExtent, mapExtent, ) where -import qualified Numeric.LAPACK.Matrix.Plain.Divide as Divide -import qualified Numeric.LAPACK.Matrix.Plain.Multiply as Multiply -import qualified Numeric.LAPACK.Matrix.Plain.Class as Plain -import qualified Numeric.LAPACK.Matrix.Type as Type -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box +import qualified Numeric.LAPACK.Matrix.Plain.Class as ArrClass +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Plain as Plain import qualified Numeric.LAPACK.Matrix.Basic as Basic -import Numeric.LAPACK.Matrix.Plain.Format (FormatArray, formatArray) +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Plain.Format (formatArray) +import Numeric.LAPACK.Matrix.Shape.Omni (Omni, Arbitrary) +import Numeric.LAPACK.Matrix.Layout.Private (Filled, Bands, Packed, Unpacked) +import Numeric.LAPACK.Matrix.Extent.Private (Extent, Shape, Size, Big, Small) import Numeric.LAPACK.Matrix.Type (Matrix) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) +import qualified Type.Data.Num.Unary as Unary +import qualified Type.Data.Bool as TBool +import Type.Data.Bool (True) + import qualified Numeric.Netlib.Class as Class import qualified Control.DeepSeq as DeepSeq @@ -60,186 +97,590 @@ import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape +import Data.Function.HT (Id) +import Foreign.Storable (Storable) + import Prelude hiding (negate) -data Array shape -newtype instance Matrix (Array shape) a = Array (Array.Array shape a) - deriving (Show) +type OmniArray pack prop lower upper meas vert horiz height width a = + Array.Array (Omni pack prop lower upper meas vert horiz height width) a -type ArrayMatrix shape = Matrix (Array shape) +data Array pack property +data instance + Matrix (Array pack prop) xl xu + lower upper meas vert horiz height width a where + Array :: + OmniArray pack prop lower upper meas vert horiz height width a -> + Matrix (Array pack prop) () () lower upper meas vert horiz height width a +deriving instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Storable a, + Show height, Show width, Show a) => + Show (Matrix (Array pack prop) xl xu + lower upper meas vert horiz height width a) -type Full vert horiz height width = - ArrayMatrix (MatrixShape.Full vert horiz height width) -type General height width = ArrayMatrix (MatrixShape.General height width) -type Tall height width = ArrayMatrix (MatrixShape.Tall height width) -type Wide height width = ArrayMatrix (MatrixShape.Wide height width) -type Square sh = ArrayMatrix (MatrixShape.Square sh) +type ArrayMatrix pack property = Matrix (Array pack property) () () +type UnpackedMatrix property = ArrayMatrix Unpacked property -instance (DeepSeq.NFData shape) => Type.NFData (Array shape) where +type Full meas vert horiz height width = + UnpackedMatrix Arbitrary Filled Filled meas vert horiz height width +type General height width = Full Size Big Big height width +type Tall height width = Full Size Big Small height width +type Wide height width = Full Size Small Big height width +type LiberalSquare height width = SquareMeas Size height width +type Square sh = SquareMeas Shape sh sh +type SquareMeas meas height width = Full meas Small Small height width + +type Quadratic pack property lower upper sh = + QuadraticMeas pack property lower upper Shape sh sh +type FullQuadratic pack property sh = Quadratic pack property Filled Filled sh + +type QuadraticMeas pack property lower upper meas height width = + ArrayMatrix pack property lower upper meas Small Small height width + + +instance Matrix.NFData (Array pack property) where rnf (Array arr) = DeepSeq.rnf arr -instance (Box.Box sh) => Type.Box (Array sh) where - type HeightOf (Array sh) = Box.HeightOf sh - type WidthOf (Array sh) = Box.WidthOf sh - height (Array arr) = Box.height $ Array.shape arr - width (Array arr) = Box.width $ Array.shape arr +instance Matrix.Box (Array pack property) where + extent (Array arr) = Omni.extent $ Array.shape arr +instance Matrix.Transpose (Array pack property) where + transpose a@(Array _) = + case shape a of + Omni.Full _ -> liftUnpacked1 Basic.transpose a + Omni.UpperTriangular _ -> lift1 Mosaic.transpose a + Omni.LowerTriangular _ -> lift1 Mosaic.transpose a + Omni.Symmetric _ -> a + Omni.Hermitian _ -> lift1 Vector.conjugate a + Omni.Banded _ -> lift1 Banded.transpose a + Omni.UnitBandedTriangular _ -> lift1 Banded.transpose a + Omni.BandedHermitian _ -> lift1 Vector.conjugate a -shape :: ArrayMatrix sh a -> sh + +asPacked :: + Id (ArrayMatrix Packed property lower upper meas vert horiz height width a) +asPacked = id + +asUnpacked :: + Id (ArrayMatrix Unpacked property lower upper meas vert horiz height width a) +asUnpacked = id + +requirePacking :: + Layout.PackingSingleton pack -> + Id (ArrayMatrix pack property lower upper meas vert horiz height width a) +requirePacking _ = id + + +plainShape :: + (Omni.ToPlain pack property lower upper meas vert horiz height width) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Omni.Plain pack property lower upper meas vert horiz height width +plainShape = Omni.toPlain . shape + +shape :: + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Omni pack property lower upper meas vert horiz height width shape (Array a) = Array.shape a +extent :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Extent meas vert horiz height width +extent = Omni.extent . shape + + +subBandsSingleton :: + (Unary.Natural sub) => + ArrayMatrix pack property + (Layout.Bands sub) upper meas vert horiz height width a -> + Unary.HeadSingleton sub +subBandsSingleton _ = Unary.headSingleton + +superBandsSingleton :: + (Unary.Natural super) => + ArrayMatrix pack property + lower (Layout.Bands super) meas vert horiz height width a -> + Unary.HeadSingleton super +superBandsSingleton _ = Unary.headSingleton + + reshape :: - (Shape.C sh0, Shape.C sh1) => - sh1 -> ArrayMatrix sh0 a -> ArrayMatrix sh1 a -reshape = lift1 . CheckedArray.reshape + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C heightA, Shape.C widthA) => + (Shape.C heightB, Shape.C widthB) => + Omni packB propB lowerB upperB measB vertB horizB heightB widthB -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB a +reshape = liftOmni1 . CheckedArray.reshape mapShape :: - (Shape.C sh0, Shape.C sh1) => - (sh0 -> sh1) -> ArrayMatrix sh0 a -> ArrayMatrix sh1 a -mapShape = lift1 . CheckedArray.mapShape + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C heightA, Shape.C widthA) => + (Shape.C heightB, Shape.C widthB) => + (Omni packA propA lowerA upperA measA vertA horizA heightA widthA -> + Omni packB propB lowerB upperB measB vertB horizB heightB widthB) -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB a +mapShape = liftOmni1 . CheckedArray.mapShape -toVector :: ArrayMatrix sh a -> Array.Array sh a -toVector (Array a) = a +type PlainArray pack prop lower upper meas vert horiz height width = + Array.Array (Omni.Plain pack prop lower upper meas vert horiz height width) +toVector :: + (Omni.ToPlain pack property lower upper meas vert horiz height width) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + PlainArray pack property lower upper meas vert horiz height width a +toVector (Array a) = Array.mapShape Omni.toPlain a + +unwrap :: + ArrayMatrix pack property lower upper meas vert horiz height width a -> + OmniArray pack property lower upper meas vert horiz height width a +unwrap (Array a) = a + fromVector :: - (Plain.Admissible sh, Class.Floating a) => - Array.Array sh a -> ArrayMatrix sh a + (Omni.FromPlain pack prop lower upper meas vert horiz height width) => + (Omni.Plain pack prop lower upper meas vert horiz height width ~ shape) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Array.Array shape a -> + ArrayMatrix pack prop lower upper meas vert horiz height width a fromVector arr = - Array $ - case Plain.check arr of - Nothing -> arr - Just msg -> error $ "Matrix.Array.fromVector: " ++ msg + let omni = Omni.fromPlain $ Array.shape arr + in case ArrClass.check omni arr of + Nothing -> Array $ Array.reshape omni arr + Just msg -> error $ "Matrix.Array.fromVector: " ++ msg + {- | 'lift0' is a synonym for 'fromVector' but lacks the admissibility check. You may thus fool the type tags. This applies to the other lift functions, too. -} -lift0 :: Array.Array shA a -> ArrayMatrix shA a -lift0 = Array +lift0 :: + (Omni.FromPlain pack prop lower upper meas vert horiz height width) => + PlainArray pack prop lower upper meas vert horiz height width a -> + ArrayMatrix pack prop lower upper meas vert horiz height width a +lift0 = Array . Array.mapShape Omni.fromPlain lift1 :: - (Array.Array shA a -> Array.Array shB b) -> - ArrayMatrix shA a -> ArrayMatrix shB b -lift1 f (Array a) = Array $ f a + (Omni.ToPlain packA propA lowerA upperA measA vertA horizA heightA widthA) => + (Omni.FromPlain packB propB lowerB upperB measB vertB horizB heightB widthB) + => + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b) -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b +lift1 f = lift0 . f . toVector lift2 :: - (Array.Array shA a -> Array.Array shB b -> Array.Array shC c) -> - ArrayMatrix shA a -> ArrayMatrix shB b -> ArrayMatrix shC c -lift2 f (Array a) (Array b) = Array $ f a b + (Omni.ToPlain packA propA lowerA upperA measA vertA horizA heightA widthA) => + (Omni.ToPlain packB propB lowerB upperB measB vertB horizB heightB widthB) => + (Omni.FromPlain packC propC lowerC upperC measC vertC horizC heightC widthC) + => + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b -> + PlainArray packC propC lowerC upperC measC vertC horizC heightC widthC c) -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b -> + ArrayMatrix packC propC lowerC upperC measC vertC horizC heightC widthC c +lift2 f = lift1 . f . toVector lift3 :: - (Array.Array shA a -> Array.Array shB b -> - Array.Array shC c -> Array.Array shD d) -> - ArrayMatrix shA a -> ArrayMatrix shB b -> - ArrayMatrix shC c -> ArrayMatrix shD d -lift3 f (Array a) (Array b) (Array c) = Array $ f a b c + (Omni.ToPlain packA propA lowerA upperA measA vertA horizA heightA widthA) => + (Omni.ToPlain packB propB lowerB upperB measB vertB horizB heightB widthB) => + (Omni.ToPlain packC propC lowerC upperC measC vertC horizC heightC widthC) => + (Omni.FromPlain packD propD lowerD upperD measD vertD horizD heightD widthD) + => + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b -> + PlainArray packC propC lowerC upperC measC vertC horizC heightC widthC c -> + PlainArray packD propD lowerD upperD measD vertD horizD heightD widthD d) -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b -> + ArrayMatrix packC propC lowerC upperC measC vertC horizC heightC widthC c -> + ArrayMatrix packD propD lowerD upperD measD vertD horizD heightD widthD d +lift3 f = lift2 . f . toVector lift4 :: - (Array.Array shA a -> Array.Array shB b -> - Array.Array shC c -> Array.Array shD d -> - Array.Array shE e) -> - ArrayMatrix shA a -> ArrayMatrix shB b -> - ArrayMatrix shC c -> ArrayMatrix shD d -> - ArrayMatrix shE e -lift4 f (Array a) (Array b) (Array c) (Array d) = Array $ f a b c d + (Omni.ToPlain packA propA lowerA upperA measA vertA horizA heightA widthA) => + (Omni.ToPlain packB propB lowerB upperB measB vertB horizB heightB widthB) => + (Omni.ToPlain packC propC lowerC upperC measC vertC horizC heightC widthC) => + (Omni.ToPlain packD propD lowerD upperD measD vertD horizD heightD widthD) => + (Omni.FromPlain packE propE lowerE upperE measE vertE horizE heightE widthE) + => + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b -> + PlainArray packC propC lowerC upperC measC vertC horizC heightC widthC c -> + PlainArray packD propD lowerD upperD measD vertD horizD heightD widthD d -> + PlainArray packE propE lowerE upperE measE vertE horizE heightE widthE e) -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b -> + ArrayMatrix packC propC lowerC upperC measC vertC horizC heightC widthC c -> + ArrayMatrix packD propD lowerD upperD measD vertD horizD heightD widthD d -> + ArrayMatrix packE propE lowerE upperE measE vertE horizE heightE widthE e +lift4 f = lift3 . f . toVector unlift1 :: - (ArrayMatrix shA a -> ArrayMatrix shB b) -> - Array.Array shA a -> Array.Array shB b -unlift1 f a = toVector $ f $ Array a + (Omni.FromPlain packA propA lowerA upperA measA vertA horizA heightA widthA) + => + (Omni.ToPlain packB propB lowerB upperB measB vertB horizB heightB widthB) => + (ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b) -> + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b) +unlift1 f = toVector . f . lift0 unlift2 :: - (ArrayMatrix shA a -> ArrayMatrix shB b -> ArrayMatrix shC c) -> - Array.Array shA a -> Array.Array shB b -> Array.Array shC c -unlift2 f a b = toVector $ f (Array a) (Array b) + (Omni.FromPlain packA propA lowerA upperA measA vertA horizA heightA widthA, + Omni.FromPlain packB propB lowerB upperB measB vertB horizB heightB widthB) + => + (Omni.ToPlain packC propC lowerC upperC measC vertC horizC heightC widthC) => + (ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b -> + ArrayMatrix packC propC lowerC upperC measC vertC horizC heightC widthC c) -> + (PlainArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + PlainArray packB propB lowerB upperB measB vertB horizB heightB widthB b -> + PlainArray packC propC lowerC upperC measC vertC horizC heightC widthC c) +unlift2 f = unlift1 . f . lift0 +type FullArray meas vert horiz height width = + Array.Array (Layout.Full meas vert horiz height width) + +unpackedToVector :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + UnpackedMatrix property lower upper meas vert horiz height width a -> + FullArray meas vert horiz height width a +unpackedToVector = Array.mapShape Omni.toFull . unwrap + +liftUnpacked0 :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (FullArray measA vertA horizA heightA widthA a) -> + UnpackedMatrix propertyA lowerA upperA measA vertA horizA heightA widthA a +liftUnpacked0 = Array . Array.mapShape Omni.fromFull + +liftUnpacked1 :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (FullArray measA vertA horizA heightA widthA a -> + FullArray measB vertB horizB heightB widthB b) -> + UnpackedMatrix propertyA lowerA upperA measA vertA horizA heightA widthA a -> + UnpackedMatrix propertyB lowerB upperB measB vertB horizB heightB widthB b +liftUnpacked1 f = liftUnpacked0 . f . unpackedToVector + +liftUnpacked2 :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (FullArray measA vertA horizA heightA widthA a -> + FullArray measB vertB horizB heightB widthB b -> + FullArray measC vertC horizC heightC widthC c) -> + UnpackedMatrix propertyA lowerA upperA measA vertA horizA heightA widthA a -> + UnpackedMatrix propertyB lowerB upperB measB vertB horizB heightB widthB b -> + UnpackedMatrix propertyC lowerC upperC measC vertC horizC heightC widthC c +liftUnpacked2 f = liftUnpacked1 . f . unpackedToVector + +liftUnpacked3 :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Omni.Property propertyD, Omni.Strip lowerD, Omni.Strip upperD) => + (FullArray measA vertA horizA heightA widthA a -> + FullArray measB vertB horizB heightB widthB b -> + FullArray measC vertC horizC heightC widthC c -> + FullArray measD vertD horizD heightD widthD d) -> + UnpackedMatrix propertyA lowerA upperA measA vertA horizA heightA widthA a -> + UnpackedMatrix propertyB lowerB upperB measB vertB horizB heightB widthB b -> + UnpackedMatrix propertyC lowerC upperC measC vertC horizC heightC widthC c -> + UnpackedMatrix propertyD lowerD upperD measD vertD horizD heightD widthD d +liftUnpacked3 f = liftUnpacked2 . f . unpackedToVector + + unliftRow :: - MatrixShape.Order -> + Layout.Order -> (General () height0 a -> General () height1 b) -> Vector height0 a -> Vector height1 b -unliftRow order = Basic.unliftRow order . unlift1 +unliftRow order_ = Basic.unliftRow order_ . unlift1 unliftColumn :: - MatrixShape.Order -> + Layout.Order -> (General height0 () a -> General height1 () b) -> Vector height0 a -> Vector height1 b -unliftColumn order = Basic.unliftColumn order . unlift1 +unliftColumn order_ = Basic.unliftColumn order_ . unlift1 -instance (FormatArray sh) => Type.FormatMatrix (Array sh) where - formatMatrix fmt (Array a) = formatArray fmt a +instance Matrix.FormatMatrix (Array pack property) where + formatMatrix fmt a@(Array _) = + case shape a of + Omni.Full fullShape -> + formatArray fmt $ Array.reshape fullShape $ unwrap a + Omni.UpperTriangular _ -> formatArray fmt $ toVector a + Omni.LowerTriangular _ -> formatArray fmt $ toVector a + Omni.Symmetric _ -> formatArray fmt $ toVector a + Omni.Hermitian _ -> formatArray fmt $ toVector a + Omni.Banded _ -> formatArray fmt $ toVector a + Omni.UnitBandedTriangular _ -> formatArray fmt $ toVector a + Omni.BandedHermitian _ -> formatArray fmt $ toVector a -instance (Multiply.MultiplySame sh) => Type.MultiplySame (Array sh) where - multiplySame = lift2 Multiply.same --- requires UndecidableInstances +packTag :: + (Layout.Packing pack) => + ArrayMatrix pack diag lower upper meas vert horiz height width a -> + Layout.PackingSingleton pack +packTag _ = Layout.autoPacking + +diagTag :: + (Omni.TriDiag diag) => + ArrayMatrix pack diag lower upper meas vert horiz height width a -> + Omni.DiagSingleton diag +diagTag _ = Omni.autoDiag + instance - (Plain.SquareShape sh, Box.WidthOf sh ~ width, Shape.Static width) => - Type.StaticIdentity (Array sh) where + (Layout.Packing pack, Omni.TriDiag diag, xl ~ (), xu ~ ()) => + Matrix.MultiplySame (Array pack diag) xl xu where + multiplySame a = + case Omni.powerSingleton $ shape a of + Omni.PowerIdentity -> \b -> + if Matrix.squareSize a == Matrix.squareSize b + then b + else error "multiplySame Identity: shape mismatch" + Omni.PowerUpperTriangular -> + lift2 (Triangular.multiply $ diagTag a) a + Omni.PowerLowerTriangular -> + lift2 (Triangular.multiply $ diagTag a) a + Omni.PowerDiagonal -> + case (diagTag a, shape a) of + (MatrixShape.Unit, Omni.UnitBandedTriangular _) -> + lift2 Banded.multiply a + (MatrixShape.Arbitrary, Omni.Banded _) -> + lift2 Banded.multiply a + (_, Omni.Full _) -> liftUnpacked2 Basic.multiply a + Omni.PowerSymmetric -> + case diagTag a of _ -> error "Symmetric forbidden" + Omni.PowerHermitian -> + case diagTag a of _ -> error "Hermitian forbidden" + Omni.PowerFull -> liftUnpacked2 Basic.multiply a + + +{- +ToDo: implement using Array.Omni.identityOrderAux. +however, we must prevent module cycle + +instance + (meas ~ Extent.Shape, vert ~ Extent.Small, horiz ~ Extent.Small, + height ~ width, Shape.Static width) => + Matrix.StaticIdentity + (Array pack property lower upper meas vert horiz height width) where staticIdentity = - lift0 $ Plain.identityOrder MatrixShape.RowMajor Shape.static + OmniBasic.identityOrder Layout.RowMajor Shape.static +-} +class (Omni.Property property) => Homogeneous property where +instance Homogeneous Arbitrary where +instance Homogeneous Omni.Symmetric where +instance (zero ~ True, neg ~ pos, TBool.C pos) => + Homogeneous (Omni.Hermitian neg zero pos) where + zero :: - (Plain.Homogeneous shape, Class.Floating a) => shape -> ArrayMatrix shape a -zero = lift0 . Plain.zero + (Homogeneous property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> + ArrayMatrix pack property lower upper meas vert horiz height width a +zero = Array . Vector.zero negate :: - (Plain.Homogeneous shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -negate = lift1 Plain.negate + (Homogeneous property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +negate (Array a) = Array $ Vector.negate a scaleReal :: - (Plain.Homogeneous shape, Class.Floating a) => - RealOf a -> ArrayMatrix shape a -> ArrayMatrix shape a -scaleReal = lift1 . Plain.scaleReal + (Homogeneous property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + RealOf a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +scaleReal a (Array v) = Array $ Vector.scaleReal a v newtype ScaleReal f a = ScaleReal {getScaleReal :: a -> f a -> f a} scaleRealReal :: - (Plain.Homogeneous shape, Class.Real a) => - a -> ArrayMatrix shape a -> ArrayMatrix shape a + (Homogeneous property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Real a) => + a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a scaleRealReal = getScaleReal $ Class.switchReal (ScaleReal scaleReal) (ScaleReal scaleReal) +class (Homogeneous property) => Scale property where +instance Scale Arbitrary where +instance Scale Omni.Symmetric where + scale, (.*#) :: - (Multiply.Scale shape, Class.Floating a) => - a -> ArrayMatrix shape a -> ArrayMatrix shape a -scale = lift1 . Multiply.scale + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Scale property, Shape.C height, Shape.C width, Class.Floating a) => + a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +scale a (Array v) = Array $ Vector.scale a v (.*#) = scale infixl 7 .*# +order :: + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Layout.Order +order = Omni.order . shape + forceOrder :: - (Plain.ShapeOrder shape, Class.Floating a) => - MatrixShape.Order -> ArrayMatrix shape a -> ArrayMatrix shape a -forceOrder = lift1 . Plain.forceOrder + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Layout.Order -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +forceOrder order_ a = + case shape a of + Omni.UpperTriangular _ -> lift1 (Triangular.forceOrder order_) a + Omni.LowerTriangular _ -> lift1 (Triangular.forceOrder order_) a + Omni.Full _ -> liftUnpacked1 (Basic.forceOrder order_) a + Omni.Symmetric _ -> lift1 (Triangular.forceOrder order_) a + Omni.Hermitian _ -> lift1 (Triangular.forceOrder order_) a + Omni.Banded _ -> lift1 (Banded.forceOrder order_) a + Omni.BandedHermitian _ -> lift1 (BandedHermitian.forceOrder order_) a + Omni.UnitBandedTriangular _ -> lift1 (Banded.forceOrder order_) a {- | @adaptOrder x y@ contains the data of @y@ with the layout of @x@. -} adaptOrder :: - (Plain.ShapeOrder shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -> ArrayMatrix shape a -adaptOrder = lift2 Plain.adaptOrder + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +adaptOrder = forceOrder . order +class (Omni.Property property) => Additive property where +instance Additive Arbitrary where +instance Additive Omni.Symmetric where +instance (TBool.C neg, TBool.C zero, TBool.C pos) => + Additive (Omni.Hermitian neg zero pos) where + +class (Additive property) => Subtractive property where +instance Subtractive Arbitrary where +instance Subtractive Omni.Symmetric where +instance (TBool.C neg, TBool.C zero, neg ~ pos) => + Subtractive (Omni.Hermitian neg zero pos) where + infixl 6 #+#, #-#, `add`, `sub` -add, sub, (#+#), (#-#) :: - (Plain.Additive shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -> ArrayMatrix shape a -add = lift2 Plain.add -sub = lift2 Plain.sub +add, (#+#) :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Additive property, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +add a b = liftOmni2 Vector.add (adaptOrder b a) b + +sub, (#-#) :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Subtractive property, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a +sub a b = liftOmni2 Vector.sub (adaptOrder b a) b + (#+#) = add (#-#) = sub + + +liftOmni1 :: + (OmniArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + OmniArray packB propB lowerB upperB measB vertB horizB heightB widthB b) + -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b +liftOmni1 f (Array a) = Array $ f a + +liftOmni2 :: + (OmniArray packA propA lowerA upperA measA vertA horizA heightA widthA a -> + OmniArray packB propB lowerB upperB measB vertB horizB heightB widthB b -> + OmniArray packC propC lowerC upperC measC vertC horizC heightC widthC c) + -> + ArrayMatrix packA propA lowerA upperA measA vertA horizA heightA widthA a -> + ArrayMatrix packB propB lowerB upperB measB vertB horizB heightB widthB b -> + ArrayMatrix packC propC lowerC upperC measC vertC horizC heightC widthC c +liftOmni2 f (Array a) (Array b) = Array $ f a b + + + +instance Matrix.ToQuadratic (Array pack property) where + heightToQuadratic a@(Array _) = + case shape a of + Omni.Full _ -> + ($a) $ liftUnpacked1 $ Basic.mapExtent $ + Extent.square . Extent.height + Omni.UpperTriangular _ -> a + Omni.LowerTriangular _ -> a + Omni.Symmetric _ -> a + Omni.Hermitian _ -> a + Omni.Banded _ -> + ($a) $ lift1 $ Banded.mapExtentSizes $ Extent.square . Extent.height + Omni.UnitBandedTriangular _ -> a + Omni.BandedHermitian _ -> a + widthToQuadratic a@(Array _) = + case shape a of + Omni.Full _ -> + ($a) $ liftUnpacked1 $ Basic.mapExtent $ + Extent.square . Extent.width + Omni.UpperTriangular _ -> a + Omni.LowerTriangular _ -> a + Omni.Symmetric _ -> a + Omni.Hermitian _ -> a + Omni.Banded _ -> + ($a) $ lift1 $ Banded.mapExtentSizes $ Extent.square . Extent.width + Omni.UnitBandedTriangular _ -> a + Omni.BandedHermitian _ -> a + + +instance + (MapExtent pack property lower upper, xl ~ (), xu ~ ()) => + Matrix.MapExtent (Array pack property) xl xu lower upper where + mapExtent = mapExtent + +class MapExtent pack property lower upper where + mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + ExtentStrict.Map measA vertA horizA measB vertB horizB height width -> + ArrayMatrix pack property lower upper measA vertA horizA height width a -> + ArrayMatrix pack property lower upper measB vertB horizB height width a + +instance MapExtent Unpacked Arbitrary Filled Filled where + mapExtent = lift1 . Plain.mapExtent . ExtentStrict.apply + +instance + (Unary.Natural sub, Unary.Natural super) => + MapExtent Packed Arbitrary (Bands sub) (Bands super) where + mapExtent = lift1 . Banded.mapExtent . ExtentStrict.apply diff --git a/src/Numeric/LAPACK/Matrix/Array/Banded.hs b/src/Numeric/LAPACK/Matrix/Array/Banded.hs --- a/src/Numeric/LAPACK/Matrix/Array/Banded.hs +++ b/src/Numeric/LAPACK/Matrix/Array/Banded.hs @@ -1,24 +1,49 @@ module Numeric.LAPACK.Matrix.Array.Banded where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import Numeric.LAPACK.Matrix.Array (ArrayMatrix) +import Numeric.LAPACK.Matrix.Shape.Omni (Unit, Arbitrary) +import Numeric.LAPACK.Matrix.Layout.Private (Bands, Packed) +import Numeric.LAPACK.Matrix.Extent.Private (Size, Big) import qualified Type.Data.Num.Unary.Literal as TypeNum -type Banded sub super vert horiz height width = - ArrayMatrix (MatrixShape.Banded sub super vert horiz height width) +type FlexBanded prop sub super meas vert horiz height width = + ArrayMatrix + Packed prop (Bands sub) (Bands super) + meas vert horiz height width +type Banded sub super meas vert horiz height width = + FlexBanded Arbitrary sub super meas vert horiz height width type General sub super height width = - ArrayMatrix (MatrixShape.BandedGeneral sub super height width) + Banded sub super Size Big Big height width -type Square sub super size = - ArrayMatrix (MatrixShape.BandedSquare sub super size) +type Quadratic prop sub super size = + ArrMatrix.Quadratic Packed prop (Bands sub) (Bands super) size +type Square sub super size = Quadratic Arbitrary sub super size type Lower sub size = Square sub TypeNum.U0 size type Upper super size = Square TypeNum.U0 super size -type Diagonal size = Square TypeNum.U0 TypeNum.U0 size +type UnitTriangular sub super size = Quadratic Unit sub super size +type UnitLower sub size = UnitTriangular sub TypeNum.U0 size +type UnitUpper super size = UnitTriangular TypeNum.U0 super size +type Diagonal size = FlexDiagonal Arbitrary size +type FlexDiagonal diag size = SymmQuadratic diag TypeNum.U0 size + +type RectangularDiagonal meas vert horiz height width = + Banded TypeNum.U0 TypeNum.U0 meas vert horiz height width + +type SymmQuadratic prop offDiag sh = Quadratic prop offDiag offDiag sh + +type FlexHermitian neg zero pos offDiag sh = + SymmQuadratic (Omni.Hermitian neg zero pos) offDiag sh type Hermitian offDiag sh = - ArrayMatrix (MatrixShape.BandedHermitian offDiag sh) + SymmQuadratic Omni.HermitianUnknownDefiniteness offDiag sh +type HermitianPosSemidef offDiag sh = + SymmQuadratic Omni.HermitianPositiveSemidefinite offDiag sh +type HermitianPosDef offDiag sh = + SymmQuadratic Omni.HermitianPositiveDefinite offDiag sh diff --git a/src/Numeric/LAPACK/Matrix/Array/Basic.hs b/src/Numeric/LAPACK/Matrix/Array/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Array/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Array/Basic.hs @@ -1,22 +1,165 @@ +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Array.Basic where +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square + import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array (Full) +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array (ArrayMatrix, Quadratic) +import Numeric.LAPACK.Vector (Vector) +import qualified Numeric.Netlib.Class as Class -transpose :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> Full horiz vert width height a -transpose = ArrMatrix.lift1 Basic.transpose +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) -swapMultiply :: - (Extent.C vertA, Extent.C vertB, Extent.C horizA, Extent.C horizB) => - (matrix -> - Full horizA vertA widthA heightA a -> - Full horizB vertB widthB heightB a) -> - Full vertA horizA heightA widthA a -> - matrix -> - Full vertB horizB heightB widthB a -swapMultiply multiplyTrans a b = transpose $ multiplyTrans b $ transpose a + +{- | +The number of rows must be maintained by the height mapping function. +-} +mapHeight :: + (ArrayMatrix pack property lower upper Extent.Size vert horiz ~ matrix, + Extent.C vert, Extent.C horiz, + Shape.C heightA, Shape.C heightB, Shape.C width) => + (heightA -> heightB) -> + matrix heightA width a -> matrix heightB width a +mapHeight f = + ArrMatrix.Array . Array.mapShape (Omni.mapHeight f) . ArrMatrix.unwrap + +{- | +The number of columns must be maintained by the width mapping function. +-} +mapWidth :: + (ArrayMatrix pack property lower upper Extent.Size vert horiz ~ matrix, + Extent.C vert, Extent.C horiz, + Shape.C widthA, Shape.C widthB, Shape.C height) => + (widthA -> widthB) -> + matrix height widthA a -> matrix height widthB a +mapWidth f = + ArrMatrix.Array . Array.mapShape (Omni.mapWidth f) . ArrMatrix.unwrap + +mapSquareSize :: + (Shape.C shA, Shape.C shB) => + (shA -> shB) -> + Quadratic pack property lower upper shA a -> + Quadratic pack property lower upper shB a +mapSquareSize f = + ArrMatrix.Array . Array.mapShape (Omni.mapSquareSize f) . ArrMatrix.unwrap + + +toFull :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a +toFull a = + case ArrMatrix.shape a of + Omni.Full _ -> ArrMatrix.liftUnpacked1 id a + Omni.UpperTriangular _ -> ArrMatrix.lift1 Triangular.toSquare a + Omni.LowerTriangular _ -> ArrMatrix.lift1 Triangular.toSquare a + Omni.Symmetric _ -> ArrMatrix.lift1 Symmetric.toSquare a + Omni.Hermitian _ -> ArrMatrix.lift1 Symmetric.toSquare a + Omni.Banded _ -> ArrMatrix.lift1 Banded.toFull a + Omni.UnitBandedTriangular _ -> ArrMatrix.lift1 Banded.toFull a + Omni.BandedHermitian _ -> + ArrMatrix.lift1 (Banded.toFull . BandedHermitian.toBanded) a + +unpack :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix Layout.Unpacked + property lower upper meas vert horiz height width a +unpack a = + case ArrMatrix.shape a of + Omni.Full _ -> ArrMatrix.liftUnpacked1 id a + Omni.UpperTriangular _ -> ArrMatrix.lift1 Mosaic.unpack a + Omni.LowerTriangular _ -> ArrMatrix.lift1 Mosaic.unpack a + Omni.Symmetric _ -> ArrMatrix.lift1 Mosaic.unpack a + Omni.Hermitian _ -> ArrMatrix.lift1 Mosaic.unpack a + Omni.Banded _ -> + ArrMatrix.liftUnpacked0 $ Banded.toFull $ ArrMatrix.toVector a + Omni.UnitBandedTriangular _ -> + ArrMatrix.liftUnpacked0 $ Banded.toFull $ ArrMatrix.toVector a + Omni.BandedHermitian _ -> + ArrMatrix.liftUnpacked0 $ Banded.toFull $ + BandedHermitian.toBanded $ ArrMatrix.toVector a + +takeDiagonal :: + (Shape.C sh, Class.Floating a) => + Quadratic pack property lower upper sh a -> Vector sh a +takeDiagonal a = + case ArrMatrix.shape a of + Omni.Full fullShape -> + Square.takeDiagonal $ Array.reshape fullShape $ ArrMatrix.unwrap a + Omni.UpperTriangular _ -> Mosaic.takeDiagonal $ ArrMatrix.toVector a + Omni.LowerTriangular _ -> Mosaic.takeDiagonal $ ArrMatrix.toVector a + Omni.Symmetric _ -> Mosaic.takeDiagonal $ ArrMatrix.toVector a + Omni.Hermitian _ -> Mosaic.takeDiagonal $ ArrMatrix.toVector a + Omni.Banded _ -> Banded.takeDiagonal $ ArrMatrix.toVector a + Omni.UnitBandedTriangular _ -> Banded.takeDiagonal $ ArrMatrix.toVector a + Omni.BandedHermitian _ -> + Vector.fromReal $ BandedHermitian.takeDiagonal $ ArrMatrix.toVector a + + +identityFromShape :: + (Shape.C sh, Class.Floating a) => + MatrixShape.Quadratic pack property lower upper sh -> + Quadratic pack property lower upper sh a +identityFromShape omni = + ArrMatrix.Array $ + case omni of + Omni.Full _ -> + identityOmni Omni.Full Square.identityOrder omni + Omni.UpperTriangular _ -> + identityOmni Omni.UpperTriangular Packed.identity omni + Omni.LowerTriangular _ -> + identityOmni Omni.LowerTriangular Packed.identity omni + Omni.Symmetric _ -> + identityOmni Omni.Symmetric Packed.identity omni + Omni.Hermitian _ -> + identityOmni Omni.Hermitian Packed.identity omni + Omni.Banded _ -> + identityOmni Omni.Banded Banded.identityFatOrder omni + Omni.UnitBandedTriangular _ -> + identityOmni Omni.UnitBandedTriangular Banded.identityFatOrder omni + Omni.BandedHermitian _ -> + identityOmni Omni.BandedHermitian + BandedHermitian.identityFatOrder omni + +identityOmni :: + (shape -> omni) -> + (Layout.Order -> sh -> Array shape a) -> + MatrixShape.Quadratic pack property lower upper sh -> Array omni a +identityOmni consOmni eye omni = + Array.mapShape consOmni $ eye (Omni.order omni) (Omni.squareSize omni) + +identityFrom :: + (Shape.C sh, Class.Floating a) => + Quadratic pack property lower upper sh a -> + Quadratic pack property lower upper sh a +identityFrom = identityFromShape . ArrMatrix.shape + +identityOrder :: + (Omni.Quadratic pack property lower upper, Shape.C sh, Class.Floating a) => + Layout.Order -> sh -> Quadratic pack property lower upper sh a +identityOrder order sh = identityFromShape $ Omni.quadratic order sh + + +signNegativeDeterminant :: + (Shape.C sh, Class.Floating a) => + MatrixShape.Quadratic pack property lower upper sh -> a +signNegativeDeterminant shape = + Scalar.minusOne ^ mod (Shape.size (Omni.squareSize shape)) 2 diff --git a/src/Numeric/LAPACK/Matrix/Array/Divide.hs b/src/Numeric/LAPACK/Matrix/Array/Divide.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Divide.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Array.Divide where + +import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Square.Linear as SquareLin +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Banded.Linear as BandedLin +import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite + as BandedHermitianPD +import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded as Banded + +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array.Multiply (Factor(..), factorSingleton) +import Numeric.LAPACK.Matrix.Array (Full, Quadratic, QuadraticMeas) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Bool as TBool + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape + + +determinant :: + (Layout.Packing pack, Omni.Property property, + Omni.Strip lower, Omni.Strip upper, + Shape.C sh, Class.Floating a) => + Quadratic pack property lower upper sh a -> a +determinant a = + let shape = ArrMatrix.shape a in + case factorSingleton shape of + FactorFull -> Square.determinant $ OmniMatrix.toFull a + FactorUpperTriangular -> + case ArrMatrix.diagTag a of + MatrixShape.Unit -> Scalar.one + MatrixShape.Arbitrary -> Triangular.determinant a + FactorLowerTriangular -> + case ArrMatrix.diagTag a of + MatrixShape.Unit -> Scalar.one + MatrixShape.Arbitrary -> Triangular.determinant a + + FactorSymmetric -> Symmetric.determinant a + FactorHermitian -> Scalar.fromReal $ Hermitian.determinant a + + FactorBanded -> Banded.determinant a + FactorUnitBandedTriangular -> Scalar.one + FactorBandedHermitian -> + case Omni.hermitianSet shape of + (TBool.False, TBool.False, TBool.True) -> + Scalar.fromReal $ BandedHermitianPD.determinant a + (TBool.True, TBool.False, TBool.False) -> + (OmniMatrix.signNegativeDeterminant shape *) $ Scalar.fromReal $ + BandedHermitianPD.determinant $ Hermitian.negate a + _ -> Banded.determinant $ BandedHermitian.toBanded a + + +{- | +We use the solvers for positive definite Hermitian matrices +also for negative definite matrices. +We even use them for semidefinite matrices, +because semidefinite matrices with full rank are definite. +-} +solve :: + (Layout.Packing pack, Omni.Property property, + Omni.Strip lower, Omni.Strip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Quadratic pack property lower upper sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve a = + case factorSingleton $ ArrMatrix.shape a of + FactorFull -> Square.solve $ OmniMatrix.toFull a + FactorUpperTriangular -> Triangular.solve a + FactorLowerTriangular -> Triangular.solve a + FactorSymmetric -> Symmetric.solve a + FactorHermitian -> Hermitian.solve a + FactorBanded -> Banded.solve a + FactorUnitBandedTriangular -> + ArrMatrix.lift2 (BandedLin.solveTriangular MatrixShape.Unit) a + FactorBandedHermitian -> + case Omni.hermitianSet $ ArrMatrix.shape a of + (TBool.False, _, TBool.True) -> + BandedHermitianPD.solve (HermitianPD.assureFullRank a) + (TBool.True, _, TBool.False) -> + ArrMatrix.negate . + BandedHermitianPD.solve + (Hermitian.negate $ HermitianPD.assureFullRank a) + _ -> Banded.solve $ BandedHermitian.toBanded a + + +inverse :: + (Layout.Packing pack, Omni.Property property, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Extent.Measure meas, Shape.C height, Shape.C width, Class.Floating a) => + QuadraticMeas pack property lower upper meas height width a -> + QuadraticMeas pack property lower upper meas width height a +inverse a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerIdentity -> a + Omni.PowerUpperTriangular -> Triangular.inverse a + Omni.PowerLowerTriangular -> Triangular.inverse a + Omni.PowerSymmetric -> Symmetric.inverse a + Omni.PowerHermitian -> Hermitian.inverse a + Omni.PowerFull -> ArrMatrix.liftUnpacked1 SquareLin.inverse a + Omni.PowerDiagonal -> + case ArrMatrix.shape a of + Omni.Banded _ -> + ArrMatrix.lift1 + (Array.mapShape Layout.diagonalInverse . Vector.recip) a + Omni.BandedHermitian _ -> ArrMatrix.lift1 Vector.recip a + Omni.UnitBandedTriangular _ -> a + Omni.Full _ -> ArrMatrix.liftUnpacked1 SquareLin.inverse a diff --git a/src/Numeric/LAPACK/Matrix/Array/Hermitian.hs b/src/Numeric/LAPACK/Matrix/Array/Hermitian.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Hermitian.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Array.Hermitian ( + Semidefinite, + AnyHermitian, + AnyHermitianP, + assureFullRank, + assureAnyRank, + relaxSemidefinite, + relaxIndefinite, + assurePositiveDefiniteness, + relaxDefiniteness, + asUnknownDefiniteness, + ) where + +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import Numeric.LAPACK.Matrix.Array (Matrix(Array), Quadratic) +import Numeric.LAPACK.Matrix.Layout.Private (Packed) + +import qualified Type.Data.Bool as TBool +import Type.Data.Bool (False, True) + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import Data.Function.HT (Id) + + +class (TBool.C neg, TBool.C pos) => Semidefinite neg pos where +instance Semidefinite False True where +instance Semidefinite True False where + +type AnyHermitian neg zero pos bands sh = + AnyHermitianP Packed neg zero pos bands sh +type AnyHermitianP pack neg zero pos bands sh = + Quadratic pack (Omni.Hermitian neg zero pos) bands bands sh + +{- +If a semidefinite matrix has full rank, then it is definite. +You can verify this by watching the eigenvalue decomposition of the matrix. +-} +assureFullRank :: + (Semidefinite neg pos, TBool.C zero) => + AnyHermitianP pack neg zero pos bands sh a -> + AnyHermitianP pack neg False pos bands sh a +assureFullRank = alterDefiniteness + +assureAnyRank :: + (Semidefinite neg pos, TBool.C zero) => + AnyHermitianP pack neg True pos bands sh a -> + AnyHermitianP pack neg zero pos bands sh a +assureAnyRank = alterDefiniteness + +relaxSemidefinite :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + AnyHermitianP pack neg False pos bands sh a -> + AnyHermitianP pack neg zero pos bands sh a +relaxSemidefinite = alterDefiniteness + +relaxIndefinite :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + AnyHermitianP pack neg zero pos bands sh a -> + Quadratic pack Omni.HermitianUnknownDefiniteness bands bands sh a +relaxIndefinite = alterDefiniteness + +assurePositiveDefiniteness :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + AnyHermitianP pack neg zero pos bands sh a -> + Quadratic pack Omni.HermitianPositiveDefinite bands bands sh a +assurePositiveDefiniteness = alterDefiniteness + +relaxDefiniteness :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + Quadratic pack Omni.HermitianPositiveDefinite bands bands sh a -> + AnyHermitianP pack neg zero pos bands sh a +relaxDefiniteness = alterDefiniteness + +alterDefiniteness :: + (TBool.C negA, TBool.C zeroA, TBool.C posA, + TBool.C negB, TBool.C zeroB, TBool.C posB) => + AnyHermitianP pack negA zeroA posA bands sh a -> + AnyHermitianP pack negB zeroB posB bands sh a +alterDefiniteness (Array a) = + Array $ flip Array.mapShape a $ \omni -> + case omni of + Omni.Full sh -> Omni.Full sh + Omni.Hermitian sh -> Omni.Hermitian sh + Omni.BandedHermitian sh -> Omni.BandedHermitian sh + + +asUnknownDefiniteness :: + Id (Quadratic pack Omni.HermitianUnknownDefiniteness bands bands sh a) +asUnknownDefiniteness = id diff --git a/src/Numeric/LAPACK/Matrix/Array/Indexed.hs b/src/Numeric/LAPACK/Matrix/Array/Indexed.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Indexed.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Array.Indexed where + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import Numeric.LAPACK.Matrix.Array (ArrayMatrix) +import Numeric.LAPACK.Scalar (conjugate, zero) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary + +import qualified Data.Array.Comfort.Storable.Unchecked as UArray +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable ((!)) + +import Foreign.Storable (Storable) + +import Data.Maybe.HT (toMaybe) +import Data.Maybe (fromMaybe) +import Data.Tuple.HT (swap) + + +infixl 9 #! + +(#!) :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + (Shape.Index height, Shape.Index width) -> a +a#!ij = + let shape = ArrMatrix.shape a + in case shape of + Omni.Full fullShape -> + UArray.reshape fullShape (ArrMatrix.unwrap a) ! ij + Omni.UpperTriangular _ -> + accessAlt (checkedZero "UpperTriangular" shape ij) a ij + Omni.LowerTriangular _ -> + accessAlt (checkedZero "LowerTriangular" shape ij) a ij + Omni.Symmetric _ -> + accessAlt (ArrMatrix.toVector a ! swap ij) a ij + Omni.Hermitian _ -> + accessAlt (conjugate $ ArrMatrix.toVector a ! swap ij) a ij + Omni.Banded _ -> accessBanded a ij + Omni.UnitBandedTriangular _ -> accessBanded a ij + Omni.BandedHermitian _ -> + accessAlt + (maybe (checkedZero "BandedHermitian" shape ij) conjugate $ + accessMaybe (ArrMatrix.toVector a) $ boxIx $ swap ij) + a (boxIx ij) + +accessBanded :: + (Omni.ToPlain pack prop lower upper meas vert horiz height width) => + (Omni.Plain pack prop lower upper meas vert horiz height width ~ shape) => + (Layout.Banded sub super meas vert horiz height width ~ shape) => + (Unary.Natural sub, Unary.Natural super) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + ArrayMatrix pack prop lower upper meas vert horiz height width a -> + (Shape.Index height, Shape.Index width) -> a +accessBanded a ij = + accessAlt (checkedZero "Banded" (ArrMatrix.shape a) ij) a $ boxIx ij + +boxIx :: (row, column) -> Layout.BandedIndex row column +boxIx = uncurry Layout.InsideBox + +accessAlt :: + (Omni.ToPlain pack prop lower upper meas vert horiz height width) => + (Omni.Plain pack prop lower upper meas vert horiz height width ~ shape) => + (Shape.Indexed shape, Shape.Index shape ~ ix, Storable a) => + a -> ArrayMatrix pack prop lower upper meas vert horiz height width a -> + ix -> a +accessAlt alt a = fromMaybe alt . accessMaybe (ArrMatrix.toVector a) + +accessMaybe :: + (Shape.Indexed sh, Storable a) => + UArray.Array sh a -> Shape.Index sh -> Maybe a +accessMaybe arr ij = + toMaybe (Shape.inBounds (UArray.shape arr) ij) (arr UArray.! ij) + +checkedZero :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + String -> + Omni.Omni pack property lower upper meas vert horiz height width -> + (Shape.Index height, Shape.Index width) -> a +checkedZero name sh ij = + if Shape.inBounds (Omni.height sh, Omni.width sh) ij + then zero + else error $ "Matrix.Indexed." ++ name ++ ": index out of range" diff --git a/src/Numeric/LAPACK/Matrix/Array/Mosaic.hs b/src/Numeric/LAPACK/Matrix/Array/Mosaic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Mosaic.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Array.Mosaic where + +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Array (Square, Quadratic, FullQuadratic) +import Numeric.LAPACK.Matrix.Shape.Omni (Arbitrary, Unit) +import Numeric.LAPACK.Matrix.Layout.Private + (Empty, Filled, Bands, Packed, Unpacked) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary.Literal as TypeNum + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape + + +type Symmetric sh = SymmetricP Packed sh +type SymmetricP pack sh = FullQuadratic pack Omni.Symmetric sh +type Hermitian sh = HermitianP Packed sh +type HermitianP pack sh = + FullQuadratic pack Omni.HermitianUnknownDefiniteness sh +type HermitianPosDef sh = HermitianPosDefP Packed sh +type HermitianPosDefP pack sh = + FullQuadratic pack Omni.HermitianPositiveDefinite sh +type HermitianPosSemidef sh = HermitianPosSemidefP Packed sh +type HermitianPosSemidefP pack sh = + FullQuadratic pack Omni.HermitianPositiveSemidefinite sh + +{- | +The definiteness tags mean: + +* @neg == False@: There is no @x@ with @x^T * A * x < 0@. +* @zero == False@: There is no @x@ with @x^T * A * x = 0@. +* @pos == False@: There is no @x@ with @x^T * A * x > 0@. + +If a tag is @True@ then this imposes no further restriction on the matrix. +-} +type FlexHermitian neg zero pos sh = FlexHermitianP Packed neg zero pos sh +type FlexHermitianP pack neg zero pos sh = + FullQuadratic pack (Omni.Hermitian neg zero pos) sh + +type Lower sh = FlexLower Arbitrary sh +type Upper sh = FlexUpper Arbitrary sh + +type LowerP pack sh = FlexLowerP pack Arbitrary sh +type UpperP pack sh = FlexUpperP pack Arbitrary sh + +type UnitLower sh = FlexLower Unit sh +type UnitUpper sh = FlexUpper Unit sh + +type UnitLowerP pack sh = FlexLowerP pack Unit sh +type UnitUpperP pack sh = FlexUpperP pack Unit sh + +type FlexLower diag sh = Quadratic Packed diag Filled Empty sh +type FlexUpper diag sh = Quadratic Packed diag Empty Filled sh + +type FlexLowerP pack diag sh = Quadratic pack diag Filled Empty sh +type FlexUpperP pack diag sh = Quadratic pack diag Empty Filled sh + +type QuasiUpper sh = Quadratic Unpacked Arbitrary (Bands TypeNum.U1) Filled sh + +type Triangular lo diag up sh = TriangularP Packed lo diag up sh +type TriangularP pack lo diag up sh = Quadratic pack diag lo up sh + + +assureMirrored :: + (Layout.Packing pack, Layout.Mirror mirror, Layout.UpLo uplo) => + (meas ~ Extent.Shape, vert ~ Extent.Small, horiz ~ Extent.Small) => + (Omni.FromPlain pack prop lower upper meas vert horiz sh sh) => + (Omni.Plain pack prop lower upper meas vert horiz sh sh + ~ + Layout.Mosaic pack mirror uplo sh) => + (Shape.C sh, Class.Floating a) => + Square sh a -> Quadratic pack prop lower upper sh a +assureMirrored = + ArrMatrix.lift0 . Mosaic.repack . + Array.mapShape Layout.mosaicFromSquare . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/Array/Multiply.hs b/src/Numeric/LAPACK/Matrix/Array/Multiply.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Multiply.hs @@ -0,0 +1,850 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Array.Multiply where + +import qualified Numeric.LAPACK.Matrix.Full as Full +import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Banded.Basic as BandedBasic +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as TriangularBasic +import qualified Numeric.LAPACK.Matrix.Square.Basic as SquareBasic +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Vector.Private as VectorPriv +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Layout.Private + (Filled, Empty, Bands, Packed, Unpacked, UnaryProxy, natFromProxy) +import Numeric.LAPACK.Matrix.Array.Banded (Banded) +import Numeric.LAPACK.Matrix.Array (ArrayMatrix, diagTag) +import Numeric.LAPACK.Matrix.Type (Matrix) +import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed,Transposed)) +import Numeric.LAPACK.Matrix.Shape.Omni (StripSingleton(StripBands, StripFilled)) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked, deconsUnchecked)) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import qualified Type.Data.Bool as TBool +import Type.Data.Num.Unary (Succ, (:+:)) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Stream as Stream +import Data.Stream (Stream) +import Data.Tuple.HT (double) +import Data.Function.HT (Id) + + + +type FactorQuadratic pack property lower upper sh = + Factor pack property lower upper + Extent.Shape Extent.Small Extent.Small sh sh + +data Factor pack property lower upper meas vert horiz height width where + FactorUpperTriangular :: + (Layout.Packing pack, Omni.TriDiag diag) => + FactorQuadratic pack diag Empty Filled sh + FactorLowerTriangular :: + (Layout.Packing pack, Omni.TriDiag diag) => + FactorQuadratic pack diag Filled Empty sh + FactorSymmetric :: + (Layout.Packing pack) => + FactorQuadratic pack Omni.Symmetric Filled Filled sh + FactorHermitian :: + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos) => + FactorQuadratic pack (Omni.Hermitian neg zero pos) Filled Filled sh + FactorBanded :: + (Unary.Natural sub, Unary.Natural super) => + Factor Packed Omni.Arbitrary (Bands sub) (Bands super) + meas vert horiz height width + FactorBandedHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + FactorQuadratic Packed (Omni.Hermitian neg zero pos) + (Bands offDiag) (Bands offDiag) sh + FactorUnitBandedTriangular :: + (Omni.BandedTriangular sub super, + Omni.BandedTriangular super sub) => + FactorQuadratic Packed Omni.Unit (Bands sub) (Bands super) sh + FactorFull :: + Factor Unpacked property lower upper meas vert horiz height width + +factorSingleton :: + (Layout.Packing pack, Omni.Property property, + Omni.Strip lower, Omni.Strip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni.Omni pack property lower upper meas vert horiz height width -> + Factor pack property lower upper meas vert horiz height width +factorSingleton shape = + case Omni.packTag shape of + Layout.Packed -> + case shape of + Omni.UpperTriangular _ -> FactorUpperTriangular + Omni.LowerTriangular _ -> FactorLowerTriangular + Omni.Symmetric _ -> FactorSymmetric + Omni.Hermitian _ -> FactorHermitian + Omni.Banded _ -> FactorBanded + Omni.BandedHermitian _ -> FactorBandedHermitian + Omni.UnitBandedTriangular _ -> FactorUnitBandedTriangular + Layout.Unpacked -> + case (Omni.extent shape, Omni.property shape, Omni.strips shape) of + (ExtentPriv.Square _, Omni.PropArbitrary, + (StripBands Unary.Zero, StripFilled)) -> + FactorUpperTriangular + (ExtentPriv.Square _, Omni.PropArbitrary, + (StripFilled, StripBands Unary.Zero)) -> + FactorLowerTriangular + (ExtentPriv.Square _, Omni.PropUnit, + (StripBands Unary.Zero, StripFilled)) -> + FactorUpperTriangular + (ExtentPriv.Square _, Omni.PropUnit, + (StripFilled, StripBands Unary.Zero)) -> + FactorLowerTriangular + (ExtentPriv.Square _, Omni.PropSymmetric, + (StripFilled, StripFilled)) -> + FactorSymmetric + (ExtentPriv.Square _, Omni.PropHermitian, + (StripFilled, StripFilled)) -> + FactorHermitian + _ -> FactorFull + +matrixVector :: + (Layout.Packing pack) => + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Vector width a -> Vector height a +matrixVector a x = + case factorSingleton $ ArrMatrix.shape a of + FactorFull -> Full.multiplyVector (OmniMatrix.toFull a) x + FactorUpperTriangular -> Triangular.multiplyVector a x + FactorLowerTriangular -> Triangular.multiplyVector a x + FactorSymmetric -> Symmetric.multiplyVector a x + FactorHermitian -> Hermitian.multiplyVector NonTransposed a x + FactorBanded -> Banded.multiplyVector a x + FactorUnitBandedTriangular -> + BandedBasic.multiplyVector (ArrMatrix.toVector a) x + FactorBandedHermitian -> + BandedHermitian.multiplyVector NonTransposed a x + +vectorMatrix :: + (Layout.Packing pack) => + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Vector height a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Vector width a +vectorMatrix x a = + case factorSingleton $ ArrMatrix.shape a of + FactorFull -> + Full.multiplyVector (OmniMatrix.toFull $ Unpacked.transpose a) x + FactorUpperTriangular -> + Triangular.multiplyVector (Triangular.transpose a) x + FactorLowerTriangular -> + Triangular.multiplyVector (Triangular.transpose a) x + FactorSymmetric -> Symmetric.multiplyVector a x + FactorHermitian -> Hermitian.multiplyVector Transposed a x + FactorBanded -> Banded.multiplyVector (Banded.transpose a) x + FactorUnitBandedTriangular -> + BandedBasic.multiplyVector + (BandedBasic.transpose $ ArrMatrix.toVector a) x + FactorBandedHermitian -> + BandedHermitian.multiplyVector Transposed a x + + +{- ToDo: +We can remove the transposition parameter +if we can transpose Hermitian in constant time. +Then we can express all variations using 'transpose'. +-} +transposableSquare :: + (Layout.Packing pack) => + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Transposition -> + ArrMatrix.Quadratic pack property lower upper height a -> + ArrMatrix.Full meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a +transposableSquare trans a = + ($a) $ + case ArrMatrix.shape a of + Omni.Hermitian _ -> Hermitian.multiplyFull trans + Omni.BandedHermitian _ -> BandedHermitian.multiplyFull trans + _ -> + case trans of + Transposed -> squareFull . Matrix.transpose + NonTransposed -> squareFull + +extentFromSquare :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Extent.Map Extent.Shape Extent.Small Extent.Small meas vert horiz size size +extentFromSquare = ExtentStrict.Map ExtentPriv.fromSquare + +fullSquare :: + (Layout.Packing pack) => + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + ArrMatrix.Full meas vert horiz height width a -> + ArrMatrix.Quadratic pack property lower upper width a -> + ArrMatrix.Full meas vert horiz height width a +fullSquare = Matrix.swapMultiply $ transposableSquare Transposed + +squareFull :: + (Layout.Packing pack) => + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + ArrMatrix.Quadratic pack property lower upper height a -> + ArrMatrix.Full meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a +squareFull a = + case factorSingleton $ ArrMatrix.shape a of + FactorFull -> Unpacked.multiply $ Unpacked.mapExtent extentFromSquare a + FactorUpperTriangular -> Triangular.multiplyFull a + FactorLowerTriangular -> Triangular.multiplyFull a + FactorSymmetric -> Symmetric.multiplyFull a + FactorHermitian -> Hermitian.multiplyFull NonTransposed a + FactorBanded -> Banded.multiplyFull $ Banded.mapExtent extentFromSquare a + FactorBandedHermitian -> BandedHermitian.multiplyFull NonTransposed a + FactorUnitBandedTriangular -> + ArrMatrix.lift2 + (BandedBasic.multiplyFull . + BandedBasic.mapExtent ExtentPriv.fromSquare) a + + +vectorSquare :: (Shape.C sh, Class.Floating a) => Vector sh a -> Vector sh a +vectorSquare = + VectorPriv.recheck . uncurry Vector.mul . double . VectorPriv.uncheck + +square :: + (Layout.Packing pack, Omni.Property property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + ArrMatrix.Quadratic pack property lower upper sh a -> + ArrMatrix.Quadratic pack property lower upper sh a +square a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerIdentity -> a + Omni.PowerUpperTriangular -> Triangular.square a + Omni.PowerLowerTriangular -> Triangular.square a + Omni.PowerSymmetric -> Symmetric.square a + Omni.PowerHermitian -> Hermitian.square a + Omni.PowerFull -> ArrMatrix.liftUnpacked1 SquareBasic.square a + Omni.PowerDiagonal -> + case ArrMatrix.shape a of + Omni.Banded _ -> ArrMatrix.lift1 vectorSquare a + -- ToDo: could be optimized by processing only the real part + Omni.BandedHermitian _ -> ArrMatrix.lift1 vectorSquare a + Omni.UnitBandedTriangular _ -> a + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (SquareBasic.diagonalOrder (ArrMatrix.order a) . + vectorSquare . SquareBasic.takeDiagonal) + a + +power :: + (Layout.Packing pack, Omni.Property property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + Integer -> + ArrMatrix.Quadratic pack property lower upper sh a -> + ArrMatrix.Quadratic pack property lower upper sh a +power n a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerIdentity -> a + Omni.PowerUpperTriangular -> + ArrMatrix.lift1 (Mosaic.power (diagTag a) n) a + Omni.PowerLowerTriangular -> + ArrMatrix.lift1 (Mosaic.power (diagTag a) n) a + Omni.PowerSymmetric -> + ArrMatrix.lift1 (Mosaic.power Omni.Arbitrary n) a + Omni.PowerHermitian -> + ArrMatrix.lift1 (Mosaic.power Omni.Arbitrary n) a + Omni.PowerFull -> + ArrMatrix.liftUnpacked1 (SquareBasic.power n) a + Omni.PowerDiagonal -> + case ArrMatrix.shape a of + Omni.Banded _ -> ArrMatrix.lift1 (Array.map (^n)) a + Omni.BandedHermitian _ -> ArrMatrix.lift1 (Array.map (^n)) a + Omni.UnitBandedTriangular _ -> a + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (SquareBasic.diagonalOrder (ArrMatrix.order a) . + Array.map (^n) . SquareBasic.takeDiagonal) + a + +powers, powers1 :: + (Layout.Packing pack, Omni.Property property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + ArrMatrix.Quadratic pack property lower upper sh a -> + Stream (ArrMatrix.Quadratic pack property lower upper sh a) +powers a = Stream.Cons (OmniMatrix.identityFrom a) (powers1 a) +powers1 a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerIdentity -> Stream.repeat a + Omni.PowerUpperTriangular -> powers1Gen a Triangular.multiply + Omni.PowerLowerTriangular -> powers1Gen a Triangular.multiply + Omni.PowerSymmetric -> + fmap ArrMatrix.lift0 $ + Mosaic.powers1 Omni.Arbitrary $ ArrMatrix.toVector a + Omni.PowerHermitian -> + fmap ArrMatrix.lift0 $ + Mosaic.powers1 Omni.Arbitrary $ ArrMatrix.toVector a + Omni.PowerFull -> + powers1Gen a $ ArrMatrix.liftUnpacked2 FullBasic.multiply + Omni.PowerDiagonal -> + case ArrMatrix.shape a of + Omni.Banded _ -> + fmap ArrMatrix.Array $ powers1Diagonal $ ArrMatrix.unwrap a + Omni.BandedHermitian _ -> + fmap ArrMatrix.Array $ powers1Diagonal $ ArrMatrix.unwrap a + Omni.UnitBandedTriangular _ -> Stream.repeat a + Omni.Full _ -> + fmap (ArrMatrix.liftUnpacked0 . + SquareBasic.diagonalOrder (ArrMatrix.order a)) $ + powers1Diagonal $ + SquareBasic.takeDiagonal $ ArrMatrix.unpackedToVector a + +powers1Diagonal :: + (Shape.C sh, Class.Floating a) => Vector sh a -> Stream (Vector sh a) +powers1Diagonal a = + let b = VectorPriv.uncheck a + in fmap VectorPriv.recheck $ Stream.iterate (flip (Array.zipWith (*)) b) b + +powers1Gen :: + (Layout.Packing pack, Omni.Property property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + ArrMatrix.Quadratic pack property lower upper sh a -> + (ArrMatrix.Quadratic pack property lower upper (Unchecked sh) a -> + ArrMatrix.Quadratic pack property lower upper (Unchecked sh) a -> + ArrMatrix.Quadratic pack property lower upper (Unchecked sh) a) -> + Stream (ArrMatrix.Quadratic pack property lower upper sh a) +powers1Gen a mul = + let b = OmniMatrix.mapSquareSize Unchecked a + in fmap (OmniMatrix.mapSquareSize deconsUnchecked) $ + Stream.iterate (flip mul b) b + + +type family MultipliedPacking packA packB +type instance MultipliedPacking Packed packB = packB +type instance MultipliedPacking Unpacked packB = Unpacked + +type family PackingByStrip lower upper meas pack +type instance PackingByStrip lower upper meas Unpacked = Unpacked +type instance PackingByStrip Filled upper Extent.Size pack = Unpacked +type instance PackingByStrip Empty upper Extent.Shape pack = pack +type instance PackingByStrip (Bands k) (Bands l) meas pack = pack +type instance PackingByStrip Filled Filled meas pack = Unpacked +type instance PackingByStrip + Filled (Bands (Unary.Succ l)) meas pack = Unpacked + + +{- | +This functions allows to multiply two matrices of arbitrary special features +and returns the most special matrix type possible (almost). +At the first glance, this is handy. +At the second glance, this has some problems. +First of all, we may refine the types in future +and then multiplication may return a different, more special type than before. +Second, if you write code with polymorphic matrix types, +then 'matrixMatrix' may leave you with constraints like +@ExtentPriv.Multiply vert vert ~ vert@. +That constraint is always fulfilled but the compiler cannot infer that. +Because of these problems +you may instead consider using specialised 'Basic.multiply' functions +from the various modules for production use. +Btw. 'MultiplyVector' and 'MultiplySquare' +are much less problematic, +because the input and output are always dense vectors or dense matrices. + + +We require e.g. both + +> Extent.Multiply vertA vertB ~ vertC + +and + +> Extent.Multiply vertB vertA ~ vertC + +This makes the combination commutative. +At first glance this looks counterintuitive, +but this allows the type checker to infer +that "shape A" times "square" is "shape A". +-} +matrixMatrix :: + (Layout.Packing packA, Omni.Property propertyA) => + (Layout.Packing packB, Omni.Property propertyB) => + (Layout.Packing packC, Omni.Property propertyC) => + (Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Strip lowerC, Omni.Strip upperC) => + (MultipliedPacking packA packB ~ pack) => + (MultipliedPacking packB packA ~ pack) => + (Omni.MultipliedStrip lowerA lowerB ~ lowerC) => + (Omni.MultipliedStrip lowerB lowerA ~ lowerC) => + (Omni.MultipliedStrip upperA upperB ~ upperC) => + (Omni.MultipliedStrip upperB upperA ~ upperC) => + (Omni.MultipliedBands lowerA lowerB ~ lowerC) => + (Omni.MultipliedBands lowerB lowerA ~ lowerC) => + (Omni.MultipliedBands upperA upperB ~ upperC) => + (Omni.MultipliedBands upperB upperA ~ upperC) => + (Omni.MultipliedProperty propertyA propertyB ~ propertyAB) => + (Omni.MultipliedProperty propertyB propertyA ~ propertyAB) => + (Omni.UnitIfTriangular lowerC upperC ~ diag) => + (Omni.UnitIfTriangular upperC lowerC ~ diag) => + (Omni.MergeUnit propertyAB diag ~ propertyC) => + (Omni.MergeUnit diag propertyAB ~ propertyC) => + (PackingByStrip lowerC upperC measC pack ~ packC) => + (PackingByStrip upperC lowerC measC pack ~ packC) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (ExtentPriv.MultiplyMeasure measA measB ~ measC) => + (ExtentPriv.MultiplyMeasure measB measA ~ measC) => + (ExtentPriv.Multiply vertA vertB ~ vertC) => + (ExtentPriv.Multiply vertB vertA ~ vertC) => + (ExtentPriv.Multiply horizA horizB ~ horizC) => + (ExtentPriv.Multiply horizB horizA ~ horizC) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + ArrayMatrix packA propertyA lowerA upperA measA vertA horizA height fuse a -> + ArrayMatrix packB propertyB lowerB upperB measB vertB horizB fuse width a -> + ArrayMatrix packC propertyC lowerC upperC measC vertC horizC height width a +matrixMatrix a b = + case (ArrMatrix.shape a, ArrMatrix.shape b) of + (shapeA@(Omni.Full _), shapeB@(Omni.Full _)) -> + case factorSingleton shapeA of + FactorUpperTriangular -> squareUnpacked a b + FactorLowerTriangular -> squareUnpacked a b + FactorSymmetric -> squareUnpacked a b + FactorHermitian -> squareUnpacked a b + _ -> + case factorSingleton shapeB of + FactorUpperTriangular -> unpackedSquare a b + FactorLowerTriangular -> unpackedSquare a b + FactorSymmetric -> unpackedSquare a b + FactorHermitian -> unpackedSquare a b + _ -> unpackedUnpacked a b + (Omni.Full _, Omni.UpperTriangular _) -> unpackedSquare a b + (Omni.Full _, Omni.LowerTriangular _) -> unpackedSquare a b + (Omni.Full _, Omni.Symmetric _) -> unpackedSquare a b + (Omni.Full _, Omni.Hermitian _) -> unpackedSquare a b + (Omni.Full _, Omni.Banded _) -> unpackedBanded a b + (Omni.Full _, Omni.UnitBandedTriangular _) -> unpackedSquare a b + (Omni.Full _, Omni.BandedHermitian _) -> unpackedSquare a b + (Omni.UpperTriangular _, Omni.Full _) -> squareUnpacked a b + (Omni.UpperTriangular _, Omni.UpperTriangular _) -> + case (diagTag a, diagTag b) of + (diagA@Omni.Unit, Omni.Unit) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (diagA@Omni.Unit, Omni.Arbitrary) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (diagA@Omni.Arbitrary, _) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (Omni.UpperTriangular _, Omni.LowerTriangular _) -> + squareFull a (OmniMatrix.toFull b) + (Omni.UpperTriangular _, Omni.Symmetric _) -> + squareFull a (Symmetric.toSquare b) + (Omni.UpperTriangular _, Omni.Hermitian _) -> + squareFull a (Hermitian.toSquare b) + (Omni.UpperTriangular _, Omni.Banded _) -> + case ArrMatrix.subBandsSingleton b of + Unary.Succ -> unpackedBanded (OmniMatrix.toFull a) b + Unary.Zero -> + case Matrix.extent b of + ExtentPriv.Square _ -> + Triangular.takeUpper $ asArbitrary $ + unpackedBanded (OmniMatrix.toFull a) b + ExtentPriv.Separate _ _ -> + unpackedBanded (OmniMatrix.toFull a) b + (Omni.UpperTriangular _, Omni.BandedHermitian _) -> + case ArrMatrix.subBandsSingleton b of + Unary.Succ -> unpackedSquare (OmniMatrix.toFull a) b + Unary.Zero -> + ArrMatrix.lift1 TriangularBasic.takeUpper $ + fullSquare (OmniMatrix.toFull a) b + (Omni.UpperTriangular _, Omni.UnitBandedTriangular _) -> + case ArrMatrix.subBandsSingleton b of + Unary.Succ -> unpackedSquare (OmniMatrix.toFull a) b + Unary.Zero -> + case diagTag a of + Omni.Unit -> + ArrMatrix.lift1 id $ + Triangular.takeUpper $ fullSquare (OmniMatrix.toFull a) b + Omni.Arbitrary -> + Triangular.takeUpper $ fullSquare (OmniMatrix.toFull a) b + (Omni.LowerTriangular _, Omni.Full _) -> squareUnpacked a b + (Omni.LowerTriangular _, Omni.LowerTriangular _) -> + case (diagTag a, diagTag b) of + (diagA@Omni.Unit, Omni.Unit) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (diagA@Omni.Unit, Omni.Arbitrary) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (diagA@Omni.Arbitrary, _) -> + ArrMatrix.lift2 (TriangularBasic.multiply diagA) a b + (Omni.LowerTriangular _, Omni.UpperTriangular _) -> + squareFull a (OmniMatrix.toFull b) + (Omni.LowerTriangular _, Omni.Symmetric _) -> + squareFull a (Symmetric.toSquare b) + (Omni.LowerTriangular _, Omni.Hermitian _) -> + squareFull a (Hermitian.toSquare b) + (Omni.LowerTriangular _, Omni.Banded _) -> + case ArrMatrix.superBandsSingleton b of + Unary.Succ -> unpackedBanded (OmniMatrix.toFull a) b + Unary.Zero -> + case Matrix.extent b of + ExtentPriv.Square _ -> + Triangular.takeLower $ asArbitrary $ + unpackedBanded (OmniMatrix.toFull a) b + ExtentPriv.Separate _ _ -> + unpackedBanded (OmniMatrix.toFull a) b + (Omni.LowerTriangular _, Omni.BandedHermitian _) -> + case ArrMatrix.superBandsSingleton b of + Unary.Succ -> flex $ fullSquare (OmniMatrix.toFull a) b + Unary.Zero -> + Triangular.takeLower $ fullSquare (OmniMatrix.toFull a) b + (Omni.LowerTriangular _, Omni.UnitBandedTriangular _) -> + case ArrMatrix.superBandsSingleton b of + Unary.Succ -> flex $ fullSquare (OmniMatrix.toFull a) b + Unary.Zero -> + case diagTag a of + Omni.Unit -> + ArrMatrix.lift1 id $ + Triangular.takeLower $ fullSquare (OmniMatrix.toFull a) b + Omni.Arbitrary -> + Triangular.takeLower $ fullSquare (OmniMatrix.toFull a) b + (Omni.Symmetric _, Omni.Full _) -> squareFull a (unflex b) + (Omni.Symmetric _, Omni.LowerTriangular _) -> + fullSquare (Symmetric.toSquare a) b + (Omni.Symmetric _, Omni.UpperTriangular _) -> + fullSquare (Symmetric.toSquare a) b + (Omni.Symmetric _, Omni.Symmetric _) -> + squareFull a (Symmetric.toSquare b) + (Omni.Symmetric _, Omni.Hermitian _) -> + fullSquare (Symmetric.toSquare a) b + (Omni.Symmetric _, Omni.Banded _) -> + unpackedBanded (Symmetric.toSquare a) b + (Omni.Symmetric _, Omni.BandedHermitian _) -> + fullSquare (Symmetric.toSquare a) b + (Omni.Symmetric _, Omni.UnitBandedTriangular _) -> + fullSquare (Symmetric.toSquare a) b + (Omni.Hermitian _, Omni.Full _) -> squareFull a (unflex b) + (Omni.Hermitian _, Omni.LowerTriangular _) -> + fullSquare (Hermitian.toSquare a) b + (Omni.Hermitian _, Omni.UpperTriangular _) -> + fullSquare (Hermitian.toSquare a) b + (Omni.Hermitian _, Omni.Symmetric _) -> + squareFull a (Symmetric.toSquare b) + (Omni.Hermitian _, Omni.Hermitian _) -> + squareFull a (Hermitian.toSquare b) + (Omni.Hermitian _, Omni.Banded _) -> + unpackedBanded (Hermitian.toSquare a) b + (Omni.Hermitian _, Omni.BandedHermitian _) -> + fullSquare (Hermitian.toSquare a) b + (Omni.Hermitian _, Omni.UnitBandedTriangular _) -> + fullSquare (Hermitian.toSquare a) b + (Omni.Banded _, Omni.Full _) -> bandedUnpacked a b + (Omni.Banded _, Omni.Symmetric _) -> + bandedUnpacked a (Symmetric.toSquare b) + (Omni.Banded _, Omni.Hermitian _) -> + bandedUnpacked a (Hermitian.toSquare b) + (Omni.Banded _, Omni.LowerTriangular _) -> + case ArrMatrix.superBandsSingleton a of + Unary.Succ -> bandedUnpacked a (OmniMatrix.toFull b) + Unary.Zero -> + case Matrix.extent a of + ExtentPriv.Square _ -> + Triangular.takeLower $ asArbitrary $ + bandedUnpacked a (OmniMatrix.toFull b) + ExtentPriv.Separate _ _ -> + bandedUnpacked a (OmniMatrix.toFull b) + (Omni.Banded _, Omni.UpperTriangular _) -> + case ArrMatrix.subBandsSingleton a of + Unary.Succ -> bandedUnpacked a (OmniMatrix.toFull b) + Unary.Zero -> + case Matrix.extent a of + ExtentPriv.Square _ -> + Triangular.takeUpper $ asArbitrary $ + bandedUnpacked a (OmniMatrix.toFull b) + ExtentPriv.Separate _ _ -> + bandedUnpacked a (OmniMatrix.toFull b) + (Omni.UnitBandedTriangular _, Omni.Full _) -> squareUnpacked a b + (Omni.UnitBandedTriangular _, Omni.LowerTriangular _) -> + case ArrMatrix.superBandsSingleton a of + Unary.Succ -> flex $ squareFull a (OmniMatrix.toFull b) + Unary.Zero -> + case diagTag b of + Omni.Unit -> + ArrMatrix.lift1 id $ + Triangular.takeLower $ squareFull a (OmniMatrix.toFull b) + Omni.Arbitrary -> + Triangular.takeLower $ squareFull a (OmniMatrix.toFull b) + (Omni.UnitBandedTriangular _, Omni.UpperTriangular _) -> + case ArrMatrix.subBandsSingleton a of + Unary.Succ -> flex $ squareFull a (OmniMatrix.toFull b) + Unary.Zero -> + case diagTag b of + Omni.Unit -> + ArrMatrix.lift1 id $ + Triangular.takeUpper $ squareFull a (OmniMatrix.toFull b) + Omni.Arbitrary -> + Triangular.takeUpper $ squareFull a (OmniMatrix.toFull b) + (Omni.UnitBandedTriangular _, Omni.Symmetric _) -> + squareFull a (Symmetric.toSquare b) + (Omni.UnitBandedTriangular _, Omni.Hermitian _) -> + squareFull a (Hermitian.toSquare b) + (Omni.BandedHermitian _, Omni.Full _) -> squareUnpacked a b + (Omni.BandedHermitian _, Omni.LowerTriangular _) -> + case ArrMatrix.superBandsSingleton a of + Unary.Succ -> squareUnpacked a (OmniMatrix.toFull b) + Unary.Zero -> + Triangular.takeLower $ squareFull a (OmniMatrix.toFull b) + (Omni.BandedHermitian _, Omni.UpperTriangular _) -> + case ArrMatrix.subBandsSingleton a of + Unary.Succ -> squareUnpacked a (OmniMatrix.toFull b) + Unary.Zero -> + Triangular.takeUpper $ squareFull a (OmniMatrix.toFull b) + (Omni.Banded _shA, Omni.Banded _shB) -> bandedBanded a b + (Omni.Banded _shA, Omni.UnitBandedTriangular _shB) -> + bandedBanded a (Banded.noUnit b) + (Omni.Banded _shA, Omni.BandedHermitian _shB) -> + bandedBanded a (BandedHermitian.toBanded b) + (Omni.UnitBandedTriangular _shA, Omni.Banded _shB) -> + bandedBanded (Banded.noUnit a) b + (Omni.UnitBandedTriangular _shA, Omni.BandedHermitian _shB) -> + bandedBanded (Banded.noUnit a) (BandedHermitian.toBanded b) + (Omni.UnitBandedTriangular shA, Omni.UnitBandedTriangular shB) -> + case (Omni.bandedTriangularSingleton shA, + Omni.bandedTriangularSingleton shB) of + (Omni.BandedDiagonal, Omni.BandedDiagonal) -> b + (Omni.BandedDiagonal, Omni.BandedUpper) -> b + (Omni.BandedDiagonal, Omni.BandedLower) -> b + (Omni.BandedUpper, Omni.BandedDiagonal) -> a + (Omni.BandedLower, Omni.BandedDiagonal) -> a + (Omni.BandedUpper, Omni.BandedLower) -> + bandedBanded (Banded.noUnit a) (Banded.noUnit b) + (Omni.BandedLower, Omni.BandedUpper) -> + bandedBanded (Banded.noUnit a) (Banded.noUnit b) + (Omni.BandedUpper, Omni.BandedUpper) -> bandedUpper a b + (Omni.BandedLower, Omni.BandedLower) -> bandedLower a b + (Omni.BandedHermitian _, Omni.Symmetric _) -> + squareUnpacked a (Symmetric.toSquare b) + (Omni.BandedHermitian _, Omni.Hermitian _) -> + squareUnpacked a (Hermitian.toSquare b) + (Omni.BandedHermitian _shA, Omni.Banded _shB) -> + bandedBanded (BandedHermitian.toBanded a) b + (Omni.BandedHermitian _shA, Omni.UnitBandedTriangular _shB) -> + bandedBanded (BandedHermitian.toBanded a) (Banded.noUnit b) + (Omni.BandedHermitian _shA, Omni.BandedHermitian _shB) -> + bandedBanded (BandedHermitian.toBanded a) (BandedHermitian.toBanded b) + +asArbitrary :: + Id (ArrayMatrix pack + Omni.Arbitrary Filled Filled meas vert horiz height width a) +asArbitrary = id + + +unpackedSquare :: + (Layout.Packing packB) => + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full.Unpacked propertyA lowerA upperA meas vert horiz height width a -> + ArrMatrix.Quadratic packB propertyB lowerB upperB width a -> + Full.Unpacked propertyC lowerC upperC meas vert horiz height width a +unpackedSquare a b = flex $ fullSquare (unflex a) b + +squareUnpacked :: + (Layout.Packing packA) => + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + ArrMatrix.Quadratic packA propertyA lowerA upperA height a -> + Full.Unpacked propertyB lowerB upperB meas vert horiz height width a -> + Full.Unpacked propertyC lowerC upperC meas vert horiz height width a +squareUnpacked a b = flex $ squareFull a (unflex b) + +unpackedUnpacked :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Full.Unpacked propertyA lowerA upperA measA vertA horizA height fuse a -> + Full.Unpacked propertyB lowerB upperB measB vertB horizB fuse width a -> + Full.Unpacked propertyC lowerC upperC + (ExtentPriv.MultiplyMeasure measA measB) + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + height width a +unpackedUnpacked a b = + case unifyFactors a b of + ((ExtentPriv.MeasureFact, ExtentPriv.TagFact, ExtentPriv.TagFact), + (unifyLeft, unifyRight)) -> + ArrMatrix.liftUnpacked2 FullBasic.multiply + (Unpacked.mapExtent unifyLeft a) + (Unpacked.mapExtent unifyRight b) + +unpackedBanded :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Unary.Natural sub, Unary.Natural super) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Full.Unpacked propertyA lowerA upperA measA vertA horizA height fuse a -> + Banded sub super measB vertB horizB fuse width a -> + Full.Unpacked propertyC lowerC upperC + (ExtentPriv.MultiplyMeasure measA measB) + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + height width a +unpackedBanded a b = + case unifyFactors a b of + ((ExtentPriv.MeasureFact, ExtentPriv.TagFact, ExtentPriv.TagFact), + (unifyLeft, unifyRight)) -> + Unpacked.swapMultiply + (ArrMatrix.liftUnpacked1 . BandedBasic.multiplyFull . + ArrMatrix.toVector . Banded.transpose) + (Unpacked.mapExtent unifyLeft a) + (Banded.mapExtent unifyRight b) + +bandedUnpacked :: + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Unary.Natural sub, Unary.Natural super) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Banded sub super measA vertA horizA height fuse a -> + Full.Unpacked propertyB lowerB upperB measB vertB horizB fuse width a -> + Full.Unpacked propertyC lowerC upperC + (ExtentPriv.MultiplyMeasure measA measB) + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + height width a +bandedUnpacked a b = + case unifyFactors a b of + ((ExtentPriv.MeasureFact, ExtentPriv.TagFact, ExtentPriv.TagFact), + (unifyLeft, unifyRight)) -> + (ArrMatrix.liftUnpacked1 . BandedBasic.multiplyFull . + ArrMatrix.toVector) + (Banded.mapExtent unifyLeft a) + (Unpacked.mapExtent unifyRight b) + + +bandedBanded :: + (Unary.Natural subA, Unary.Natural superA) => + (Unary.Natural subB, Unary.Natural superB) => + (Extent.Measure measA, Extent.Measure measB) => + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Banded subA superA measA vertA horizA height fuse a -> + Banded subB superB measB vertB horizB fuse width a -> + Banded + (subA :+: subB) (superA :+: superB) + (ExtentPriv.MultiplyMeasure measA measB) + (ExtentPriv.Multiply vertA vertB) + (ExtentPriv.Multiply horizA horizB) + height width a +bandedBanded a b = + case unifyFactors a b of + ((ExtentPriv.MeasureFact, ExtentPriv.TagFact, ExtentPriv.TagFact), + (unifyLeft, unifyRight)) -> + Banded.multiply + (Banded.mapExtent unifyLeft a) + (Banded.mapExtent unifyRight b) + +bandedUpper :: + (Unary.Natural superA, Unary.Natural superB, + (Unary.Succ superA :+: superB) ~ superC, + Shape.C size, Eq size, Class.Floating a) => + Banded.UnitUpper (Unary.Succ superA) size a -> + Banded.UnitUpper (Unary.Succ superB) size a -> + Banded.UnitUpper (Unary.Succ superC) size a +bandedUpper a b = + case (snd $ MatrixShape.bandedOffDiagonals $ ArrMatrix.shape a, + snd $ MatrixShape.bandedOffDiagonals $ ArrMatrix.shape b) of + (superA,superB) -> + case Proof.addNat (natFromProxy superA) (natFromProxy $ prev superB) of + Proof.Nat -> ArrMatrix.lift2 BandedBasic.multiply a b + +bandedLower :: + (Unary.Natural subA, Unary.Natural subB, + (Unary.Succ subA :+: subB) ~ subC, + Shape.C size, Eq size, Class.Floating a) => + Banded.UnitLower (Unary.Succ subA) size a -> + Banded.UnitLower (Unary.Succ subB) size a -> + Banded.UnitLower (Unary.Succ subC) size a +bandedLower a b = + case (fst $ MatrixShape.bandedOffDiagonals $ ArrMatrix.shape a, + fst $ MatrixShape.bandedOffDiagonals $ ArrMatrix.shape b) of + (subA,subB) -> + case Proof.addNat (natFromProxy subA) (natFromProxy $ prev subB) of + Proof.Nat -> ArrMatrix.lift2 BandedBasic.multiply a b + +prev :: UnaryProxy (Succ x) -> UnaryProxy x +prev Proxy = Proxy + + +unifyFactors :: + (Matrix.Box typA, Matrix.Box typB) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (ExtentPriv.MultiplyMeasure measA measB ~ measC) => + (ExtentPriv.Multiply vertA vertB ~ vertC) => + (ExtentPriv.Multiply horizA horizB ~ horizC) => + Matrix typA xlA xuA lowerA upperA measA vertA horizA height fuse a -> + Matrix typB xlB xuB lowerB upperB measB vertB horizB fuse width a -> + ((ExtentPriv.MeasureFact measC, + ExtentPriv.TagFact vertC, ExtentPriv.TagFact horizC), + (Extent.Map measA vertA horizA measC vertC horizC height fuse, + Extent.Map measB vertB horizB measC vertC horizC fuse width)) +unifyFactors a b = ExtentStrict.unifiers (Matrix.extent a) (Matrix.extent b) + + +unflex :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + Full.Unpacked property lower upper meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a +unflex = ArrMatrix.liftUnpacked1 id + +flex :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + ArrMatrix.Full meas vert horiz height width a -> + Full.Unpacked property lower upper meas vert horiz height width a +flex = ArrMatrix.liftUnpacked1 id + + +property :: + (Omni.Property property) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + Omni.PropertySingleton property +property _ = Omni.propertySingleton diff --git a/src/Numeric/LAPACK/Matrix/Array/Triangular.hs b/src/Numeric/LAPACK/Matrix/Array/Triangular.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Array/Triangular.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Numeric.LAPACK.Matrix.Array.Triangular where - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Array (ArrayMatrix) -import Numeric.LAPACK.Matrix.Shape.Private (NonUnit, Unit) - - -type Hermitian sh = ArrayMatrix (MatrixShape.Hermitian sh) - -type Lower sh = FlexLower NonUnit sh -type Upper sh = FlexUpper NonUnit sh -type Symmetric sh = FlexSymmetric NonUnit sh -type Diagonal sh = FlexDiagonal NonUnit sh - -type UnitLower sh = FlexLower Unit sh -type UnitUpper sh = FlexUpper Unit sh - -type FlexDiagonal diag sh = - ArrayMatrix - (MatrixShape.Triangular MatrixShape.Empty diag MatrixShape.Empty sh) -type FlexLower diag sh = ArrayMatrix (MatrixShape.LowerTriangular diag sh) -type FlexUpper diag sh = ArrayMatrix (MatrixShape.UpperTriangular diag sh) -type FlexSymmetric diag sh = ArrayMatrix (MatrixShape.FlexSymmetric diag sh) - -type Triangular lo diag up sh = - ArrayMatrix (MatrixShape.Triangular lo diag up sh) diff --git a/src/Numeric/LAPACK/Matrix/Array/Unpacked.hs b/src/Numeric/LAPACK/Matrix/Array/Unpacked.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Array/Unpacked.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TypeOperators #-} +module Numeric.LAPACK.Matrix.Array.Unpacked where + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Plain as Plain +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Shape.Private (Unchecked) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) + + + +type Unpacked property lower upper meas vert horiz height width = + ArrMatrix.ArrayMatrix Layout.Unpacked + property lower upper meas vert horiz height width +type Quadratic property lower upper sh = + Unpacked property lower upper + Extent.Shape Extent.Small Extent.Small sh sh +{- | +We do not support unit diagonal tag for trapezoids, +because unit diagonal is not preserved by multiplication of trapezoids. +-} +type LowerTrapezoid meas vert horiz height width = + Unpacked Omni.Arbitrary Layout.Filled Layout.Empty + meas vert horiz height width +type UpperTrapezoid meas vert horiz height width = + Unpacked Omni.Arbitrary Layout.Empty Layout.Filled + meas vert horiz height width + + +recheck :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Unpacked property lower upper + meas vert horiz (Unchecked height) (Unchecked width) a -> + Unpacked property lower upper meas vert horiz height width a +recheck = ArrMatrix.liftUnpacked1 Basic.recheck + +uncheck :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Unpacked property lower upper meas vert horiz height width a -> + Unpacked property lower upper + meas vert horiz (Unchecked height) (Unchecked width) a +uncheck = ArrMatrix.liftUnpacked1 Basic.uncheck + + +fillLower :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + Unpacked property lower upper meas vert horiz height width a -> + Unpacked property Layout.Filled upper meas vert horiz height width a +fillLower = ArrMatrix.liftUnpacked1 id + +fillUpper :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + Unpacked property lower upper meas vert horiz height width a -> + Unpacked property lower Layout.Filled meas vert horiz height width a +fillUpper = ArrMatrix.liftUnpacked1 id + + +mapExtent :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Unpacked property lower upper measA vertA horizA height width a -> + Unpacked property lower upper measB vertB horizB height width a +mapExtent = ArrMatrix.liftUnpacked1 . Plain.mapExtent . ExtentStrict.apply + +transpose :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Unpacked property lower upper meas vert horiz height width a -> + Unpacked property upper lower meas horiz vert width height a +transpose = ArrMatrix.liftUnpacked1 Basic.transpose + +swapMultiply :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (matrix -> + Unpacked propertyA upperA lowerA measA horizA vertA widthA heightA a -> + Unpacked propertyB upperB lowerB measB horizB vertB widthB heightB a) -> + Unpacked propertyA lowerA upperA measA vertA horizA heightA widthA a -> + matrix -> + Unpacked propertyB lowerB upperB measB vertB horizB heightB widthB a +swapMultiply multiplyTrans a b = transpose $ multiplyTrans b $ transpose a + + +takeTopLeft :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic property lower upper (sh0::+sh1) a -> + Quadratic property lower upper sh0 a +takeTopLeft = + ArrMatrix.liftUnpacked1 $ + Basic.recheck . Square.fromFull . Basic.uncheck . + Basic.takeTop . Basic.takeLeft . Matrix.fromFull + +takeTopRight :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic property lower upper (sh0::+sh1) a -> ArrMatrix.General sh0 sh1 a +takeTopRight = + ArrMatrix.liftUnpacked1 $ + Basic.takeTop . Basic.takeRight . Matrix.fromFull + +takeBottomLeft :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic property lower upper (sh0::+sh1) a -> ArrMatrix.General sh1 sh0 a +takeBottomLeft = + ArrMatrix.liftUnpacked1 $ + Basic.takeBottom . Basic.takeLeft . Matrix.fromFull + +takeBottomRight :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic property lower upper (sh0::+sh1) a -> + Quadratic property lower upper sh1 a +takeBottomRight = + ArrMatrix.liftUnpacked1 $ + Basic.recheck . Square.fromFull . Basic.uncheck . + Basic.takeBottom . Basic.takeRight . Matrix.fromFull + + +multiplyVector :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Unpacked property lower upper meas vert horiz height width a -> + Vector width a -> Vector height a +multiplyVector = Basic.multiplyVector . ArrMatrix.unpackedToVector + +multiply :: + (Omni.Property propertyA, Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Property propertyB, Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Property propertyC, Omni.Strip lowerC, Omni.Strip upperC) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, + Shape.C fuse, Eq fuse, + Shape.C width, + Class.Floating a) => + Unpacked propertyA lowerA upperA meas vert horiz height fuse a -> + Unpacked propertyB upperB lowerB meas vert horiz fuse width a -> + Unpacked propertyC upperC lowerC meas vert horiz height width a +multiply = ArrMatrix.liftUnpacked2 Basic.multiply diff --git a/src/Numeric/LAPACK/Matrix/Banded.hs b/src/Numeric/LAPACK/Matrix/Banded.hs --- a/src/Numeric/LAPACK/Matrix/Banded.hs +++ b/src/Numeric/LAPACK/Matrix/Banded.hs @@ -1,13 +1,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Banded ( Banded, - General, - Square, - Upper, - Lower, + FlexBanded, + Banded.General, + Banded.Square, + Banded.Upper, Banded.UnitUpper, + Banded.Lower, Banded.UnitLower, Diagonal, - Hermitian, + Banded.FlexDiagonal, + Banded.RectangularDiagonal, + Banded.Hermitian, + Banded.HermitianPosSemidef, + Banded.HermitianPosDef, + Banded.FlexHermitian, height, width, fromList, squareFromList, @@ -16,9 +23,13 @@ mapExtent, diagonal, takeDiagonal, + forceOrder, + noUnit, toFull, toLowerTriangular, toUpperTriangular, + takeTopLeftSquare, + takeBottomRightSquare, transpose, adjoint, multiplyVector, @@ -32,35 +43,42 @@ import qualified Numeric.LAPACK.Matrix.Banded.Linear as Linear import qualified Numeric.LAPACK.Matrix.Banded.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Array.Triangular as Tri +import qualified Numeric.LAPACK.Matrix.Array.Banded as Banded +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as Triangular import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Array.Banded - (Banded, General, Square, Lower, Upper, Diagonal, Hermitian) -import Numeric.LAPACK.Matrix.Array (Full) -import Numeric.LAPACK.Matrix.Shape.Private (Order, UnaryProxy) +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array.Banded (FlexBanded, Banded, Diagonal) +import Numeric.LAPACK.Matrix.Array (Full, diagTag) +import Numeric.LAPACK.Matrix.Layout.Private (Order, UnaryProxy) import Numeric.LAPACK.Vector (Vector) import qualified Numeric.Netlib.Class as Class +import qualified Type.Data.Num.Unary.Proof as Proof import qualified Type.Data.Num.Unary as Unary import Type.Data.Num.Unary ((:+:)) +import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) height :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width a -> height -height = MatrixShape.bandedHeight . ArrMatrix.shape + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width a -> height +height = Omni.height . ArrMatrix.shape width :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width a -> width -width = MatrixShape.bandedWidth . ArrMatrix.shape + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width a -> width +width = Omni.width . ArrMatrix.shape @@ -68,49 +86,61 @@ (Unary.Natural sub, Unary.Natural super, Shape.C height, Shape.C width, Storable a) => (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> [a] -> - General sub super height width a + Banded.General sub super height width a fromList offDiag order height_ width_ = ArrMatrix.lift0 . Basic.fromList offDiag order height_ width_ squareFromList :: (Unary.Natural sub, Unary.Natural super, Shape.C size, Storable a) => (UnaryProxy sub, UnaryProxy super) -> Order -> size -> [a] -> - Square sub super size a + Banded.Square sub super size a squareFromList offDiag order size = ArrMatrix.lift0 . Basic.squareFromList offDiag order size lowerFromList :: (Unary.Natural sub, Shape.C size, Storable a) => - UnaryProxy sub -> Order -> size -> [a] -> Lower sub size a + UnaryProxy sub -> Order -> size -> [a] -> Banded.Lower sub size a lowerFromList numOff order size = ArrMatrix.lift0 . Basic.lowerFromList numOff order size upperFromList :: (Unary.Natural super, Shape.C size, Storable a) => - UnaryProxy super -> Order -> size -> [a] -> Upper super size a + UnaryProxy super -> Order -> size -> [a] -> Banded.Upper super size a upperFromList numOff order size = ArrMatrix.lift0 . Basic.upperFromList numOff order size mapExtent :: (Extent.C vertA, Extent.C horizA) => (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - Banded super sub vertA horizA height width a -> - Banded super sub vertB horizB height width a -mapExtent = ArrMatrix.lift1 . Basic.mapExtent + (Unary.Natural sub, Unary.Natural super) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Banded sub super measA vertA horizA height width a -> + Banded sub super measB vertB horizB height width a +mapExtent = ArrMatrix.lift1 . Basic.mapExtent . ExtentStrict.apply transpose :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width a -> - Banded super sub horiz vert width height a -transpose = ArrMatrix.lift1 Basic.transpose + (Omni.TriDiag diag, Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz) => + FlexBanded diag sub super meas vert horiz height width a -> + FlexBanded diag super sub meas horiz vert width height a +transpose a = + case diagTag a of + Omni.Arbitrary -> ArrMatrix.lift1 Basic.transpose a + Omni.Unit -> + case ArrMatrix.shape a of + Omni.UnitBandedTriangular _ -> ArrMatrix.lift1 Basic.transpose a adjoint :: - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Banded sub super vert horiz height width a -> - Banded super sub horiz vert width height a -adjoint = ArrMatrix.lift1 Basic.adjoint + FlexBanded diag sub super meas vert horiz height width a -> + FlexBanded diag super sub meas horiz vert width height a +adjoint a = + case ArrMatrix.shape a of + Omni.Banded _ -> ArrMatrix.lift1 Basic.adjoint a + Omni.UnitBandedTriangular _ -> ArrMatrix.lift1 Basic.adjoint a + Omni.BandedHermitian _ -> a diagonal :: (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Diagonal sh a @@ -118,14 +148,15 @@ takeDiagonal :: (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => - Square sub super sh a -> Vector sh a + Banded.Square sub super sh a -> Vector sh a takeDiagonal = Basic.takeDiagonal . ArrMatrix.toVector multiplyVector :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Banded sub super vert horiz height width a -> + Banded sub super meas vert horiz height width a -> Vector width a -> Vector height a multiplyVector = Basic.multiplyVector . ArrMatrix.toVector @@ -134,51 +165,112 @@ Unary.Natural subB, Unary.Natural superB, (subA :+: subB) ~ subC, (superA :+: superB) ~ superC, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Banded subA superA vert horiz height fuse a -> - Banded subB superB vert horiz fuse width a -> - Banded subC superC vert horiz height width a -multiply = ArrMatrix.lift2 Basic.multiply + Banded subA superA meas vert horiz height fuse a -> + Banded subB superB meas vert horiz fuse width a -> + Banded subC superC meas vert horiz height width a +multiply a b = + case Layout.addOffDiagonals + (MatrixShape.bandedOffDiagonals $ ArrMatrix.shape a) + (MatrixShape.bandedOffDiagonals $ ArrMatrix.shape b) of + ((Proof.Nat, Proof.Nat), _numOffC) -> ArrMatrix.lift2 Basic.multiply a b multiplyFull :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Banded sub super vert horiz height fuse a -> - Full vert horiz fuse width a -> Full vert horiz height width a + Banded sub super meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> Full meas vert horiz height width a multiplyFull = ArrMatrix.lift2 Basic.multiplyFull + +forceOrder :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Order -> + Banded sub super meas vert horiz height width a -> + Banded sub super meas vert horiz height width a +forceOrder = ArrMatrix.lift1 . Basic.forceOrder + toLowerTriangular :: (Unary.Natural sub, Shape.C sh, Class.Floating a) => - Lower sub sh a -> Tri.Lower sh a + Banded.Lower sub sh a -> Triangular.Lower sh a toLowerTriangular = ArrMatrix.lift1 Basic.toLowerTriangular toUpperTriangular :: (Unary.Natural super, Shape.C sh, Class.Floating a) => - Upper super sh a -> Tri.Upper sh a + Banded.Upper super sh a -> Triangular.Upper sh a toUpperTriangular = ArrMatrix.lift1 Basic.toUpperTriangular toFull :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Banded sub super vert horiz height width a -> - Full vert horiz height width a + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Banded sub super meas vert horiz height width a -> + Full meas vert horiz height width a toFull = ArrMatrix.lift1 Basic.toFull +takeTopLeftSquare :: + (Unary.Natural sub, Unary.Natural super, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Banded.Square sub super (sh0 ::+ sh1) a -> + Banded.Square sub super sh0 a +takeTopLeftSquare = ArrMatrix.lift1 Basic.takeTopLeftSquare +takeBottomRightSquare :: + (Unary.Natural sub, Unary.Natural super, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Banded.Square sub super (sh0 ::+ sh1) a -> + Banded.Square sub super sh1 a +takeBottomRightSquare = ArrMatrix.lift1 Basic.takeBottomRightSquare + + +noUnit :: Banded.UnitTriangular sub super sh a -> Banded.Square sub super sh a +noUnit a = + case ArrMatrix.shape a of + Omni.UnitBandedTriangular sh -> + ArrMatrix.Array $ Array.reshape (Omni.Banded sh) (ArrMatrix.unwrap a) + + +offDiagonals :: + (Unary.Natural sub, Unary.Natural super) => + Banded.Quadratic diag sub super sh a -> + (Unary.HeadSingleton sub, Unary.HeadSingleton super) +offDiagonals _ = (Unary.headSingleton, Unary.headSingleton) + solve :: - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + (Omni.TriDiag diag, Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Square sub super sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve = ArrMatrix.lift2 Linear.solve + Banded.Quadratic diag sub super sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve a = + case diagTag a of + diag@Omni.Unit -> + case ArrMatrix.shape a of + Omni.UnitBandedTriangular _ -> + ArrMatrix.lift2 (Linear.solveTriangular diag) a + diag@Omni.Arbitrary -> + case offDiagonals a of + (Unary.Zero, Unary.Zero) -> + ArrMatrix.lift2 (Linear.solveTriangular diag) a + (Unary.Zero, Unary.Succ) -> + ArrMatrix.lift2 (Linear.solveTriangular diag) a + (Unary.Succ, Unary.Zero) -> + ArrMatrix.lift2 (Linear.solveTriangular diag) a + (Unary.Succ, Unary.Succ) -> + ArrMatrix.lift2 Linear.solve a determinant :: - (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => - Square sub super sh a -> a -determinant = Linear.determinant . ArrMatrix.toVector + (Omni.TriDiag diag, Unary.Natural sub, Unary.Natural super, + Shape.C sh, Class.Floating a) => + Banded.Quadratic diag sub super sh a -> a +determinant a = + case ArrMatrix.diagTag a of + MatrixShape.Unit -> Scalar.one + MatrixShape.Arbitrary -> Linear.determinant $ ArrMatrix.toVector a diff --git a/src/Numeric/LAPACK/Matrix/Banded/Basic.hs b/src/Numeric/LAPACK/Matrix/Banded/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Banded/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Banded/Basic.hs @@ -7,20 +7,25 @@ Upper, Lower, Diagonal, + RectangularDiagonal, fromList, squareFromList, lowerFromList, upperFromList, mapExtent, + mapExtentSizes, mapHeight, mapWidth, identityFatOrder, + diagonalFat, diagonal, - fromDiagonal, takeDiagonal, + forceOrder, toFull, toLowerTriangular, toUpperTriangular, + takeTopLeftSquare, + takeBottomRightSquare, transpose, adjoint, multiplyVector, @@ -28,23 +33,26 @@ multiplyFull, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriangularPriv import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Generic as Mosaic +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos import qualified Numeric.LAPACK.Matrix.RowMajor as RowMajor import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Private as Private -import qualified Numeric.LAPACK.ShapeStatic as ShapeStatic -import Numeric.LAPACK.Matrix.Shape.Private +import qualified Data.Array.Comfort.Shape.Static as ShapeStatic +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor,ColumnMajor), transposeFromOrder, swapOnRowMajor, UnaryProxy, addOffDiagonals) import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Matrix.Extent.Private (Extent) import Numeric.LAPACK.Private - (fill, pointerSeq, pokeCInt, copySubMatrix, copySubTrapezoid) + (fill, pointerSeq, pokeCInt, + copyBlock, copySubMatrix, copySubTrapezoid) import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call @@ -61,6 +69,7 @@ import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import Data.Array.Comfort.Shape ((::+)((::+))) import Foreign.Marshal.Array (advancePtr) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) @@ -78,19 +87,21 @@ import Data.Ord.HT (limit) -type Banded sub super vert horiz height width = - Array (MatrixShape.Banded sub super vert horiz height width) +type Banded sub super meas vert horiz height width = + Array (Layout.Banded sub super meas vert horiz height width) type General sub super height width = - Array (MatrixShape.BandedGeneral sub super height width) + Array (Layout.BandedGeneral sub super height width) type Square sub super size = - Array (MatrixShape.BandedSquare sub super size) + Array (Layout.BandedSquare sub super size) type Lower sub size = Square sub TypeNum.U0 size type Upper super size = Square TypeNum.U0 super size type Diagonal size = Square TypeNum.U0 TypeNum.U0 size +type RectangularDiagonal meas vert horiz height width = + Banded TypeNum.U0 TypeNum.U0 meas vert horiz height width fromList :: @@ -122,118 +133,122 @@ fromListGen :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Storable a) => (UnaryProxy sub, UnaryProxy super) -> Order -> - Extent.Extent vert horiz height width -> [a] -> - Banded sub super vert horiz height width a + Extent.Extent meas vert horiz height width -> [a] -> + Banded sub super meas vert horiz height width a fromListGen offDiag order extent = - CheckedArray.fromList (MatrixShape.Banded offDiag order extent) + CheckedArray.fromList (Layout.Banded offDiag order extent) mapExtent :: (Extent.C vertA, Extent.C horizA) => (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - Banded super sub vertA horizA height width a -> - Banded super sub vertB horizB height width a -mapExtent f = Array.mapShape $ MatrixShape.bandedMapExtent f + Extent.Map measA vertA horizA measB vertB horizB height width -> + Banded sub super measA vertA horizA height width a -> + Banded sub super measB vertB horizB height width a +mapExtent f = Array.mapShape $ Layout.bandedMapExtent f +mapExtentSizes :: + (Extent.C vertA, Extent.C horizA) => + (Extent.C vertB, Extent.C horizB) => + (Extent measA vertA horizA heightA widthA -> + Extent measB vertB horizB heightB widthB) -> + Banded sub super measA vertA horizA heightA widthA a -> + Banded sub super measB vertB horizB heightB widthB a +mapExtentSizes f = + Array.mapShape + (\(Layout.Banded offDiag order extent) -> + Layout.Banded offDiag order $ f extent) + mapHeight :: - (Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Extent.C vert, Extent.C horiz) => (heightA -> heightB) -> - Banded super sub vert horiz heightA width a -> - Banded super sub vert horiz heightB width a -mapHeight f = - Array.mapShape - (\(MatrixShape.Banded offDiag order extent) -> - MatrixShape.Banded offDiag order $ Extent.mapHeight f extent) + Banded sub super Extent.Size vert horiz heightA width a -> + Banded sub super Extent.Size vert horiz heightB width a +mapHeight = mapExtentSizes . Extent.mapHeight mapWidth :: - (Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Extent.C vert, Extent.C horiz) => (widthA -> widthB) -> - Banded super sub vert horiz height widthA a -> - Banded super sub vert horiz height widthB a -mapWidth f = - Array.mapShape - (\(MatrixShape.Banded offDiag order extent) -> - MatrixShape.Banded offDiag order $ Extent.mapWidth f extent) + Banded sub super Extent.Size vert horiz height widthA a -> + Banded sub super Extent.Size vert horiz height widthB a +mapWidth = mapExtentSizes . Extent.mapWidth transpose :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width a -> - Banded super sub horiz vert width height a -transpose = Array.mapShape MatrixShape.bandedTranspose + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width a -> + Banded super sub meas horiz vert width height a +transpose = Array.mapShape Layout.bandedTranspose adjoint :: - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Banded sub super vert horiz height width a -> - Banded super sub horiz vert width height a + Banded sub super meas vert horiz height width a -> + Banded super sub meas horiz vert width height a adjoint = Vector.conjugate . transpose identityFatOrder :: (Unary.Natural sub, Unary.Natural super, Shape.C size, Class.Floating a) => Order -> size -> Square sub super size a -identityFatOrder order = +identityFatOrder order = diagonalFat order . Vector.one + +diagonalFat :: + (Unary.Natural sub, Unary.Natural super, Shape.C size, Class.Floating a) => + Order -> Vector size a -> Square sub super size a +diagonalFat order = case order of - RowMajor -> fromRowMajor Extent.square . identityStripe - ColumnMajor -> fromColumnMajor Extent.square . identityStripe + RowMajor -> fromRowMajor Extent.square . diagonalStripe + ColumnMajor -> fromColumnMajor Extent.square . diagonalStripe type Section sub super = - ShapeStatic.ZeroBased sub Shape.:+: () - Shape.:+: ShapeStatic.ZeroBased super + ShapeStatic.ZeroBased sub ::+ () + ::+ ShapeStatic.ZeroBased super -identityStripe :: +diagonalStripe :: (Unary.Natural sub, Unary.Natural super, Shape.C height, Class.Floating a) => - height -> RowMajor.Matrix height (Section sub super) a -identityStripe sh = + Vector height a -> RowMajor.Matrix height (Section sub super) a +diagonalStripe v = RowMajor.tensorProduct (Left NonConjugated) - (Vector.one sh) (Vector.unit Shape.static $ Right (Left ())) + v (Vector.unit Shape.static $ Right (Left ())) fromRowMajor :: (Unary.Natural sub, Unary.Natural super, Shape.C height) => - (height -> Extent.Extent vert horiz height width) -> + (height -> Extent.Extent meas vert horiz height width) -> RowMajor.Matrix height (Section sub super) a -> - Banded sub super vert horiz height width a + Banded sub super meas vert horiz height width a fromRowMajor extent = Array.mapShape (\(size, - ShapeStatic.ZeroBased kl Shape.:+: () - Shape.:+: ShapeStatic.ZeroBased ku) -> - MatrixShape.Banded (kl,ku) RowMajor $ extent size) + ShapeStatic.ZeroBased kl ::+ () + ::+ ShapeStatic.ZeroBased ku) -> + Layout.Banded (kl,ku) RowMajor $ extent size) fromColumnMajor :: (Unary.Natural sub, Unary.Natural super, Shape.C width) => - (width -> Extent.Extent vert horiz height width) -> + (width -> Extent.Extent meas vert horiz height width) -> RowMajor.Matrix width (Section super sub) a -> - Banded sub super vert horiz height width a + Banded sub super meas vert horiz height width a fromColumnMajor extent = Array.mapShape (\(size, - ShapeStatic.ZeroBased ku Shape.:+: () - Shape.:+: ShapeStatic.ZeroBased kl) -> - MatrixShape.Banded (kl,ku) ColumnMajor $ extent size) + ShapeStatic.ZeroBased ku ::+ () + ::+ ShapeStatic.ZeroBased kl) -> + Layout.Banded (kl,ku) ColumnMajor $ extent size) diagonal :: (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Diagonal sh a diagonal order (Array sh x) = - Array (MatrixShape.bandedSquare (Proxy,Proxy) order sh) x - -fromDiagonal :: - (Shape.C sh, Class.Floating a) => - TriangularPriv.FlexDiagonal diag sh a -> Diagonal sh a -fromDiagonal (Array (MatrixShape.Triangular _diag _uplo order sh) x) = - Array (MatrixShape.bandedSquare (Proxy,Proxy) order sh) x + Array (Layout.bandedSquare (Proxy,Proxy) order sh) x takeDiagonal :: (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => Square sub super sh a -> Vector sh a -takeDiagonal (Array (MatrixShape.Banded (sub,super) order extent) x) = +takeDiagonal (Array (Layout.Banded (sub,super) order extent) x) = let size = Extent.squareSize extent kl = integralFromProxy sub ku = integralFromProxy super @@ -255,19 +270,19 @@ multiplyVector :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, - Class.Floating a) => - Banded sub super vert horiz height width a -> + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Banded sub super meas vert horiz height width a -> Vector width a -> Vector height a multiplyVector - (Array (MatrixShape.Banded numOff order extent) a) (Array width x) = + (Array (Layout.Banded numOff order extent) a) (Array width x) = let height = Extent.height extent in Array.unsafeCreate height $ \yPtr -> do Call.assert "Banded.multiplyVector: shapes mismatch" (Extent.width extent == width) - let (m,n) = MatrixShape.dimensions $ MatrixShape.Full order extent - let (kl,ku) = MatrixShape.numOffDiagonals order numOff + let (m,n) = Layout.dimensions $ Layout.Full order extent + let (kl,ku) = Layout.numOffDiagonals order numOff evalContT $ do transPtr <- Call.char $ transposeFromOrder order mPtr <- Call.cint m @@ -291,20 +306,20 @@ Unary.Natural subB, Unary.Natural superB, (subA :+: subB) ~ subC, (superA :+: superB) ~ superC, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Banded subA superA vert horiz height fuse a -> - Banded subB superB vert horiz fuse width a -> - Banded subC superC vert horiz height width a + Banded subA superA meas vert horiz height fuse a -> + Banded subB superB meas vert horiz fuse width a -> + Banded subC superC meas vert horiz height width a multiply - (Array (MatrixShape.Banded numOffA orderA extentA) a) - (Array (MatrixShape.Banded numOffB orderB extentB) b) = + (Array (Layout.Banded numOffA orderA extentA) a) + (Array (Layout.Banded numOffB orderB extentB) b) = case (addOffDiagonals numOffA numOffB, Extent.fuse extentA extentB) of (_, Nothing) -> error "Banded.multiply: shapes mismatch" (((Proof.Nat, Proof.Nat), numOffC), Just extent) -> Array.unsafeCreate - (MatrixShape.Banded numOffC orderB extent) $ \cPtr -> + (Layout.Banded numOffC orderB extent) $ \cPtr -> let (height,fuse) = Extent.dimensions extentA width = Extent.width extentB in case (orderA,orderB) of @@ -437,18 +452,18 @@ multiplyFull :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Banded sub super vert horiz height fuse a -> - Matrix.Full vert horiz fuse width a -> Matrix.Full vert horiz height width a + Banded sub super meas vert horiz height fuse a -> + Matrix.Full meas vert horiz fuse width a -> Matrix.Full meas vert horiz height width a multiplyFull - (Array (MatrixShape.Banded numOff orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Banded numOff orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = case Extent.fuse extentA extentB of Nothing -> error "Banded.multiplyFull: shapes mismatch" Just extent -> - Array.unsafeCreate (MatrixShape.Full orderB extent) $ \cPtr -> + Array.unsafeCreate (Layout.Full orderB extent) $ \cPtr -> let (height,fuse) = Extent.dimensions extentA width = Extent.width extentB in case orderB of @@ -461,17 +476,17 @@ multiplyFullColumnMajor :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Shape.C fuse, Class.Floating a) => (UnaryProxy sub, UnaryProxy super) -> (height, fuse, width) -> - Order -> Extent.Extent vert horiz height fuse -> + Order -> Extent.Extent meas vert horiz height fuse -> ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () multiplyFullColumnMajor numOff (height,fuse,width) orderA extentA a b cPtr = do - let (m,n) = MatrixShape.dimensions $ MatrixShape.Full orderA extentA + let (m,n) = Layout.dimensions $ Layout.Full orderA extentA let k = Shape.size width - let (kl,ku) = MatrixShape.numOffDiagonals orderA numOff + let (kl,ku) = Layout.numOffDiagonals orderA numOff evalContT $ do transPtr <- Call.char $ transposeFromOrder orderA mPtr <- Call.cint m @@ -541,31 +556,94 @@ betaPtr yPtr incyPtr +forceOrder :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Order -> + Banded sub super meas vert horiz height width a -> + Banded sub super meas vert horiz height width a +forceOrder newOrder a = + if newOrder == Layout.bandedOrder (Array.shape a) + then a + else flipOrder a + +flipOrder :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Banded sub super meas vert horiz height width a -> + Banded sub super meas vert horiz height width a +flipOrder (Array (Layout.Banded (sub,super) order extent) a) = + Array.unsafeCreate + (Layout.Banded (sub,super) (Layout.flipOrder order) extent) $ + \bPtr -> + withForeignPtr a $ \aPtr -> do + let (height,width) = Extent.dimensions extent + let m = Shape.size height + let n = Shape.size width + let kl = integralFromProxy sub + let ku = integralFromProxy super + case order of + ColumnMajor -> flipOrderArray m n kl ku aPtr bPtr + RowMajor -> flipOrderArray n m ku kl aPtr bPtr + +flipOrderArray :: + (Class.Floating a) => Int -> Int -> Int -> Int -> Ptr a -> Ptr a -> IO () +flipOrderArray m n kl ku aPtr bPtr = evalContT $ do + let lda0 = kl+ku + let lda = lda0+1 + incxPtr <- Call.cint lda + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + dPtr <- Call.alloca + liftIO $ do + forM_ (take kl [0..]) $ \i -> do + let xPtr = advancePtr aPtr (lda0-i) + let yPtr = advancePtr bPtr i + let left = min m $ kl-i + let right = min m $ n+kl-i + pokeCInt dPtr left + BlasGen.copy dPtr zPtr inczPtr yPtr incxPtr + pokeCInt dPtr (right-left) + BlasGen.copy dPtr xPtr incxPtr + (advancePtr yPtr (left*lda)) incxPtr + pokeCInt dPtr (m-right) + BlasGen.copy dPtr zPtr inczPtr + (advancePtr yPtr (right*lda)) incxPtr + forM_ (take (ku+1) [0..]) $ \i -> do + let xPtr = advancePtr aPtr (ku+lda0*i) + let yPtr = advancePtr bPtr (kl+i) + let right = min m $ max 0 (n-i) + pokeCInt dPtr right + BlasGen.copy dPtr xPtr incxPtr yPtr incxPtr + pokeCInt dPtr (m-right) + BlasGen.copy dPtr zPtr inczPtr + (advancePtr yPtr (right*lda)) incxPtr + + toLowerTriangular :: (Unary.Natural sub, Shape.C sh, Class.Floating a) => Lower sub sh a -> Triangular.Lower sh a toLowerTriangular = - Triangular.transpose . toUpperTriangular . transpose + Mosaic.transpose . toUpperTriangular . transpose toUpperTriangular :: (Unary.Natural super, Shape.C sh, Class.Floating a) => Upper super sh a -> Triangular.Upper sh a -toUpperTriangular (Array (MatrixShape.Banded (_sub,super) order extent) a) = +toUpperTriangular (Array (Layout.Banded (_sub,super) order extent) a) = let size = Extent.squareSize extent - in Array.unsafeCreateWithSize - (MatrixShape.Triangular MatrixShape.NonUnit MatrixShape.upper - order size) $ - TriangularPriv.fromBanded - (integralFromProxy super) order (Shape.size size) a + in Array.unsafeCreateWithSize (Layout.upperTriangular order size) $ + Mos.fromBanded (integralFromProxy super) order (Shape.size size) a toFull :: (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Banded sub super vert horiz height width a -> - Matrix.Full vert horiz height width a -toFull (Array (MatrixShape.Banded (sub,super) order extent) a) = - Array.unsafeCreateWithSize (MatrixShape.Full order extent) $ \bSize bPtr -> + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Banded sub super meas vert horiz height width a -> + Matrix.Full meas vert horiz height width a +toFull (Array (Layout.Banded (sub,super) order extent) a) = + Array.unsafeCreateWithSize (Layout.Full order extent) $ \bSize bPtr -> withForeignPtr a $ \aPtr -> do let (height,width) = Extent.dimensions extent fill zero bSize bPtr @@ -634,3 +712,34 @@ copySubTrapezoid 'U' n n lda (advancePtr aPtr d) ldb (advancePtr bPtr d) + + +takeTopLeftSquare :: + (Unary.Natural sub, Unary.Natural super, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Square sub super (sh0 ::+ sh1) a -> + Square sub super sh0 a +takeTopLeftSquare (Array (Layout.Banded offDiag order extent) a) = + case Extent.squareSize extent of + sh0 ::+ _sh1 -> + Array.unsafeCreateWithSize + (Layout.Banded offDiag order (Extent.square sh0)) $ + \n bPtr -> withForeignPtr a $ \aPtr -> copyBlock n aPtr bPtr + +takeBottomRightSquare :: + (Unary.Natural sub, Unary.Natural super, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + Square sub super (sh0 ::+ sh1) a -> + Square sub super sh1 a +takeBottomRightSquare (Array (Layout.Banded (sub,super) order extent) a) = + case Extent.squareSize extent of + sh0 ::+ sh1 -> + Array.unsafeCreateWithSize + (Layout.Banded (sub,super) order (Extent.square sh1)) $ + \n bPtr -> + withForeignPtr a $ \aPtr -> + copyBlock n + (advancePtr aPtr $ + (integralFromProxy sub + 1 + integralFromProxy super) + * Shape.size sh0) + bPtr diff --git a/src/Numeric/LAPACK/Matrix/Banded/Linear.hs b/src/Numeric/LAPACK/Matrix/Banded/Linear.hs --- a/src/Numeric/LAPACK/Matrix/Banded/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/Banded/Linear.hs @@ -2,16 +2,18 @@ module Numeric.LAPACK.Matrix.Banded.Linear ( solve, solveColumnMajor, + solveTriangular, determinant, ) where import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Permutation.Private as Perm import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, withInfo) -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor,ColumnMajor), transposeFromOrder) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Private (copySubMatrix) @@ -36,14 +38,15 @@ solve :: - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => Banded.Square sub super sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve (Array (MatrixShape.Banded numOff order extent) a) = + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve (Array (Layout.Banded numOff order extent) a) = solver "Banded.solve" (Extent.squareSize extent) $ \n nPtr nrhsPtr xPtr ldxPtr -> do - let (kl,ku) = MatrixShape.numOffDiagonals order numOff + let (kl,ku) = Layout.numOffDiagonals order numOff let k = kl+1+ku let ldab = kl+k transPtr <- Call.char $ transposeFromOrder order @@ -62,12 +65,13 @@ abPtr ldabPtr ipivPtr xPtr ldxPtr solveColumnMajor :: - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => Banded.Square sub super sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a solveColumnMajor - (Array (MatrixShape.Banded (sub,super) ColumnMajor extent) a) = + (Array (Layout.Banded (sub,super) ColumnMajor extent) a) = solver "Banded.solve" (Extent.squareSize extent) $ \n nPtr nrhsPtr xPtr ldxPtr -> do let kl = integralFromProxy sub @@ -85,17 +89,40 @@ withInfo "gbsv" $ LapackGen.gbsv nPtr klPtr kuPtr nrhsPtr abPtr ldabPtr ipivPtr xPtr ldxPtr -solveColumnMajor (Array (MatrixShape.Banded _ RowMajor _) _) = +solveColumnMajor (Array (Layout.Banded _ RowMajor _) _) = error "Linear.Banded.solveColumnMajor: RowMajor intentionally unimplemented" +solveTriangular :: + (Omni.BandedTriangular sub super, Omni.TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + Omni.DiagSingleton diag -> + Banded.Square sub super sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solveTriangular diag (Array (Layout.Banded numOff order extent) a) = + solver "Banded.solveTriangular" (Extent.squareSize extent) $ + \ _n nPtr nrhsPtr xPtr ldxPtr -> do + let (kl,ku) = Layout.numOffDiagonals order numOff + let k = kl+ku + uploPtr <- Call.char $ if kl==0 then 'U' else 'L' + transPtr <- Call.char $ Layout.transposeFromOrder order + diagPtr <- Call.char $ Omni.charFromTriDiag diag + kPtr <- Call.cint k + abPtr <- ContT $ withForeignPtr a + ldabPtr <- Call.leadingDim (k+1) + liftIO $ + withInfo "tbtrs" $ + LapackGen.tbtrs uploPtr transPtr diagPtr nPtr kPtr nrhsPtr + abPtr ldabPtr xPtr ldxPtr + determinant :: (Unary.Natural sub, Unary.Natural super, Shape.C sh, Class.Floating a) => Banded.Square sub super sh a -> a -determinant (Array (MatrixShape.Banded numOff order extent) a) = +determinant (Array (Layout.Banded numOff order extent) a) = unsafePerformIO $ do let n = Shape.size $ Extent.squareSize extent evalContT $ do - let (kl,ku) = MatrixShape.numOffDiagonals order numOff + let (kl,ku) = Layout.numOffDiagonals order numOff let k = kl+1+ku let ldab = kl+k nPtr <- Call.cint n diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian.hs --- a/src/Numeric/LAPACK/Matrix/BandedHermitian.hs +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian.hs @@ -3,6 +3,15 @@ module Numeric.LAPACK.Matrix.BandedHermitian ( BandedHermitian, Transposition(..), + + Hermitian.Semidefinite, + Hermitian.assureFullRank, + Hermitian.assureAnyRank, + Hermitian.relaxSemidefinite, + Hermitian.relaxIndefinite, + Hermitian.assurePositiveDefiniteness, + Hermitian.relaxDefiniteness, + size, fromList, identity, @@ -10,6 +19,10 @@ takeDiagonal, toHermitian, toBanded, + forceOrder, + takeTopLeft, + takeBottomRight, + negate, multiplyVector, multiplyFull, gramian, @@ -22,14 +35,18 @@ import qualified Numeric.LAPACK.Matrix.BandedHermitian.Eigen as Eigen import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Array.Hermitian as Hermitian import qualified Numeric.LAPACK.Matrix.Array.Banded as Banded import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Shape as ExtShape import Numeric.LAPACK.Matrix.Array.Banded (Square) -import Numeric.LAPACK.Matrix.Array.Triangular (Hermitian) +import Numeric.LAPACK.Matrix.Array.Mosaic (FlexHermitian) import Numeric.LAPACK.Matrix.Array (Full) -import Numeric.LAPACK.Matrix.Shape.Private (Order, UnaryProxy) +import Numeric.LAPACK.Matrix.Layout.Private (Order, UnaryProxy, natFromProxy) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed, Transposed)) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) @@ -37,14 +54,17 @@ import qualified Numeric.Netlib.Class as Class import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof import qualified Type.Data.Num.Unary as Unary +import qualified Type.Data.Bool as TBool import Type.Data.Num.Unary ((:+:)) import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) -import Foreign.Storable (Storable) +import Data.Tuple.HT (mapPair, mapFst) -import Data.Tuple.HT (mapFst) +import Prelude hiding (negate) type BandedHermitian offDiag sh = Banded.Hermitian offDiag sh @@ -52,17 +72,19 @@ size :: BandedHermitian offDiag sh a -> sh -size = MatrixShape.bandedHermitianSize . ArrMatrix.shape +size = Omni.height . ArrMatrix.shape fromList :: - (Unary.Natural offDiag, Shape.C size, Storable a) => + (Unary.Natural offDiag, Shape.C size, Class.Floating a) => UnaryProxy offDiag -> Order -> size -> [a] -> BandedHermitian offDiag size a fromList numOff order size_ = - ArrMatrix.lift0 . Basic.fromList numOff order size_ + ArrMatrix.fromVector . Basic.fromList numOff order size_ -identity :: (Shape.C sh, Class.Floating a) => sh -> Diagonal sh a +identity :: + (Shape.C sh, Class.Floating a) => + sh -> Banded.HermitianPosDef TypeNum.U0 sh a identity = ArrMatrix.lift0 . Basic.identity diagonal :: @@ -70,40 +92,88 @@ diagonal = ArrMatrix.lift0 . Basic.diagonal takeDiagonal :: + (TBool.C neg, TBool.C zero, TBool.C pos) => (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - BandedHermitian offDiag size a -> Vector size (RealOf a) + Banded.FlexHermitian neg zero pos offDiag size a -> + Vector size (RealOf a) takeDiagonal = Basic.takeDiagonal . ArrMatrix.toVector toHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos) => (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - BandedHermitian offDiag size a -> Hermitian size a + Banded.FlexHermitian neg zero pos offDiag size a -> + FlexHermitian neg zero pos size a toHermitian = ArrMatrix.lift1 Basic.toHermitian toBanded :: - (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - BandedHermitian offDiag size a -> + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C size, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag size a -> Square offDiag offDiag size a toBanded = ArrMatrix.lift1 Basic.toBanded + +forceOrder :: + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C size, Class.Floating a) => + Order -> + Banded.FlexHermitian neg zero pos offDiag size a -> + Banded.FlexHermitian neg zero pos offDiag size a +forceOrder = ArrMatrix.lift1 . Basic.forceOrder + + +takeTopLeft :: + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag (sh0 ::+ sh1) a -> + Banded.FlexHermitian neg zero pos offDiag sh0 a +takeTopLeft = ArrMatrix.lift1 Basic.takeTopLeft + +takeBottomRight :: + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag (sh0 ::+ sh1) a -> + Banded.FlexHermitian neg zero pos offDiag sh1 a +takeBottomRight = ArrMatrix.lift1 Basic.takeBottomRight + + +negate :: + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag sh a -> + Banded.FlexHermitian pos zero neg offDiag sh a +negate = ArrMatrix.lift1 Vector.negate + + multiplyVector :: - (Unary.Natural offDiag, Shape.C size, Eq size, Class.Floating a) => - Transposition -> BandedHermitian offDiag size a -> + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Shape.C size, Eq size, Class.Floating a) => + Transposition -> + Banded.FlexHermitian neg zero pos offDiag size a -> Vector size a -> Vector size a -multiplyVector transposed = Basic.multiplyVector transposed . ArrMatrix.toVector +multiplyVector transposed = + Basic.multiplyVector transposed . ArrMatrix.toVector gramian :: (Shape.C size, Eq size, Class.Floating a, Unary.Natural sub, Unary.Natural super) => Square sub super size a -> - BandedHermitian (sub :+: super) size a -gramian = ArrMatrix.lift1 Basic.gramian + Banded.HermitianPosSemidef (sub :+: super) size a +gramian a = + case mapPair (natFromProxy,natFromProxy) $ + MatrixShape.bandedOffDiagonals $ ArrMatrix.shape a of + (sub,super) -> + case Proof.addNat sub super of + Proof.Nat -> ArrMatrix.lift1 Basic.gramian a multiplyFull :: - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + (TBool.C neg, TBool.C zero, TBool.C pos, + Unary.Natural offDiag, Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Transposition -> BandedHermitian offDiag height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Transposition -> + Banded.FlexHermitian neg zero pos offDiag height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a multiplyFull = ArrMatrix.lift2 . Basic.multiplyFull {- | @@ -113,19 +183,22 @@ (Unary.Natural k, Shape.Indexed sh, Class.Floating a) => Order -> sh -> [(RealOf a, (Shape.Index sh, Basic.StaticVector (Unary.Succ k) a))] -> - BandedHermitian k sh a + Banded.HermitianPosSemidef k sh a sumRank1 order sh = ArrMatrix.lift0 . Basic.sumRank1 order sh eigenvalues :: - (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => - BandedHermitian offDiag sh a -> Vector sh (RealOf a) + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + (ExtShape.Permutable sh, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag sh a -> Vector sh (RealOf a) eigenvalues = Eigen.values . ArrMatrix.toVector {- | For symmetric eigenvalue problems, @eigensystem@ and @schur@ coincide. -} eigensystem :: - (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => - BandedHermitian offDiag sh a -> (ArrMatrix.Square sh a, Vector sh (RealOf a)) + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + (ExtShape.Permutable sh, Class.Floating a) => + Banded.FlexHermitian neg zero pos offDiag sh a -> + (ArrMatrix.Square sh a, Vector sh (RealOf a)) eigensystem = mapFst ArrMatrix.lift0 . Eigen.decompose . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs --- a/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian/Basic.hs @@ -12,6 +12,9 @@ takeDiagonal, toHermitian, toBanded, + forceOrder, + takeTopLeft, + takeBottomRight, multiplyVector, multiplyFull, gramian, @@ -19,19 +22,20 @@ takeUpper, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded -import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriangularPriv +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos import qualified Numeric.LAPACK.Matrix.RowMajor as RowMajor import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector.Private as VectorPriv import qualified Numeric.LAPACK.Vector as Vector -import qualified Numeric.LAPACK.ShapeStatic as ShapeStatic +import qualified Data.Array.Comfort.Shape.Static as ShapeStatic import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder, +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor,ColumnMajor), uploFromOrder, UnaryProxy, natFromProxy) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed, Transposed), transposeOrder, @@ -40,7 +44,7 @@ import Numeric.LAPACK.Scalar (RealOf, zero, one) import Numeric.LAPACK.Private (fill, lacgv, caseRealComplexFunc, realPtr, - copyConjugate, condConjugate, condConjugateToTemp, + copyBlock, copyConjugate, condConjugate, condConjugateToTemp, pointerSeq, pokeCInt, copySubMatrix) import qualified Numeric.BLAS.FFI.Generic as BlasGen @@ -60,6 +64,7 @@ import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import Data.Array.Comfort.Shape ((::+)((::+))) import Foreign.Marshal.Array (advancePtr) import Foreign.C.Types (CInt, CChar) @@ -77,7 +82,7 @@ type BandedHermitian offDiag size = - Array (MatrixShape.BandedHermitian offDiag size) + Array (Layout.BandedHermitian offDiag size) type Diagonal size = BandedHermitian TypeNum.U0 size @@ -87,7 +92,7 @@ UnaryProxy offDiag -> Order -> size -> [a] -> BandedHermitian offDiag size a fromList numOff order size = - CheckedArray.fromList (MatrixShape.BandedHermitian numOff order size) + CheckedArray.fromList (Layout.BandedHermitian numOff order size) identityFatOrder :: (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => @@ -105,31 +110,31 @@ fromRowMajor :: (Unary.Natural offDiag, Shape.C size) => - RowMajor.Matrix size (() Shape.:+: ShapeStatic.ZeroBased offDiag) a -> + RowMajor.Matrix size (() ::+ ShapeStatic.ZeroBased offDiag) a -> BandedHermitian offDiag size a fromRowMajor = Array.mapShape - (\(size, () Shape.:+: ShapeStatic.ZeroBased k) -> - MatrixShape.BandedHermitian k RowMajor size) + (\(size, () ::+ ShapeStatic.ZeroBased k) -> + Layout.BandedHermitian k RowMajor size) fromColumnMajor :: (Unary.Natural offDiag, Shape.C size) => - RowMajor.Matrix size (ShapeStatic.ZeroBased offDiag Shape.:+: ()) a -> + RowMajor.Matrix size (ShapeStatic.ZeroBased offDiag ::+ ()) a -> BandedHermitian offDiag size a fromColumnMajor = Array.mapShape - (\(size, ShapeStatic.ZeroBased k Shape.:+: ()) -> - MatrixShape.BandedHermitian k ColumnMajor size) + (\(size, ShapeStatic.ZeroBased k ::+ ()) -> + Layout.BandedHermitian k ColumnMajor size) identity :: (Shape.C sh, Class.Floating a) => sh -> Diagonal sh a identity = - Array.mapShape (MatrixShape.BandedHermitian Proxy ColumnMajor) . Vector.one + Array.mapShape (Layout.BandedHermitian Proxy ColumnMajor) . Vector.one diagonal :: (Shape.C sh, Class.Floating a) => Vector sh (RealOf a) -> Diagonal sh a diagonal = - Array.mapShape (MatrixShape.BandedHermitian Proxy ColumnMajor) . + Array.mapShape (Layout.BandedHermitian Proxy ColumnMajor) . Vector.fromReal takeDiagonal :: @@ -145,7 +150,7 @@ (Unary.Natural offDiag, Shape.C size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => BandedHermitian offDiag size a -> Vector size ar -takeDiagonalAux (Array (MatrixShape.BandedHermitian numOff order size) a) = +takeDiagonalAux (Array (Layout.BandedHermitian numOff order size) a) = let k = integralFromProxy numOff in Array.unsafeCreateWithSize size $ \n yPtr -> evalContT $ do nPtr <- Call.cint n @@ -163,84 +168,134 @@ toHermitian :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => BandedHermitian offDiag size a -> Hermitian size a -toHermitian (Array (MatrixShape.BandedHermitian numOff order size) a) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order size) $ - TriangularPriv.fromBanded - (integralFromProxy numOff) order (Shape.size size) a +toHermitian (Array (Layout.BandedHermitian numOff order size) a) = + Array.unsafeCreateWithSize (Layout.hermitian order size) $ + Mos.fromBanded (integralFromProxy numOff) order (Shape.size size) a toBanded :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => BandedHermitian offDiag size a -> Banded.Square offDiag offDiag size a -toBanded (Array (MatrixShape.BandedHermitian numOff order sh) a) = +toBanded (Array (Layout.BandedHermitian numOff order sh) a) = Array.unsafeCreate - (MatrixShape.Banded (numOff,numOff) order (Extent.square sh)) $ \bPtr -> + (Layout.Banded (numOff,numOff) order (Extent.square sh)) $ \bPtr -> withForeignPtr a $ \aPtr -> - case order of - ColumnMajor -> toBandedColumnMajor numOff sh aPtr bPtr - RowMajor -> toBandedRowMajor numOff sh aPtr bPtr + let n = Shape.size sh + k = integralFromProxy numOff + lda = k+1 + ldb = 2*k+1 + in case order of + ColumnMajor -> do + copySubMatrix lda n lda aPtr ldb bPtr + columnToRowMajor copyConjugate + (n-1) k + lda (advancePtr aPtr (k+1)) + ldb (advancePtr bPtr (k+1)) + fill zero k (advancePtr bPtr (ldb*n-k)) + RowMajor -> do + copySubMatrix lda n lda aPtr ldb (advancePtr bPtr k) + fill zero k bPtr + rowToColumnMajor copyConjugate + (n-1) k + lda (advancePtr aPtr 1) + ldb (advancePtr bPtr ldb) -toBandedColumnMajor :: +forceOrder :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - UnaryProxy offDiag -> size -> Ptr a -> Ptr a -> IO () -toBandedColumnMajor numOff size aPtr bPtr = do - let n = Shape.size size - let k = integralFromProxy numOff - let lda0 = k - let lda = lda0+1 - let ldb0 = 2*k - let ldb = ldb0+1 - copySubMatrix lda n lda aPtr ldb bPtr - evalContT $ do - incxPtr <- Call.cint lda0 - incyPtr <- Call.cint 1 - inczPtr <- Call.cint 0 - zPtr <- Call.number zero - nPtr <- Call.alloca - liftIO $ for_ (take n [0..]) $ \i -> do - let top = i+1 - let bottom = min n (i+k+1) - let xPtr = advancePtr aPtr ((i+1)*lda0+top+k-1) - let yPtr = advancePtr bPtr (i*ldb0+k) - pokeCInt nPtr (bottom-top) - copyConjugate nPtr xPtr incxPtr (advancePtr yPtr top) incyPtr - pokeCInt nPtr (i+k+1 - bottom) - BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr bottom) incyPtr + Order -> + BandedHermitian offDiag size a -> + BandedHermitian offDiag size a +forceOrder newOrder a = + if newOrder == Layout.bandedHermitianOrder (Array.shape a) + then a + else flipOrder a -toBandedRowMajor :: +flipOrder :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - UnaryProxy offDiag -> size -> Ptr a -> Ptr a -> IO () -toBandedRowMajor numOff size aPtr bPtr = do - let n = Shape.size size - let k = integralFromProxy numOff - let lda0 = k - let lda = lda0+1 - let ldb0 = 2*k - let ldb = ldb0+1 - copySubMatrix lda n lda aPtr ldb (advancePtr bPtr k) - evalContT $ do - incxPtr <- Call.cint lda0 - incyPtr <- Call.cint 1 - inczPtr <- Call.cint 0 - zPtr <- Call.number zero - nPtr <- Call.alloca - liftIO $ for_ (take n [0..]) $ \i -> do - let left = max 0 (i-k) - let xPtr = advancePtr aPtr (left*lda0+i) - let yPtr = advancePtr bPtr (i*ldb0) - pokeCInt nPtr (k-i+left) - BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr i) incyPtr - pokeCInt nPtr (i-left) - copyConjugate nPtr xPtr incxPtr (advancePtr yPtr (left+k)) incyPtr + BandedHermitian offDiag size a -> + BandedHermitian offDiag size a +flipOrder (Array (Layout.BandedHermitian numOff order sh) a) = + Array.unsafeCreate + (Layout.BandedHermitian numOff (Layout.flipOrder order) sh) $ + \bPtr -> + withForeignPtr a $ \aPtr -> + let n = Shape.size sh + k = integralFromProxy numOff + 1 + in case order of + ColumnMajor -> columnToRowMajor BlasGen.copy n k k aPtr k bPtr + RowMajor -> rowToColumnMajor BlasGen.copy n k k aPtr k bPtr +columnToRowMajor :: + (Class.Floating a) => + (Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> IO ()) -> + Int -> Int -> Int -> Ptr a -> Int -> Ptr a -> IO () +columnToRowMajor copy n k lda aPtr ldb bPtr = evalContT $ do + incxPtr <- Call.cint (lda-1) + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + nPtr <- Call.alloca + liftIO $ for_ (take n [0..]) $ \i -> do + let split = min k $ n-i + let xPtr = advancePtr aPtr (i*lda + k-1) + let yPtr = advancePtr bPtr (i*ldb) + pokeCInt nPtr split + copy nPtr xPtr incxPtr yPtr incyPtr + pokeCInt nPtr (k - split) + BlasGen.copy nPtr zPtr inczPtr (advancePtr yPtr split) incyPtr +rowToColumnMajor :: + (Class.Floating a) => + (Ptr CInt -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> IO ()) -> + Int -> Int -> Int -> Ptr a -> Int -> Ptr a -> IO () +rowToColumnMajor copy n k lda aPtr ldb bPtr = evalContT $ do + incxPtr <- Call.cint (lda-1) + incyPtr <- Call.cint 1 + inczPtr <- Call.cint 0 + zPtr <- Call.number zero + nPtr <- Call.alloca + liftIO $ for_ (take n [0..]) $ \i -> do + let split = max 0 (k-i-1) + let xPtr = advancePtr aPtr (i*lda + (split+1-k)*(lda-1)) + let yPtr = advancePtr bPtr (i*ldb) + pokeCInt nPtr split + BlasGen.copy nPtr zPtr inczPtr yPtr incyPtr + pokeCInt nPtr (k - split) + copy nPtr xPtr incxPtr (advancePtr yPtr split) incyPtr + + +takeTopLeft :: + (Unary.Natural offDiag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + BandedHermitian offDiag (sh0 ::+ sh1) a -> + BandedHermitian offDiag sh0 a +takeTopLeft + (Array (Layout.BandedHermitian numOff order (sh0 ::+ _sh1)) a) = + + Array.unsafeCreateWithSize (Layout.BandedHermitian numOff order sh0) $ + \n bPtr -> withForeignPtr a $ \aPtr -> copyBlock n aPtr bPtr + +takeBottomRight :: + (Unary.Natural offDiag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + BandedHermitian offDiag (sh0 ::+ sh1) a -> + BandedHermitian offDiag sh1 a +takeBottomRight + (Array (Layout.BandedHermitian numOff order (sh0 ::+ sh1)) a) = + + Array.unsafeCreateWithSize (Layout.BandedHermitian numOff order sh1) $ + \n bPtr -> + withForeignPtr a $ \aPtr -> + copyBlock n + (advancePtr aPtr $ (integralFromProxy numOff + 1) * Shape.size sh0) + bPtr + + multiplyVector :: (Unary.Natural offDiag, Shape.C size, Eq size, Class.Floating a) => Transposition -> BandedHermitian offDiag size a -> Vector size a -> Vector size a multiplyVector transposed - (Array (MatrixShape.BandedHermitian numOff order size) a) (Array sizeX x) = + (Array (Layout.BandedHermitian numOff order size) a) (Array sizeX x) = Array.unsafeCreateWithSize size $ \n yPtr -> do Call.assert "BandedHermitian.multiplyVector: shapes mismatch" @@ -271,7 +326,7 @@ BandedHermitian (sub :+: super) size a gramian a = case mapPair (natFromProxy,natFromProxy) $ - MatrixShape.bandedOffDiagonals $ Array.shape a of + Layout.bandedOffDiagonals $ Array.shape a of (sub,super) -> case (Proof.addNat sub super, Proof.addComm sub super) of (Proof.Nat, Proof.AddComm) -> @@ -280,14 +335,14 @@ fromUpperPart :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => Banded.Square offDiag offDiag size a -> BandedHermitian offDiag size a -fromUpperPart (Array (MatrixShape.Banded (sub,super) order extent) a) = +fromUpperPart (Array (Layout.Banded (sub,super) order extent) a) = let sh = Extent.squareSize extent n = Shape.size sh kl = integralFromProxy sub ku = integralFromProxy super lda = kl+1+ku ldb = ku+1 - in Array.unsafeCreate (MatrixShape.BandedHermitian super order sh) $ \bPtr -> + in Array.unsafeCreate (Layout.BandedHermitian super order sh) $ \bPtr -> withForeignPtr a $ \aPtr -> case order of ColumnMajor -> copySubMatrix ldb n lda aPtr ldb bPtr @@ -295,26 +350,26 @@ multiplyFull :: - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + (Unary.Natural offDiag, Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Transposition -> BandedHermitian offDiag height a -> - Matrix.Full vert horiz height width a -> - Matrix.Full vert horiz height width a + Matrix.Full meas vert horiz height width a -> + Matrix.Full meas vert horiz height width a multiplyFull transposed a b = - case MatrixShape.fullOrder $ Array.shape b of + case Layout.fullOrder $ Array.shape b of ColumnMajor -> multiplyFullSpecial transposed a b RowMajor -> multiplyFullGeneric transposed a b multiplyFullSpecial :: - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + (Unary.Natural offDiag, Extent.Measure meas, Extent.C vert, Extent.C horiz, Eq height, Shape.C height, Shape.C width, Class.Floating a) => Transposition -> BandedHermitian offDiag height a -> - Matrix.Full vert horiz height width a -> - Matrix.Full vert horiz height width a + Matrix.Full meas vert horiz height width a -> + Matrix.Full meas vert horiz height width a multiplyFullSpecial transposed - (Array (MatrixShape.BandedHermitian numOff orderA sizeA) a) - (Array (MatrixShape.Full orderB extentB) b) = - Array.unsafeCreate (MatrixShape.Full orderB extentB) $ \cPtr -> do + (Array (Layout.BandedHermitian numOff orderA sizeA) a) + (Array (Layout.Full orderB extentB) b) = + Array.unsafeCreate (Layout.Full orderB extentB) $ \cPtr -> do Call.assert "BandedHermitian.multiplyFull: shapes mismatch" (sizeA == Extent.height extentB) let (height,width) = Extent.dimensions extentB @@ -368,11 +423,11 @@ multiplyFullGeneric :: - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, + (Unary.Natural offDiag, Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Transposition -> BandedHermitian offDiag height a -> - Matrix.Full vert horiz height width a -> - Matrix.Full vert horiz height width a + Matrix.Full meas vert horiz height width a -> + Matrix.Full meas vert horiz height width a multiplyFullGeneric transposed a b = let (lower,upper) = (takeStrictLower a, takeUpper a) (lowerT,upperT) = @@ -380,8 +435,10 @@ Transposed -> (Banded.transpose upper, Banded.transpose lower) NonTransposed -> (lower,upper) in VectorPriv.mac one - (Banded.multiplyFull (Banded.mapExtent Extent.fromSquare lowerT) b) - (Banded.multiplyFull (Banded.mapExtent Extent.fromSquare upperT) b) + (Banded.multiplyFull + (Banded.mapExtent ExtentPriv.fromSquare lowerT) b) + (Banded.multiplyFull + (Banded.mapExtent ExtentPriv.fromSquare upperT) b) takeUpper :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => @@ -389,17 +446,18 @@ Banded.Square TypeNum.U0 offDiag size a takeUpper = Array.mapShape - (\(MatrixShape.BandedHermitian numOff order sh) -> - MatrixShape.bandedSquare (Proxy,numOff) order sh) + (\(Layout.BandedHermitian numOff order sh) -> + Layout.bandedSquare (Proxy,numOff) order sh) takeStrictLower :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => BandedHermitian offDiag size a -> Banded.Square offDiag TypeNum.U0 size a -takeStrictLower (Array (MatrixShape.BandedHermitian numOff order sh) x) = +takeStrictLower (Array (Layout.BandedHermitian numOff order sh) x) = Array.unsafeCreateWithSize - (MatrixShape.bandedSquare (numOff,Proxy) (flipOrder order) sh) $ - \size yPtr -> evalContT $ do + (Layout.bandedSquare + (numOff,Proxy) (Layout.flipOrder order) sh) $ + \size yPtr -> evalContT $ do let k = integralFromProxy numOff nPtr <- Call.cint $ Shape.size sh xPtr <- ContT $ withForeignPtr x @@ -443,7 +501,7 @@ UnaryProxy k -> SumRank1_ k sh ar a sumRank1Aux numOff order size xs = Array.unsafeCreateWithSize - (MatrixShape.BandedHermitian numOff order size) $ + (Layout.BandedHermitian numOff order size) $ \bSize aPtr -> evalContT $ do let k = integralFromProxy numOff let n = Shape.size size diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs b/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs --- a/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs +++ b/src/Numeric/LAPACK/Matrix/BandedHermitian/Eigen.hs @@ -6,10 +6,11 @@ import Numeric.LAPACK.Matrix.BandedHermitian.Basic (BandedHermitian) -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Shape as ExtShape import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), uploFromOrder) +import Numeric.LAPACK.Matrix.Layout.Private (uploFromOrder) import Numeric.LAPACK.Matrix.Modifier (conjugatedOnRowMajor) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) @@ -26,7 +27,6 @@ import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as ArrayIO import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) import Foreign.C.Types (CInt, CChar) @@ -40,7 +40,7 @@ values :: - (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => + (Unary.Natural offDiag, ExtShape.Permutable sh, Class.Floating a) => BandedHermitian offDiag sh a -> Vector sh (RealOf a) values = runTakeDiagonal $ @@ -49,10 +49,10 @@ (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) valuesAux :: - (Unary.Natural offDiag, Shape.C sh, + (Unary.Natural offDiag, ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => BandedHermitian offDiag sh a -> Vector sh ar -valuesAux (Array (MatrixShape.BandedHermitian numOff order size) a) = +valuesAux (Array (Layout.BandedHermitian numOff order size) a) = Array.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do let k = integralFromProxy numOff let lda = k+1 @@ -68,8 +68,9 @@ decompose :: - (Unary.Natural offDiag, Shape.C sh, Class.Floating a) => - BandedHermitian offDiag sh a -> (Matrix.Square sh a, Vector sh (RealOf a)) + (Unary.Natural offDiag, ExtShape.Permutable sh, Class.Floating a) => + BandedHermitian offDiag sh a -> + (Matrix.Square sh a, Vector sh (RealOf a)) decompose = getDecompose $ Class.switchFloating @@ -83,11 +84,11 @@ Decompose {getDecompose :: Decompose_ offDiag sh a} decomposeAux :: - (Unary.Natural offDiag, Shape.C sh, + (Unary.Natural offDiag, ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => Decompose_ offDiag sh a -decomposeAux (Array (MatrixShape.BandedHermitian numOff order size) a) = - Array.unsafeCreateWithSizeAndResult (MatrixShape.square ColumnMajor size) $ +decomposeAux (Array (Layout.BandedHermitian numOff order size) a) = + Array.unsafeCreateWithSizeAndResult (Layout.square Layout.ColumnMajor size) $ \_ zPtr -> ArrayIO.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs --- a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs +++ b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite.hs @@ -1,4 +1,11 @@ module Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite ( + Hermitian.Semidefinite, + Hermitian.assureFullRank, + Hermitian.assureAnyRank, + Hermitian.relaxSemidefinite, + Hermitian.relaxIndefinite, + Hermitian.assurePositiveDefiniteness, + Hermitian.relaxDefiniteness, solve, solveDecomposed, decompose, @@ -7,6 +14,7 @@ import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear as Linear +import qualified Numeric.LAPACK.Matrix.Array.Hermitian as Hermitian import qualified Numeric.LAPACK.Matrix.Array.Banded as Banded import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Extent as Extent @@ -22,9 +30,10 @@ solve :: (Unary.Natural offDiag, Shape.C size, Eq size, - Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => - Banded.Hermitian offDiag size a -> - Full vert horiz size nrhs a -> Full vert horiz size nrhs a + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C nrhs, Class.Floating a) => + Banded.HermitianPosDef offDiag size a -> + Full meas vert horiz size nrhs a -> Full meas vert horiz size nrhs a solve = ArrMatrix.lift2 Linear.solve {- | @@ -33,9 +42,10 @@ -} solveDecomposed :: (Unary.Natural offDiag, Shape.C size, Eq size, - Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C nrhs, Class.Floating a) => Banded.Upper offDiag size a -> - Full vert horiz size nrhs a -> Full vert horiz size nrhs a + Full meas vert horiz size nrhs a -> Full meas vert horiz size nrhs a solveDecomposed = ArrMatrix.lift2 Linear.solveDecomposed {- | @@ -43,10 +53,10 @@ -} decompose :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - Banded.Hermitian offDiag size a -> Banded.Upper offDiag size a + Banded.HermitianPosDef offDiag size a -> Banded.Upper offDiag size a decompose = ArrMatrix.lift1 Linear.decompose determinant :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => - Banded.Hermitian offDiag size a -> RealOf a + Banded.HermitianPosDef offDiag size a -> RealOf a determinant = Linear.determinant . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs --- a/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/BandedHermitianPositiveDefinite/Linear.hs @@ -7,13 +7,14 @@ ) where import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Linear.Private (solver) import Numeric.LAPACK.Matrix.BandedHermitian.Basic (BandedHermitian) import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) -import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) -import Numeric.LAPACK.Matrix.Shape.Private (uploFromOrder) +import Numeric.LAPACK.Matrix.Mosaic.Private (copyTriangleToTemp) +import Numeric.LAPACK.Matrix.Layout.Private (uploFromOrder) import Numeric.LAPACK.Matrix.Modifier (Conjugation(Conjugated)) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Scalar (RealOf, realPart) @@ -39,10 +40,11 @@ solve :: (Unary.Natural offDiag, Shape.C size, Eq size, - Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C nrhs, Class.Floating a) => BandedHermitian offDiag size a -> - Full vert horiz size nrhs a -> Full vert horiz size nrhs a -solve (Array (MatrixShape.BandedHermitian numOff orderA shA) a) = + Full meas vert horiz size nrhs a -> Full meas vert horiz size nrhs a +solve (Array (Layout.BandedHermitian numOff orderA shA) a) = solver "BandedHermitian.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do uploPtr <- Call.char $ uploFromOrder orderA let k = integralFromProxy numOff @@ -56,10 +58,11 @@ solveDecomposed :: (Unary.Natural offDiag, Shape.C size, Eq size, - Extent.C vert, Extent.C horiz, Shape.C nrhs, Class.Floating a) => + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C nrhs, Class.Floating a) => Banded.Upper offDiag size a -> - Full vert horiz size nrhs a -> Full vert horiz size nrhs a -solveDecomposed (Array (MatrixShape.Banded (_zero,numOff) orderA shA) a) = + Full meas vert horiz size nrhs a -> Full meas vert horiz size nrhs a +solveDecomposed (Array (Layout.Banded (_zero,numOff) orderA shA) a) = solver "BandedHermitian.solveDecomposed" (Extent.squareSize shA) $ \n nPtr nrhsPtr xPtr ldxPtr -> do uploPtr <- Call.char $ uploFromOrder orderA @@ -76,9 +79,9 @@ decompose :: (Unary.Natural offDiag, Shape.C size, Class.Floating a) => BandedHermitian offDiag size a -> Banded.Upper offDiag size a -decompose (Array (MatrixShape.BandedHermitian numOff order sh) a) = +decompose (Array (Layout.BandedHermitian numOff order sh) a) = Array.unsafeCreateWithSize - (MatrixShape.bandedSquare (Proxy,numOff) order sh) $ \bSize bPtr -> do + (Layout.bandedSquare (Proxy,numOff) order sh) $ \bSize bPtr -> do evalContT $ do let k = integralFromProxy numOff uploPtr <- Call.char $ uploFromOrder order @@ -106,5 +109,5 @@ Class.Floating a, RealOf a ~ ar, Class.Real ar) => BandedHermitian offDiag size a -> ar determinantAux = - (^(2::Int)) . product . map realPart . Array.toList . + (^(2::Int)) . Vector.product . Array.map realPart . Banded.takeDiagonal . decompose diff --git a/src/Numeric/LAPACK/Matrix/Basic.hs b/src/Numeric/LAPACK/Matrix/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Basic.hs @@ -2,19 +2,20 @@ {-# LANGUAGE TypeOperators #-} module Numeric.LAPACK.Matrix.Basic where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.RowMajor as RowMajor import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), transposeFromOrder, flipOrder) import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) import Numeric.LAPACK.Matrix.Private - (Full, Tall, Wide, General, fromFull, ShapeInt, revealOrder) + (Full, Tall, Wide, Square, General, fromFull, ShapeInt, revealOrder) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, zero, one) import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) +import Numeric.LAPACK.Matrix.Extent (Extent) import Numeric.LAPACK.Private (pointerSeq, copyTransposed, copySubMatrix, copyBlock) @@ -25,7 +26,7 @@ import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) import Foreign.Marshal.Array (advancePtr) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) @@ -37,89 +38,87 @@ caseTallWide :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Full vert horiz height width a -> + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width a -> Either (Tall height width a) (Wide height width a) caseTallWide (Array shape a) = either (Left . flip Array a) (Right . flip Array a) $ - MatrixShape.caseTallWide shape + Layout.caseTallWide shape transpose :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> Full horiz vert width height a -transpose = Array.mapShape MatrixShape.transpose + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> Full meas horiz vert width height a +transpose = Array.mapShape Layout.transpose adjoint :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> Full horiz vert width height a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> Full meas horiz vert width height a adjoint = transpose . Vector.conjugate swapMultiply :: - (Extent.C vertA, Extent.C vertB, Extent.C horizA, Extent.C horizB) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB) => (matrix -> - Full horizA vertA widthA heightA a -> - Full horizB vertB widthB heightB a) -> - Full vertA horizA heightA widthA a -> + Full measA horizA vertA widthA heightA a -> + Full measB horizB vertB widthB heightB a) -> + Full measA vertA horizA heightA widthA a -> matrix -> - Full vertB horizB heightB widthB a + Full measB vertB horizB heightB widthB a swapMultiply multiplyTrans a b = transpose $ multiplyTrans b $ transpose a +mapExtent :: + (Extent measA vertA horizA heightA widthA -> + Extent measB vertB horizB heightB widthB) -> + Full measA vertA horizA heightA widthA a -> + Full measB vertB horizB heightB widthB a +mapExtent f = + Array.mapShape + (\(Layout.Full order extent) -> + Layout.Full order $ f extent) + mapHeight :: - (Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Extent.C vert, Extent.C horiz) => (heightA -> heightB) -> - Full vert horiz heightA width a -> - Full vert horiz heightB width a -mapHeight f = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ Extent.mapHeight f extent) + Full Extent.Size vert horiz heightA width a -> + Full Extent.Size vert horiz heightB width a +mapHeight = mapExtent . Extent.mapHeight mapWidth :: - (Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Extent.C vert, Extent.C horiz) => (widthA -> widthB) -> - Full vert horiz height widthA a -> - Full vert horiz height widthB a -mapWidth f = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ Extent.mapWidth f extent) + Full Extent.Size vert horiz height widthA a -> + Full Extent.Size vert horiz height widthB a +mapWidth = mapExtent . Extent.mapWidth uncheck :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> - Full vert horiz (Unchecked height) (Unchecked width) a -uncheck = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ Extent.mapWrap Unchecked Unchecked extent) + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> + Full meas vert horiz (Unchecked height) (Unchecked width) a +uncheck = mapExtent $ Extent.mapWrap Unchecked Unchecked recheck :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz (Unchecked height) (Unchecked width) a -> - Full vert horiz height width a -recheck = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ Extent.recheck extent) + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz (Unchecked height) (Unchecked width) a -> + Full meas vert horiz height width a +recheck = mapExtent Extent.recheck singleRow :: Order -> Vector width a -> General () width a -singleRow order = Array.mapShape (MatrixShape.general order ()) +singleRow order = Array.mapShape (Layout.general order ()) singleColumn :: Order -> Vector height a -> General height () a -singleColumn order = Array.mapShape (flip (MatrixShape.general order) ()) +singleColumn order = Array.mapShape (flip (Layout.general order) ()) flattenRow :: General () width a -> Vector width a -flattenRow = Array.mapShape MatrixShape.fullWidth +flattenRow = Array.mapShape Layout.fullWidth flattenColumn :: General height () a -> Vector height a -flattenColumn = Array.mapShape MatrixShape.fullHeight +flattenColumn = Array.mapShape Layout.fullHeight liftRow :: Order -> @@ -147,15 +146,15 @@ forceRowMajor :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -forceRowMajor (Array shape@(MatrixShape.Full order extent) x) = + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + Full meas vert horiz height width a +forceRowMajor (Array shape@(Layout.Full order extent) x) = case order of RowMajor -> Array shape x ColumnMajor -> - Array.unsafeCreate (MatrixShape.Full RowMajor extent) $ \yPtr -> + Array.unsafeCreate (Layout.Full RowMajor extent) $ \yPtr -> withForeignPtr x $ \xPtr -> do let (height, width) = Extent.dimensions extent let n = Shape.size width @@ -163,11 +162,11 @@ Private.copyTransposed n m xPtr n yPtr forceOrder :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => Order -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a forceOrder order = case order of RowMajor -> forceRowMajor @@ -175,12 +174,12 @@ takeSub :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Shape.C height, Shape.C width, Class.Floating a) => heightA -> Int -> ForeignPtr a -> - MatrixShape.Full vert horiz height width -> - Full vert horiz height width a -takeSub heightA k a shape@(MatrixShape.Full order extentB) = + Layout.Full meas vert horiz height width -> + Full meas vert horiz height width a +takeSub heightA k a shape@(Layout.Full order extentB) = Array.unsafeCreateWithSize shape $ \blockSize bPtr -> withForeignPtr a $ \aPtr -> let ma = Shape.size heightA @@ -193,64 +192,58 @@ takeTop :: (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, Class.Floating a) => - Full vert Extent.Big (height0:+:height1) width a -> - Full vert Extent.Big height0 width a -takeTop (Array (MatrixShape.Full order extentA) a) = - let heightA@(heightB:+:_) = Extent.height extentA + Full Extent.Size vert Extent.Big (height0::+height1) width a -> + Full Extent.Size vert Extent.Big height0 width a +takeTop (Array (Layout.Full order extentA) a) = + let heightA@(heightB::+_) = Extent.height extentA extentB = Extent.reduceWideHeight heightB extentA - in takeSub heightA 0 a $ MatrixShape.Full order extentB + in takeSub heightA 0 a $ Layout.Full order extentB takeBottom :: (Extent.C vert, Shape.C height0, Shape.C height1, Shape.C width, Class.Floating a) => - Full vert Extent.Big (height0:+:height1) width a -> - Full vert Extent.Big height1 width a -takeBottom (Array (MatrixShape.Full order extentA) a) = - let heightA@(height0:+:heightB) = Extent.height extentA + Full Extent.Size vert Extent.Big (height0::+height1) width a -> + Full Extent.Size vert Extent.Big height1 width a +takeBottom (Array (Layout.Full order extentA) a) = + let heightA@(height0::+heightB) = Extent.height extentA extentB = Extent.reduceWideHeight heightB extentA - in takeSub heightA (Shape.size height0) a $ MatrixShape.Full order extentB + in takeSub heightA (Shape.size height0) a $ Layout.Full order extentB takeLeft :: (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, Class.Floating a) => - Full Extent.Big vert height (width0:+:width1) a -> - Full Extent.Big vert height width0 a + Full Extent.Size Extent.Big vert height (width0::+width1) a -> + Full Extent.Size Extent.Big vert height width0 a takeLeft = transpose . takeTop . transpose takeRight :: (Extent.C vert, Shape.C height, Shape.C width0, Shape.C width1, Class.Floating a) => - Full Extent.Big vert height (width0:+:width1) a -> - Full Extent.Big vert height width1 a + Full Extent.Size Extent.Big vert height (width0::+width1) a -> + Full Extent.Size Extent.Big vert height width1 a takeRight = transpose . takeBottom . transpose splitRows :: - (Extent.C vert, Shape.C width, Class.Floating a) => + (Extent.C vert, Extent.C horiz, Shape.C width, Class.Floating a) => Int -> - Full vert Extent.Big ShapeInt width a -> - Full vert Extent.Big (ShapeInt:+:ShapeInt) width a -splitRows k = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ - Extent.reduceWideHeight - (Shape.zeroBasedSplit k $ Extent.height extent) - extent) + Full Extent.Size vert horiz ShapeInt width a -> + Full Extent.Size vert horiz (ShapeInt::+ShapeInt) width a +splitRows = mapExtent . Extent.mapHeight . Shape.zeroBasedSplit takeRows, dropRows :: (Extent.C vert, Shape.C width, Class.Floating a) => Int -> - Full vert Extent.Big ShapeInt width a -> - Full vert Extent.Big ShapeInt width a + Full Extent.Size vert Extent.Big ShapeInt width a -> + Full Extent.Size vert Extent.Big ShapeInt width a takeRows k = takeTop . splitRows k dropRows k = takeBottom . splitRows k takeColumns, dropColumns :: (Extent.C horiz, Shape.C height, Class.Floating a) => Int -> - Full Extent.Big horiz height ShapeInt a -> - Full Extent.Big horiz height ShapeInt a + Full Extent.Size Extent.Big horiz height ShapeInt a -> + Full Extent.Size Extent.Big horiz height ShapeInt a takeColumns k = transpose . takeRows k . transpose dropColumns k = transpose . dropRows k . transpose @@ -264,12 +257,12 @@ Class.Floating a) => OrderBias -> Extent.AppendMode vertA vertB vertC height widthA widthB -> - Full vertA Extent.Big height widthA a -> - Full vertB Extent.Big height widthB a -> - Full vertC Extent.Big height (widthA:+:widthB) a + Full Extent.Size vertA Extent.Big height widthA a -> + Full Extent.Size vertB Extent.Big height widthB a -> + Full Extent.Size vertC Extent.Big height (widthA::+widthB) a beside orderBias (Extent.AppendMode appendMode) - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = let (heightA,widthA) = Extent.dimensions extentA (heightB,widthB) = Extent.dimensions extentB n = Shape.size heightA @@ -278,7 +271,7 @@ m = ma+mb create order act = Array.unsafeCreate - (MatrixShape.Full order $ appendMode extentA extentB) $ \cPtr -> + (Layout.Full order $ appendMode extentA extentB) $ \cPtr -> withForeignPtr a $ \aPtr -> withForeignPtr b $ \bPtr -> act aPtr bPtr cPtr $ advancePtr cPtr $ @@ -342,37 +335,53 @@ Class.Floating a) => OrderBias -> Extent.AppendMode horizA horizB horizC width heightA heightB -> - Full Extent.Big horizA heightA width a -> - Full Extent.Big horizB heightB width a -> - Full Extent.Big horizC (heightA:+:heightB) width a + Full Extent.Size Extent.Big horizA heightA width a -> + Full Extent.Size Extent.Big horizB heightB width a -> + Full Extent.Size Extent.Big horizC (heightA::+heightB) width a above orderBias appendMode a b = transpose $ beside orderBias appendMode (transpose a) (transpose b) stack :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Eq heightA, Shape.C heightB, Eq heightB, Shape.C widthA, Eq widthA, Shape.C widthB, Eq widthB, Class.Floating a) => - Full vert horiz heightA widthA a -> General heightA widthB a -> - General heightB widthA a -> Full vert horiz heightB widthB a -> - Full vert horiz (heightA:+:heightB) (widthA:+:widthB) a -stack a b c d = - Array.mapShape - (\(MatrixShape.Full order _) -> - MatrixShape.Full order $ + Full meas vert horiz heightA widthA a -> General heightA widthB a -> + General heightB widthA a -> Full meas vert horiz heightB widthB a -> + Full meas vert horiz (heightA::+heightB) (widthA::+widthB) a +stack = stackBiased RightBias RightBias + +stackMosaic :: + (Shape.C shA, Eq shA, Shape.C shB, Eq shB, Class.Floating a) => + Square shA a -> General shA shB a -> + General shB shA a -> Square shB a -> + Square (shA::+shB) a +stackMosaic = stackBiased LeftBias RightBias + +stackBiased :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C heightA, Eq heightA, Shape.C heightB, Eq heightB, + Shape.C widthA, Eq widthA, Shape.C widthB, Eq widthB, Class.Floating a) => + OrderBias -> OrderBias -> + Full meas vert horiz heightA widthA a -> General heightA widthB a -> + General heightB widthA a -> Full meas vert horiz heightB widthB a -> + Full meas vert horiz (heightA::+heightB) (widthA::+widthB) a +stackBiased vertBias horizBias a b c d = + mapExtent + (\ _ -> Extent.stack - (MatrixShape.fullExtent $ Array.shape a) - (MatrixShape.fullExtent $ Array.shape d)) $ - above RightBias Extent.appendAny - (beside RightBias Extent.appendAny (fromFull a) b) - (beside RightBias Extent.appendAny c (fromFull d)) + (Layout.fullExtent $ Array.shape a) + (Layout.fullExtent $ Array.shape d)) $ + above vertBias Extent.appendAny + (beside horizBias Extent.appendAny (fromFull a) b) + (beside horizBias Extent.appendAny c (fromFull d)) liftRowMajor :: - (Extent.C vert, Extent.C horiz) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Array (height, width) a -> Array (height, width) b) -> (Array (width, height) a -> Array (width, height) b) -> - Full vert horiz height width a -> - Full vert horiz height width b + Full meas vert horiz height width a -> + Full meas vert horiz height width b liftRowMajor fr fc a = either (Array.reshape (Array.shape a) . fr) @@ -380,28 +389,28 @@ revealOrder a scaleRows :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Vector height a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleRows x = liftRowMajor (RowMajor.scaleRows x) (RowMajor.scaleColumns x) scaleColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => Vector width a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleColumns x = transpose . scaleRows x . transpose scaleRowsComplex :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Real a) => Vector height a -> - Full vert horiz height width (Complex a) -> - Full vert horiz height width (Complex a) + Full meas vert horiz height width (Complex a) -> + Full meas vert horiz height width (Complex a) scaleRowsComplex x = liftRowMajor (RowMajor.recomplex . RowMajor.scaleRows x . RowMajor.decomplex) @@ -412,20 +421,20 @@ RowMajor.decomplex) scaleColumnsComplex :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Real a) => Vector width a -> - Full vert horiz height width (Complex a) -> - Full vert horiz height width (Complex a) + Full meas vert horiz height width (Complex a) -> + Full meas vert horiz height width (Complex a) scaleColumnsComplex x = transpose . scaleRowsComplex x . transpose scaleRowsReal :: - (Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => Vector height (RealOf a) -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleRowsReal = getScaleRowsReal $ Class.switchFloating @@ -438,33 +447,33 @@ ScaleRowsReal {getScaleRowsReal :: f (RealOf a) -> g a -> g a} scaleColumnsReal :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Class.Floating a) => Vector width (RealOf a) -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a scaleColumnsReal x = transpose . scaleRowsReal x . transpose multiplyVector :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, - Class.Floating a) => - Full vert horiz height width a -> Vector width a -> Vector height a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full meas vert horiz height width a -> Vector width a -> Vector height a multiplyVector a x = - let width = MatrixShape.fullWidth $ Array.shape a + let width = Layout.fullWidth $ Array.shape a in if width == Array.shape x then multiplyVectorUnchecked a x else error "multiplyVector: width shapes mismatch" multiplyVectorUnchecked :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> Vector width a -> Vector height a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> Vector width a -> Vector height a multiplyVectorUnchecked - (Array shape@(MatrixShape.Full order extent) a) (Array _ x) = + (Array shape@(Layout.Full order extent) a) (Array _ x) = Array.unsafeCreate (Extent.height extent) $ \yPtr -> do - let (m,n) = MatrixShape.dimensions shape + let (m,n) = Layout.dimensions shape let lda = m evalContT $ do transPtr <- Call.char $ transposeFromOrder order @@ -493,22 +502,22 @@ 'Matrix.generalizeTall' or 'Matrix.generalizeWide'. -} multiply, multiplyColumnMajor :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => - Full vert horiz height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a + Full meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a -- preserve order of the right factor multiply - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = case Extent.fuse extentA extentB of Nothing -> error "multiply: fuse shapes mismatch" Just extent -> - Array.unsafeCreate (MatrixShape.Full orderB extent) $ \cPtr -> do + Array.unsafeCreate (Layout.Full orderB extent) $ \cPtr -> do let (height,fuse) = Extent.dimensions extentA let width = Extent.width extentB @@ -523,12 +532,12 @@ -- always return ColumnMajor multiplyColumnMajor - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = case Extent.fuse extentA extentB of Nothing -> error "multiply: fuse shapes mismatch" Just extent -> - Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \cPtr -> do + Array.unsafeCreate (Layout.Full ColumnMajor extent) $ \cPtr -> do let (height,fuse) = Extent.dimensions extentA let width = Extent.width extentB diff --git a/src/Numeric/LAPACK/Matrix/Class.hs b/src/Numeric/LAPACK/Matrix/Class.hs --- a/src/Numeric/LAPACK/Matrix/Class.hs +++ b/src/Numeric/LAPACK/Matrix/Class.hs @@ -1,23 +1,27 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Class ( - SquareShape(toSquare, identityOrder, takeDiagonal), - identityFrom, - identityFromHeight, - identityFromWidth, + SquareShape(toSquare, takeDiagonal, mapSquareSize, identityFrom), + MapSize(mapHeight, mapWidth), trace, Complex(conjugate, fromReal, toComplex), + adjoint, ) where +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Type as Type -import qualified Numeric.LAPACK.Matrix.Plain.Class as Plain -import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Permutation as Permutation import qualified Numeric.LAPACK.Permutation.Private as Perm +import qualified Numeric.LAPACK.Permutation as PermPub import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Scalar as Scalar -import Numeric.LAPACK.Matrix.Array (ArrayMatrix) +import Numeric.LAPACK.Matrix.Type (Matrix) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, ComplexOf) @@ -28,80 +32,120 @@ class Complex typ where conjugate :: - (Class.Floating a) => Type.Matrix typ a -> Type.Matrix typ a + (Matrix typ xl xu lower upper meas vert horiz height width ~ matrix, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + matrix a -> matrix a fromReal :: - (Class.Floating a) => Type.Matrix typ (RealOf a) -> Type.Matrix typ a + (Matrix typ xl xu lower upper meas vert horiz height width ~ matrix, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + matrix (RealOf a) -> matrix a toComplex :: - (Class.Floating a) => Type.Matrix typ a -> Type.Matrix typ (ComplexOf a) + (Matrix typ xl xu lower upper meas vert horiz height width ~ matrix, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + matrix a -> matrix (ComplexOf a) -instance (Plain.Complex sh) => Complex (ArrMatrix.Array sh) where - conjugate = ArrMatrix.lift1 Plain.conjugate - fromReal = ArrMatrix.lift1 Plain.fromReal - toComplex = ArrMatrix.lift1 Plain.toComplex +instance Complex (ArrMatrix.Array pack property) where + conjugate (ArrMatrix.Array a) = ArrMatrix.Array $ Vector.conjugate a + fromReal (ArrMatrix.Array a) = ArrMatrix.Array $ Vector.fromReal a + toComplex (ArrMatrix.Array a) = ArrMatrix.Array $ Vector.toComplex a -instance (Shape.C shape) => Complex (Type.Scale shape) where - conjugate (Type.Scale sh m) = Type.Scale sh $ Scalar.conjugate m - fromReal (Type.Scale sh m) = Type.Scale sh $ Scalar.fromReal m - toComplex (Type.Scale sh m) = Type.Scale sh $ Scalar.toComplex m +instance Complex Matrix.Scale where + conjugate (Matrix.Scale sh m) = Matrix.Scale sh $ Scalar.conjugate m + fromReal (Matrix.Scale sh m) = Matrix.Scale sh $ Scalar.fromReal m + toComplex (Matrix.Scale sh m) = Matrix.Scale sh $ Scalar.toComplex m -instance (Shape.C shape) => Complex (Perm.Permutation shape) where +instance Complex Matrix.Permutation where conjugate = id - fromReal (Type.Permutation p) = Type.Permutation p - toComplex (Type.Permutation p) = Type.Permutation p + fromReal (Matrix.Permutation p) = Matrix.Permutation p + toComplex (Matrix.Permutation p) = Matrix.Permutation p +adjoint :: + (Matrix.Transpose typ, Complex typ) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + Matrix typ xu xl upper lower meas horiz vert width height a +adjoint = conjugate . Matrix.transpose -class SquareShape typ where + +class (Matrix.Box typ) => SquareShape typ where toSquare :: - (Type.HeightOf typ ~ sh, Class.Floating a) => - Type.Matrix typ a -> ArrMatrix.Square sh a - identityOrder :: - (Type.HeightOf typ ~ sh, Class.Floating a) => - MatrixShape.Order -> sh -> Type.Matrix typ a + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> ArrMatrix.Square sh a takeDiagonal :: - (Type.HeightOf typ ~ sh, Class.Floating a) => - Type.Matrix typ a -> Vector sh a + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> Vector sh a + {- | + The number of rows and columns + must be maintained by the shape mapping function. + -} + mapSquareSize :: + (Shape.C shA, Shape.C shB) => + (shA -> shB) -> + Matrix.Quadratic typ xl xu lower upper shA a -> + Matrix.Quadratic typ xl xu lower upper shB a + identityFrom :: + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> + Matrix.Quadratic typ xl xu lower upper sh a -instance (ArrMatrix.SquareShape sh) => SquareShape (ArrMatrix.Array sh) where - toSquare = ArrMatrix.lift1 Plain.toSquare - identityOrder order = ArrMatrix.lift0 . Plain.identityOrder order - takeDiagonal = Plain.takeDiagonal . ArrMatrix.toVector +instance SquareShape (ArrMatrix.Array pack property) where + toSquare a@(ArrMatrix.Array _) = OmniMatrix.toFull a + takeDiagonal a@(ArrMatrix.Array _) = OmniMatrix.takeDiagonal a + mapSquareSize f a@(ArrMatrix.Array _) = OmniMatrix.mapSquareSize f a + identityFrom a@(ArrMatrix.Array _) = OmniMatrix.identityFrom a -instance (Shape.C sh) => SquareShape (Type.Scale sh) where - toSquare (Type.Scale sh a) = - Triangular.toSquare $ Triangular.asDiagonal $ - Triangular.diagonal MatrixShape.RowMajor $ Vector.constant sh a - identityOrder _ sh = Type.Scale sh Scalar.one - takeDiagonal (Type.Scale sh a) = Vector.constant sh a +instance SquareShape Matrix.Scale where + toSquare (Matrix.Scale sh a) = + ArrMatrix.lift0 $ Banded.toFull $ + Banded.diagonal Layout.RowMajor $ Vector.constant sh a + takeDiagonal (Matrix.Scale sh a) = Vector.constant sh a + mapSquareSize f (Matrix.Scale sh a) = + Matrix.Scale (Layout.mapChecked "Scale.mapSquareSize" f sh) a + identityFrom (Matrix.Scale sh _a) = Matrix.Scale sh Scalar.one -instance (Shape.C sh) => SquareShape (Perm.Permutation sh) where - toSquare = Permutation.toMatrix - identityOrder _ = Permutation.identity - takeDiagonal = Perm.takeDiagonal . Permutation.toPermutation +instance SquareShape Matrix.Permutation where + toSquare (Matrix.Permutation perm) = PermPub.toMatrix perm + takeDiagonal a@(Matrix.Permutation _) = + Perm.takeDiagonal . Permutation.toPermutation $ a + mapSquareSize f (Matrix.Permutation perm) = + Matrix.Permutation $ Perm.mapSize f perm + identityFrom (Matrix.Permutation perm) = + Matrix.Permutation $ Perm.identity $ Perm.size perm -identityFrom :: - (Plain.SquareShape shape, ArrMatrix.ShapeOrder shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -identityFrom m = - identityOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape m) (Type.height m) +trace :: + (SquareShape typ, Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> a +trace = Vector.sum . takeDiagonal -identityFromHeight :: - (ArrMatrix.ShapeOrder shape, MatrixShape.Box shape, - MatrixShape.HeightOf shape ~ Type.HeightOf typ, SquareShape typ, - Class.Floating a) => - ArrayMatrix shape a -> Type.Matrix typ a -identityFromHeight m = - identityOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape m) (Type.height m) -identityFromWidth :: - (ArrMatrix.ShapeOrder shape, MatrixShape.Box shape, - MatrixShape.WidthOf shape ~ Type.HeightOf typ, SquareShape typ, - Class.Floating a) => - ArrayMatrix shape a -> Type.Matrix typ a -identityFromWidth m = - identityOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape m) (Type.width m) -trace :: - (SquareShape typ, Type.HeightOf typ ~ sh, Shape.C sh, Class.Floating a) => - Type.Matrix typ a -> a -trace = Vector.sum . takeDiagonal +class (Matrix.Box typ) => MapSize typ where + {- | + The number of rows and columns + must be maintained by the shape mapping function. + -} + mapHeight :: + (Extent.C vert, Extent.C horiz, + Shape.C heightA, Shape.C heightB, Shape.C width) => + (heightA -> heightB) -> + Matrix typ extraLower extraUpper lower upper + Extent.Size vert horiz heightA width a -> + Matrix typ extraLower extraUpper lower upper + Extent.Size vert horiz heightB width a + mapWidth :: + (Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C widthA, Shape.C widthB) => + (widthA -> widthB) -> + Matrix typ extraLower extraUpper lower upper + Extent.Size vert horiz height widthA a -> + Matrix typ extraLower extraUpper lower upper + Extent.Size vert horiz height widthB a + +instance MapSize (ArrMatrix.Array pack property) where + mapHeight f a@(ArrMatrix.Array _) = OmniMatrix.mapHeight f a + mapWidth f a@(ArrMatrix.Array _) = OmniMatrix.mapWidth f a diff --git a/src/Numeric/LAPACK/Matrix/Diagonal.hs b/src/Numeric/LAPACK/Matrix/Diagonal.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Diagonal.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Diagonal ( + Diagonal, FlexDiagonal, + fromList, autoFromList, + lift, + + stack, (%%%), + split, + + multiply, + + solve, + inverse, + determinant, + ) where + +import qualified Numeric.LAPACK.Matrix.Quadratic as Quad +import qualified Numeric.LAPACK.Matrix.Banded as Banded + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array.Banded (Diagonal, FlexDiagonal) +import Numeric.LAPACK.Matrix.Layout.Private (Order) +import Numeric.LAPACK.Matrix.Private (ShapeInt) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) + +import qualified Numeric.Netlib.Class as Class + +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable (Array) +import Data.Array.Comfort.Shape ((::+)) + +import Foreign.Storable (Storable) + + + +fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Diagonal sh a +fromList order sh = Banded.squareFromList (Proxy,Proxy) order sh + +autoFromList :: (Storable a) => Order -> [a] -> Diagonal ShapeInt a +autoFromList order = + ArrMatrix.Array . Array.mapShape (Omni.quadratic order) . Vector.autoFromList + + +takeDiagonal :: + (Omni.TriDiag diag) => + FlexDiagonal diag sh a -> Vector sh a +takeDiagonal = Array.mapShape Omni.squareSize . ArrMatrix.unwrap + + +lift :: + (Layout.Packing pack, + Shape.C sha, Shape.C shb, Class.Floating a, Class.Floating b) => + (Array sha a -> Array shb b) -> + FlexDiagonalP pack Omni.Arbitrary sha a -> + FlexDiagonalP pack Omni.Arbitrary shb b +lift f a = + case ArrMatrix.packTag a of + Layout.Packed -> + Quad.diagonal (ArrMatrix.order a) $ f $ Quad.takeDiagonal a + Layout.Unpacked -> + Quad.diagonal (ArrMatrix.order a) $ f $ Quad.takeDiagonal a + + +type FlexDiagonalP pack diag sh = + ArrMatrix.Quadratic pack diag Layout.Empty Layout.Empty sh + +infixr 2 %%% + +(%%%), stack :: + (Layout.Packing pack) => + (Omni.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexDiagonalP pack diag sh0 a -> + FlexDiagonalP pack diag sh1 a -> + FlexDiagonalP pack diag (sh0::+sh1) a +(%%%) = stack +stack a b = + let order = Omni.order $ ArrMatrix.shape b in + case ArrMatrix.packTag a of + Layout.Packed -> + ArrMatrix.Array $ + Array.mapShape (Omni.uncheckedDiagonal order) $ + Vector.append (takeDiagonal a) (takeDiagonal b) + Layout.Unpacked -> + let shc = + Layout.general order + (Unchecked $ Quad.size a) (Unchecked $ Quad.size b) + in ArrMatrix.liftUnpacked2 + (\a_ b_ -> + FullBasic.mapExtent Extent.recheckAppend $ + FullBasic.stack + (FullBasic.uncheck a_) (Vector.zero shc) + (Vector.zero $ Layout.inverse shc) (FullBasic.uncheck b_)) + a b + +split :: + (Omni.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexDiagonalP pack diag (sh0::+sh1) a -> + (FlexDiagonalP pack diag sh0 a, FlexDiagonalP pack diag sh1 a) +split a = (Quad.takeTopLeft a, Quad.takeBottomRight a) + + +multiply :: + (Omni.TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => + FlexDiagonal diag sh a -> FlexDiagonal diag sh a -> FlexDiagonal diag sh a +multiply = ArrMatrix.liftOmni2 Vector.mul + + +solve :: + (Omni.TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + FlexDiagonal diag height a -> + ArrMatrix.Full meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a +solve a = + case ArrMatrix.diagTag a of + Omni.Arbitrary -> Banded.solve a + Omni.Unit -> \b -> + if Omni.squareSize (ArrMatrix.shape a) == + Omni.height (ArrMatrix.shape b) + then b + else error ("Diagonal.solve: height shapes mismatch") + +inverse :: + (Omni.TriDiag diag, Shape.C sh, Class.Floating a) => + FlexDiagonal diag sh a -> FlexDiagonal diag sh a +inverse a = + case ArrMatrix.diagTag a of + Omni.Unit -> a + Omni.Arbitrary -> ArrMatrix.liftOmni1 Vector.recip a + +determinant :: + (Omni.TriDiag diag, Shape.C sh, Class.Floating a) => + FlexDiagonal diag sh a -> a +determinant a = + case ArrMatrix.diagTag a of + Omni.Unit -> Scalar.one + Omni.Arbitrary -> Vector.product $ ArrMatrix.unwrap a diff --git a/src/Numeric/LAPACK/Matrix/Divide.hs b/src/Numeric/LAPACK/Matrix/Divide.hs --- a/src/Numeric/LAPACK/Matrix/Divide.hs +++ b/src/Numeric/LAPACK/Matrix/Divide.hs @@ -1,17 +1,23 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Numeric.LAPACK.Matrix.Divide where -import qualified Numeric.LAPACK.Matrix.Plain.Divide as ArrDivide -import qualified Numeric.LAPACK.Matrix.Array.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Multiply as Multiply +import qualified Numeric.LAPACK.Matrix.Array.Divide as ArrDivide +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Permutation as PermMatrix -import qualified Numeric.LAPACK.Matrix.Multiply as Multiply -import qualified Numeric.LAPACK.Matrix.Type as Type -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix.Array (Full) -import Numeric.LAPACK.Matrix.Type (Matrix, scaleWithCheck) +import Numeric.LAPACK.Matrix.Type (scaleWithCheck) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed,Transposed), Inversion(Inverted)) @@ -19,113 +25,171 @@ import qualified Numeric.Netlib.Class as Class +import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Semigroup ((<>)) -class - (Type.Box typ, Type.HeightOf typ ~ Type.WidthOf typ) => - Determinant typ where - determinant :: (Class.Floating a) => Matrix typ a -> a +class (Matrix.Box typ) => Determinant typ xl xu where + determinant :: + (Omni.Strip lower, Omni.Strip upper) => + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> a -class (Type.Box typ, Type.HeightOf typ ~ Type.WidthOf typ) => Solve typ where +class (Matrix.Box typ) => Solve typ xl xu where {-# MINIMAL solve | solveLeft,solveRight #-} solve :: - (Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Transposition -> Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Class.Floating a) => + Transposition -> + Matrix.Quadratic typ xl xu lower upper height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a solve NonTransposed a b = solveRight a b - solve Transposed a b = Basic.transpose $ solveLeft (Basic.transpose b) a + solve Transposed a b = + Unpacked.transpose $ solveLeft (Unpacked.transpose b) a solveRight :: - (Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a solveRight = solve NonTransposed solveLeft :: - (Type.WidthOf typ ~ width, Eq width, Shape.C height, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Full vert horiz height width a -> - Matrix typ a -> Full vert horiz height width a - solveLeft = Basic.swapMultiply $ solve Transposed + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full meas vert horiz height width a -> + Matrix.Quadratic typ xl xu lower upper width a -> + Full meas vert horiz height width a + solveLeft = Unpacked.swapMultiply $ solve Transposed -class (Solve typ, Multiply.Power typ) => Inverse typ where - inverse :: (Class.Floating a) => Matrix typ a -> Matrix typ a +class (Solve typ xl xu) => Inverse typ xl xu where + inverse :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Extent.Measure meas, Shape.C height, Shape.C width, Class.Floating a) => + Matrix.QuadraticMeas typ xl xu lower upper meas height width a -> + Matrix.QuadraticMeas typ xl xu lower upper meas width height a infixl 7 ##/# infixr 7 #\## (#\##) :: - (Solve typ, Type.HeightOf typ ~ height, Eq height, Shape.C width, + (Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, + Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC, Extent.C vert, Extent.C horiz, Class.Floating a) => - Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a -(#\##) = solveRight + Matrix.QuadraticMeas typ xl xu lower upper measA height width a -> + Full measB vert horiz height nrhs a -> Full measC vert horiz width nrhs a +a#\##b = + case Multiply.factorIdentityRight a of + (q, ident) -> + Multiply.reshapeHeight (Matrix.transpose ident) (solveRight q b) (##/#) :: - (Solve typ, Type.WidthOf typ ~ width, Eq width, Shape.C height, + (Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper, + Shape.C height, Shape.C width, Eq width, Shape.C nrhs, + Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC, Extent.C vert, Extent.C horiz, Class.Floating a) => - Full vert horiz height width a -> - Matrix typ a -> Full vert horiz height width a -(##/#) = solveLeft + Full measB vert horiz nrhs width a -> + Matrix.QuadraticMeas typ xl xu lower upper measA height width a -> + Full measC vert horiz nrhs height a +b##/#a = + case Multiply.factorIdentityLeft a of + (ident, q) -> + Multiply.reshapeWidth (solveLeft b q) (Matrix.transpose ident) solveVector :: - (Solve typ, Type.HeightOf typ ~ height, Eq height, Class.Floating a) => - Transposition -> Matrix typ a -> Vector height a -> Vector height a + (Solve typ xl xu, Omni.Strip lower, Omni.Strip upper, + Shape.C sh, Eq sh, Class.Floating a) => + Transposition -> + Matrix.Quadratic typ xl xu lower upper sh a -> + Vector sh a -> Vector sh a solveVector trans = - ArrMatrix.unliftColumn MatrixShape.ColumnMajor . solve trans + ArrMatrix.unliftColumn Layout.ColumnMajor . solve trans + infixl 7 -/# infixr 7 #\| (#\|) :: - (Solve typ, Type.HeightOf typ ~ height, Eq height, Class.Floating a) => - Matrix typ a -> Vector height a -> Vector height a -(#\|) = solveVector NonTransposed + (Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper, Extent.Measure meas, + Shape.C height, Shape.C width, Eq height, Class.Floating a) => + Matrix.QuadraticMeas typ xl xu lower upper meas height width a -> + Vector height a -> Vector width a +(#\|) a = + case Multiply.factorIdentityRight a of + (q, ident) -> + reshapeVector (Matrix.transpose ident) . solveVector NonTransposed q (-/#) :: - (Solve typ, Type.HeightOf typ ~ height, Eq height, Class.Floating a) => - Vector height a -> Matrix typ a -> Vector height a -(-/#) = flip $ solveVector Transposed + (Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper, Extent.Measure meas, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Vector width a -> + Matrix.QuadraticMeas typ xl xu lower upper meas height width a -> + Vector height a +(-/#) = flip $ \a -> + case Multiply.factorIdentityLeft a of + (ident, q) -> reshapeVector ident . solveVector Transposed q -instance (Shape.C shape, Eq shape) => Determinant (Type.Scale shape) where - determinant (Type.Scale sh a) = a ^ Shape.size sh +reshapeVector :: + (Extent.Measure meas, Shape.C height, Shape.C width) => + Multiply.IdentityMaes meas height width a -> + Vector width a -> Vector height a +reshapeVector (Matrix.Identity extent) = Array.reshape (Extent.height extent) -instance (Shape.C shape, Eq shape) => Solve (Type.Scale shape) where + +instance (xl ~ (), xu ~ ()) => Determinant Matrix.Scale xl xu where + determinant (Matrix.Scale sh a) = a ^ Shape.size sh + +instance (xl ~ (), xu ~ ()) => Solve Matrix.Scale xl xu where solve _trans = - scaleWithCheck "Matrix.Scale.solve" Type.height $ + scaleWithCheck "Matrix.Scale.solve" Matrix.height $ ArrMatrix.lift1 . Vector.scale . recip -instance (Shape.C shape, Eq shape) => Inverse (Type.Scale shape) where - inverse (Type.Scale shape a) = Type.Scale shape $ recip a +instance (xl ~ (), xu ~ ()) => Inverse Matrix.Scale xl xu where + inverse (Matrix.Scale shape a) = Matrix.Scale shape $ recip a -instance (Shape.C shape) => Determinant (PermMatrix.Permutation shape) where +instance (xl ~ (), xu ~ ()) => Determinant Matrix.Permutation xl xu where determinant = PermMatrix.determinant -instance (Shape.C shape) => Solve (PermMatrix.Permutation shape) where +instance (xl ~ (), xu ~ ()) => Solve Matrix.Permutation xl xu where solve trans = PermMatrix.multiplyFull (Inverted <> PermMatrix.inversionFromTransposition trans) -instance (Shape.C shape) => Inverse (PermMatrix.Permutation shape) where - inverse = PermMatrix.transpose - +instance (xl ~ (), xu ~ ()) => Inverse Matrix.Permutation xl xu where + inverse a@(Matrix.Permutation _) = + case Matrix.powerStrips a of + (MatrixShape.Filled, MatrixShape.Filled) -> PermMatrix.transpose a + _ -> a -- identity matrix instance - (ArrDivide.Determinant shape) => Determinant (ArrMatrix.Array shape) where - determinant = ArrDivide.determinant . ArrMatrix.toVector + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + Determinant (ArrMatrix.Array pack property) xl xu where + determinant = ArrDivide.determinant -instance (ArrDivide.Solve shape) => Solve (ArrMatrix.Array shape) where - solve = ArrMatrix.lift2 . ArrDivide.solve - solveLeft = ArrMatrix.lift2 ArrDivide.solveLeft - solveRight = ArrMatrix.lift2 ArrDivide.solveRight +instance + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + Solve (ArrMatrix.Array pack property) xl xu where + solveRight = ArrDivide.solve + solveLeft = Matrix.swapMultiply $ ArrDivide.solve . Matrix.transpose -instance (ArrDivide.Inverse shape) => Inverse (ArrMatrix.Array shape) where - inverse = ArrMatrix.lift1 ArrDivide.inverse +instance + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + Inverse (ArrMatrix.Array pack property) xl xu where + inverse = ArrDivide.inverse diff --git a/src/Numeric/LAPACK/Matrix/Extent.hs b/src/Numeric/LAPACK/Matrix/Extent.hs --- a/src/Numeric/LAPACK/Matrix/Extent.hs +++ b/src/Numeric/LAPACK/Matrix/Extent.hs @@ -1,23 +1,27 @@ module Numeric.LAPACK.Matrix.Extent ( - Extent.C(switchTag), + Extent.C(switchTag), Small, Big, + Extent.Measure(switchMeasure), Shape, Size, + Measured(switchMeasured), Extent.Extent, Map, - Small, Big, Extent.height, Extent.width, Extent.squareSize, Extent.dimensions, Extent.transpose, Extent.fuse, + Extent.MultiplyMeasure, Extent.square, toGeneral, fromSquare, fromSquareLiberal, + fromLiberalSquare, generalizeTall, generalizeWide, - Extent.GeneralTallWide, + weakenTall, + weakenWide, Extent.AppendMode, Extent.appendSame, @@ -28,21 +32,47 @@ ) where import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Extent.Private (C, Small, Big, Map(Map)) +import Numeric.LAPACK.Matrix.Extent.Strict (Map(Map), Measured(..)) +import Numeric.LAPACK.Matrix.Extent.Private + (C, Measure, Small, Big, Shape, Size) -toGeneral :: (C vert, C horiz) => Map vert horiz Big Big height width +toGeneral :: + (Measure meas, C vert, C horiz) => + Map meas vert horiz Size Big Big height width toGeneral = Map Extent.toGeneral -fromSquare :: (C vert, C horiz) => Map Small Small vert horiz size size +fromSquare :: + (Measured meas vert, Measured meas horiz) => + Map Shape Small Small meas vert horiz size size fromSquare = Map Extent.fromSquare fromSquareLiberal :: - (C vert, C horiz) => Map Small Small vert horiz height width + (Measured meas vert, Measured meas horiz) => + Map Shape Small Small meas vert horiz height width fromSquareLiberal = Map Extent.fromSquareLiberal -generalizeTall :: (C vert, C horiz) => Map vert Small vert horiz height width +fromLiberalSquare :: + (C vert, C horiz) => + Map Size Small Small Size vert horiz height width +fromLiberalSquare = Map Extent.fromLiberalSquare + +generalizeTall :: + (Measure meas, C vert, C horiz) => + Map meas vert Small Size vert horiz height width generalizeTall = Map Extent.generalizeTall -generalizeWide :: (C vert, C horiz) => Map Small horiz vert horiz height width +generalizeWide :: + (Measure meas, C vert, C horiz) => + Map meas Small horiz Size vert horiz height width generalizeWide = Map Extent.generalizeWide + +weakenTall :: + (Measured meas horiz, C vert) => + Map meas vert Small meas vert horiz height width +weakenTall = Map Extent.weakenTall + +weakenWide :: + (Measured meas vert, C horiz) => + Map meas Small horiz meas vert horiz height width +weakenWide = Map Extent.weakenWide diff --git a/src/Numeric/LAPACK/Matrix/Extent/Private.hs b/src/Numeric/LAPACK/Matrix/Extent/Private.hs --- a/src/Numeric/LAPACK/Matrix/Extent/Private.hs +++ b/src/Numeric/LAPACK/Matrix/Extent/Private.hs @@ -1,32 +1,34 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Extent.Private where import Numeric.LAPACK.Shape.Private (Unchecked(deconsUnchecked)) import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)((::+))) +import Text.Printf (printf) + import Control.DeepSeq (NFData, rnf) +import Control.Applicative (Const(Const)) import Data.Maybe.HT (toMaybe) -import Data.Eq.HT (equating) -data family Extent vertical horizontal :: * -> * -> * +data Extent meas vert horiz height width where + Square :: size -> Extent Shape Small Small size size + Separate :: height -> width -> Extent Size vert horiz height width + instance - (C vertical, C horizontal, NFData height, NFData width) => - NFData (Extent vertical horizontal height width) where - rnf = - getAccessor $ - switchTagPair - (Accessor $ \(Square s) -> rnf s) - (Accessor $ \(Wide h w) -> rnf (h,w)) - (Accessor $ \(Tall h w) -> rnf (h,w)) - (Accessor $ \(General h w) -> rnf (h,w)) + (Measure measure, C vertical, C horizontal, NFData height, NFData width) => + NFData (Extent measure vertical horizontal height width) where + rnf (Square s) = rnf s + rnf (Separate h w) = rnf (h,w) data Big = Big deriving (Eq,Show) @@ -35,63 +37,52 @@ instance NFData Big where rnf Big = () instance NFData Small where rnf Small = () -type General = Extent Big Big -type Tall = Extent Big Small -type Wide = Extent Small Big -type Square sh = Extent Small Small sh sh +data Size = Size deriving (Eq,Show) +data Shape = Shape deriving (Eq,Show) -data instance Extent Big Big height width = - General { - generalHeight :: height, - generalWidth :: width - } +instance NFData Size where rnf Size = () +instance NFData Shape where rnf Shape = () -data instance Extent Big Small height width = - Tall { - tallHeight :: height, - tallWidth :: width - } -data instance Extent Small Big height width = - Wide { - wideHeight :: height, - wideWidth :: width - } - -data instance Extent Small Small height width = - (height ~ width) => - Square { - squareSize :: height - } +type General = Extent Size Big Big +type Tall = Extent Size Big Small +type Wide = Extent Size Small Big +type SquareMeas meas = Extent meas Small Small +type LiberalSquare = SquareMeas Size +type Square sh = SquareMeas Shape sh sh general :: height -> width -> General height width -general = General +general = Separate tall :: height -> width -> Tall height width -tall = Tall +tall = Separate wide :: height -> width -> Wide height width -wide = Wide +wide = Separate +liberalSquare :: height -> width -> LiberalSquare height width +liberalSquare = Separate + square :: sh -> Square sh square = Square -newtype Map vertA horizA vertB horizB height width = - Map { - apply :: - Extent vertA horizA height width -> - Extent vertB horizB height width - } +type Map measA vertA horizA measB vertB horizB height width = + Extent measA vertA horizA height width -> + Extent measB vertB horizB height width class C tag where switchTag :: f Small -> f Big -> f tag instance C Small where switchTag f _ = f instance C Big where switchTag _ f = f +class Measure meas where switchMeasure :: f Shape -> f Size -> f meas +instance Measure Shape where switchMeasure f _ = f +instance Measure Size where switchMeasure _ f = f + switchTagPair :: (C vert, C horiz) => f Small Small -> f Small Big -> f Big Small -> f Big Big -> f vert horiz @@ -102,216 +93,299 @@ (Flip $ switchTag fTall fGeneral) -newtype CaseTallWide height width vert horiz = - CaseTallWide { - getCaseTallWide :: - Extent vert horiz height width -> - Either (Tall height width) (Wide height width) - } +newtype RotLeft3 f b c a = RotLeft3 {getRotLeft3 :: f a b c} +switchMeasureExtent :: + (Measure meas, C vert, C horiz) => + f Shape Small Small -> + (forall vert0 horiz0. (C vert0, C horiz0) => f Size vert0 horiz0) -> + f meas vert horiz +switchMeasureExtent fSquare fGeneral = + getRotLeft3 $ + switchMeasure + (RotLeft3 $ switchTagPair fSquare + errorTagTriple errorTagTriple errorTagTriple) + (RotLeft3 $ switchTagPair fGeneral fGeneral fGeneral fGeneral) + + +errorTagTripleAux :: + Const String meas -> Const String vert -> Const String horiz -> + f meas vert horiz +errorTagTripleAux (Const meas) (Const vert) (Const horiz) = + error $ printf "forbidden Extent tag combination %s %s %s" meas vert horiz + +showConst :: (Show a) => a -> Const String a +showConst a = Const $ show a + +errorTagTriple :: (Measure meas, C vert, C horiz) => f meas vert horiz +errorTagTriple = + errorTagTripleAux + (switchMeasure (showConst Shape) (showConst Size)) + (switchTag (showConst Small) (showConst Big)) + (switchTag (showConst Small) (showConst Big)) + +switchTagTriple :: + (Measure meas, C vert, C horiz) => + f Shape Small Small -> f Size Small Small -> f Size Small Big -> + f Size Big Small -> f Size Big Big -> f meas vert horiz +switchTagTriple fSquare fLiberalSquare fWide fTall fGeneral = + getRotLeft3 $ + switchMeasure + (RotLeft3 $ switchTagPair fSquare + errorTagTriple errorTagTriple errorTagTriple) + (RotLeft3 $ switchTagPair fLiberalSquare fWide fTall fGeneral) + + caseTallWide :: - (C vert, C horiz) => + (Measure meas, C vert, C horiz) => (height -> width -> Bool) -> - Extent vert horiz height width -> + Extent meas vert horiz height width -> Either (Tall height width) (Wide height width) -caseTallWide ge = - getCaseTallWide $ +caseTallWide _ (Square sh) = Left $ tall sh sh +caseTallWide ge x@(Separate _ _) = + flip getAccessor x $ switchTagPair - (CaseTallWide $ \(Square sh) -> Left $ tall sh sh) - (CaseTallWide Right) - (CaseTallWide Left) - (CaseTallWide $ \(General h w) -> + (Accessor $ \(Separate h w) -> Left $ tall h w) + (Accessor Right) + (Accessor Left) + (Accessor $ \(Separate h w) -> if ge h w then Left $ tall h w else Right $ wide h w) -newtype GenSquare sh vert horiz = - GenSquare {getGenSquare :: sh -> Extent vert horiz sh sh} +newtype GenSquare sh meas vert horiz = + GenSquare {getGenSquare :: sh -> Extent meas vert horiz sh sh} -genSquare :: (C vert, C horiz) => sh -> Extent vert horiz sh sh +genSquare :: + (Measure meas, C vert, C horiz) => sh -> Extent meas vert horiz sh sh genSquare = getGenSquare $ - switchTagPair + switchMeasureExtent (GenSquare square) - (GenSquare (\sh -> wide sh sh)) - (GenSquare (\sh -> tall sh sh)) - (GenSquare (\sh -> general sh sh)) + (GenSquare (\sh -> Separate sh sh)) -newtype GenTall height width vert horiz = +genLiberalSquare :: + (C vert, C horiz) => height -> width -> Extent Size vert horiz height width +genLiberalSquare = Separate + +relaxMeasure :: (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> + Extent Size vert horiz height width +relaxMeasure (Square s) = genSquare s +relaxMeasure (Separate h w) = Separate h w + +newtype GenTall height width meas vert horiz = GenTall { getGenTall :: - Extent vert Small height width -> Extent vert horiz height width + Extent meas vert Small height width -> + Extent Size vert horiz height width } -generalizeTall :: (C vert, C horiz) => - Extent vert Small height width -> Extent vert horiz height width +generalizeTall :: (Measure meas, C vert, C horiz) => + Extent meas vert Small height width -> Extent Size vert horiz height width generalizeTall = - getGenTall $ - switchTagPair - (GenTall id) (GenTall $ \(Square s) -> wide s s) - (GenTall id) (GenTall $ \(Tall h w) -> general h w) + getGenTall + (switchTagPair + (GenTall id) (GenTall $ \(Separate h w) -> wide h w) + (GenTall id) (GenTall $ \(Separate h w) -> general h w)) + . + relaxMeasure -newtype GenWide height width vert horiz = +newtype GenWide height width meas vert horiz = GenWide { getGenWide :: - Extent Small horiz height width -> Extent vert horiz height width + Extent meas Small horiz height width -> + Extent Size vert horiz height width } -generalizeWide :: (C vert, C horiz) => - Extent Small horiz height width -> Extent vert horiz height width +generalizeWide :: (Measure meas, C vert, C horiz) => + Extent meas Small horiz height width -> Extent Size vert horiz height width generalizeWide = - getGenWide $ - switchTagPair - (GenWide id) - (GenWide id) - (GenWide $ \(Square s) -> tall s s) - (GenWide $ \(Wide h w) -> general h w) + getGenWide + (switchTagPair + (GenWide id) + (GenWide id) + (GenWide $ \(Separate h w) -> tall h w) + (GenWide $ \(Separate h w) -> general h w)) + . + relaxMeasure -newtype GenToTall height width vert horiz = +newtype WeakenTall height width meas vert horiz = + WeakenTall { + getWeakenTall :: + Extent meas vert Small height width -> + Extent meas vert horiz height width + } + +weakenTall :: (Measure meas, C vert, C horiz) => + Extent meas vert Small height width -> Extent meas vert horiz height width +weakenTall = + getWeakenTall $ + switchTagTriple + (WeakenTall fromSquareLiberal) + (WeakenTall id) (WeakenTall $ \(Separate h w) -> wide h w) + (WeakenTall id) (WeakenTall $ \(Separate h w) -> general h w) + +newtype WeakenWide height width meas vert horiz = + WeakenWide { + getWeakenWide :: + Extent meas Small horiz height width -> + Extent meas vert horiz height width + } + +weakenWide :: (Measure meas, C vert, C horiz) => + Extent meas Small horiz height width -> Extent meas vert horiz height width +weakenWide = + getWeakenWide $ + switchTagTriple + (WeakenWide fromSquareLiberal) + (WeakenWide id) + (WeakenWide id) + (WeakenWide $ \(Separate h w) -> tall h w) + (WeakenWide $ \(Separate h w) -> general h w) + + +newtype GenToTall height width meas vert horiz = GenToTall { getGenToTall :: - Extent vert horiz height width -> Extent Big horiz height width + Extent meas vert horiz height width -> + Extent Size Big horiz height width } -genToTall :: (C vert, C horiz) => - Extent vert horiz height width -> Extent Big horiz height width +genToTall :: (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> Extent Size Big horiz height width genToTall = getGenToTall $ - switchTagPair + switchTagTriple (GenToTall $ \(Square s) -> tall s s) - (GenToTall $ \(Wide h w) -> general h w) + (GenToTall $ \(Separate h w) -> tall h w) + (GenToTall $ \(Separate h w) -> general h w) (GenToTall id) (GenToTall id) - -newtype GenToWide height width vert horiz = +newtype GenToWide height width meas vert horiz = GenToWide { getGenToWide :: - Extent vert horiz height width -> Extent vert Big height width + Extent meas vert horiz height width -> + Extent Size vert Big height width } -genToWide :: (C vert, C horiz) => - Extent vert horiz height width -> Extent vert Big height width +genToWide :: (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> Extent Size vert Big height width genToWide = getGenToWide $ - switchTagPair + switchTagTriple (GenToWide $ \(Square s) -> wide s s) + (GenToWide $ \(Separate h w) -> wide h w) (GenToWide id) - (GenToWide $ \(Tall h w) -> general h w) + (GenToWide $ \(Separate h w) -> general h w) (GenToWide id) -newtype Accessor a height width vert horiz = - Accessor {getAccessor :: Extent vert horiz height width -> a} +newtype Accessor a height width meas vert horiz = + Accessor {getAccessor :: Extent meas vert horiz height width -> a} -height :: (C vert, C horiz) => Extent vert horiz height width -> height -height = - getAccessor $ - switchTagPair - (Accessor squareSize) - (Accessor wideHeight) - (Accessor tallHeight) - (Accessor generalHeight) +squareSize :: Square shape -> shape +squareSize (Square s) = s -width :: (C vert, C horiz) => Extent vert horiz height width -> width -width = - getAccessor $ - switchTagPair - (Accessor (\(Square s) -> s)) - (Accessor wideWidth) - (Accessor tallWidth) - (Accessor generalWidth) +height :: + (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> height +height (Square s) = s +height (Separate h _w) = h +width :: + (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> width +width (Square s) = s +width (Separate _h w) = w + dimensions :: - (C vert, C horiz) => Extent vert horiz height width -> (height,width) + (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> (height,width) dimensions x = (height x, width x) toGeneral :: - (C vert, C horiz) => Extent vert horiz height width -> General height width + (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> General height width toGeneral x = general (height x) (width x) -fromSquare :: (C vert, C horiz) => Square size -> Extent vert horiz size size -fromSquare = genSquare . squareSize +fromSquare :: + (Measure meas, C vert, C horiz) => + Square size -> Extent meas vert horiz size size +fromSquare (Square s) = genSquare s -fromSquareLiberal :: (C vert, C horiz) => - Extent Small Small height width -> Extent vert horiz height width -fromSquareLiberal (Square s) = genSquare s +fromSquareLiberal :: + (Measure meas, C vert, C horiz) => + Extent Shape Small Small height width -> + Extent meas vert horiz height width +fromSquareLiberal (Square h) = genSquare h -squareFromGeneral :: - (C vert, C horiz, Eq size) => - Extent vert horiz size size -> Square size -squareFromGeneral x = +fromLiberalSquare :: (C vert, C horiz) => + LiberalSquare height width -> + Extent Size vert horiz height width +fromLiberalSquare (Separate h w) = genLiberalSquare h w + +squareFromFull :: + (Measure meas, C vert, C horiz, Eq size) => + Extent meas vert horiz size size -> Square size +squareFromFull x = let size = height x in if size == width x - then square size - else error "Extent.squareFromGeneral: no square shape" + then square size + else error "Extent.squareFromFull: no square shape" +liberalSquareFromFull :: + (Measure meas, C vert, C horiz, Shape.C height, Shape.C width) => + Extent meas vert horiz height width -> LiberalSquare height width +liberalSquareFromFull (Square s) = Separate s s +liberalSquareFromFull (Separate h w) = + if Shape.size h == Shape.size w + then liberalSquare h w + else error "Extent.liberalSquareFromFull: no square shape" -newtype Transpose height width vert horiz = - Transpose { - getTranspose :: - Extent vert horiz height width -> - Extent horiz vert width height - } transpose :: - (C vert, C horiz) => - Extent vert horiz height width -> - Extent horiz vert width height -transpose = - getTranspose $ - switchTagPair - (Transpose $ \(Square s) -> Square s) - (Transpose $ \(Wide h w) -> Tall w h) - (Transpose $ \(Tall h w) -> Wide w h) - (Transpose $ \(General h w) -> General w h) + (Measure meas, C vert, C horiz) => + Extent meas vert horiz height width -> + Extent meas horiz vert width height +transpose (Square s) = Square s +transpose (Separate h w) = Separate w h -newtype Equal height width vert horiz = - Equal { - getEqual :: - Extent vert horiz height width -> - Extent vert horiz height width -> Bool - } - instance - (C vert, C horiz, Eq height, Eq width) => - Eq (Extent vert horiz height width) where - (==) = - getEqual $ - switchTagPair - (Equal $ \(Square a) (Square b) -> a==b) - (Equal $ \a b -> equating wideHeight a b && equating wideWidth a b) - (Equal $ \a b -> equating tallHeight a b && equating tallWidth a b) - (Equal $ \a b -> - equating generalHeight a b && equating generalWidth a b) + (Measure meas, C vert, C horiz, Eq height, Eq width) => + Eq (Extent meas vert horiz height width) where + Square a == Square b = a==b + Separate h0 w0 == Separate h1 w1 = h0==h1 && w0==w1 instance - (C vert, C horiz, Show height, Show width) => - Show (Extent vert horiz height width) where - showsPrec prec = - getAccessor $ + (Measure meas, C vert, C horiz, Show height, Show width) => + Show (Extent meas vert horiz height width) where + showsPrec prec x@(Square _) = showsPrecSquare prec x + showsPrec prec x@(Separate _ _) = + flip getAccessor x $ switchTagPair - (Accessor $ showsPrecSquare prec) + (Accessor $ showsPrecAny "Extent.liberalSquare" prec) (Accessor $ showsPrecAny "Extent.wide" prec) (Accessor $ showsPrecAny "Extent.tall" prec) (Accessor $ showsPrecAny "Extent.general" prec) showsPrecSquare :: (Show height) => - Int -> Extent Small Small height width -> ShowS + Int -> Extent Shape Small Small height width -> ShowS showsPrecSquare p x = showParen (p>10) $ showString "Extent.square " . showsPrec 11 (height x) showsPrecAny :: - (C vert, C horiz, Show height, Show width) => - String -> Int -> Extent vert horiz height width -> ShowS + (Measure meas, C vert, C horiz, Show height, Show width) => + String -> Int -> Extent meas vert horiz height width -> ShowS showsPrecAny name p x = showParen (p>10) $ showString name . @@ -319,106 +393,58 @@ showString " " . showsPrec 11 (width x) -newtype Widen heightA widthA heightB widthB vert = - Widen { - getWiden :: - Extent vert Big heightA widthA -> - Extent vert Big heightB widthB - } - widen :: (C vert) => - widthB -> Extent vert Big height widthA -> Extent vert Big height widthB -widen w = - getWiden $ - switchTag - (Widen (\x -> x{wideWidth = w})) - (Widen (\x -> x{generalWidth = w})) + widthB -> + Extent Size vert Big height widthA -> Extent Size vert Big height widthB +widen w (Separate h _) = Separate h w reduceWideHeight :: (C vert) => - heightB -> Extent vert Big heightA width -> Extent vert Big heightB width -reduceWideHeight h = - getWiden $ - switchTag - (Widen (\x -> x{wideHeight = h})) - (Widen (\x -> x{generalHeight = h})) + heightB -> + Extent Size vert Big heightA width -> Extent Size vert Big heightB width +reduceWideHeight h (Separate _ w) = Separate h w -newtype Adapt heightA widthA heightB widthB vert horiz = - Adapt { - getAdapt :: - Extent vert horiz heightA widthA -> - Extent vert horiz heightB widthB - } - reduceConsistent :: - (C vert, C horiz) => + (Measure meas, C vert, C horiz) => height -> width -> - Extent vert horiz height width -> Extent vert horiz height width -reduceConsistent h w = - getAdapt $ - switchTagPair - (Adapt $ \(Square _) -> Square h) - (Adapt $ \(Wide _ _) -> Wide h w) - (Adapt $ \(Tall _ _) -> Tall h w) - (Adapt $ \(General _ _) -> General h w) - - -class (C vert, C horiz) => GeneralTallWide vert horiz where - switchTagGTW :: f Small Big -> f Big Small -> f Big Big -> f vert horiz - -instance GeneralTallWide Small Big where switchTagGTW f _ _ = f -instance GeneralTallWide Big Small where switchTagGTW _ f _ = f -instance GeneralTallWide Big Big where switchTagGTW _ _ f = f + Extent meas vert horiz height width -> Extent meas vert horiz height width +reduceConsistent h _ (Square _) = Square h +reduceConsistent h w (Separate _ _) = Separate h w mapHeight :: - (GeneralTallWide vert horiz) => + (C vert, C horiz) => (heightA -> heightB) -> - Extent vert horiz heightA width -> Extent vert horiz heightB width -mapHeight f = - getAdapt $ - switchTagGTW - (Adapt $ \(Wide h w) -> Wide (f h) w) - (Adapt $ \(Tall h w) -> Tall (f h) w) - (Adapt $ \(General h w) -> General (f h) w) + Extent Size vert horiz heightA width -> Extent Size vert horiz heightB width +mapHeight f (Separate h w) = Separate (f h) w mapWidth :: - (GeneralTallWide vert horiz) => + (C vert, C horiz) => (widthA -> widthB) -> - Extent vert horiz height widthA -> Extent vert horiz height widthB -mapWidth f = - getAdapt $ - switchTagGTW - (Adapt $ \(Wide h w) -> Wide h (f w)) - (Adapt $ \(Tall h w) -> Tall h (f w)) - (Adapt $ \(General h w) -> General h (f w)) + Extent Size vert horiz height widthA -> Extent Size vert horiz height widthB +mapWidth f (Separate h w) = Separate h (f w) mapSquareSize :: (shA -> shB) -> Square shA -> Square shB mapSquareSize f (Square s) = Square (f s) mapWrap :: - (C vert, C horiz) => + (Measure meas, C vert, C horiz) => (height -> f height) -> (width -> f width) -> - Extent vert horiz height width -> - Extent vert horiz (f height) (f width) -mapWrap fh fw = - getAdapt $ - switchTagPair - (Adapt $ \(Square h) -> Square (fh h)) - (Adapt $ \(Wide h w) -> Wide (fh h) (fw w)) - (Adapt $ \(Tall h w) -> Tall (fh h) (fw w)) - (Adapt $ \(General h w) -> General (fh h) (fw w)) + Extent meas vert horiz height width -> + Extent meas vert horiz (f height) (f width) +mapWrap fh _ (Square h) = Square (fh h) +mapWrap fh fw (Separate h w) = Separate (fh h) (fw w) {- only admissible since GHC-7.8 mapUnwrap :: - (C vert, C horiz) => + (Measure meas, C vert, C horiz) => (f height -> height) -> (f width -> width) -> - Extent vert horiz (f height) (f width) -> - Extent vert horiz height width + Extent meas vert horiz (f height) (f width) -> + Extent meas vert horiz height width mapUnwrap fh fw = getAdapt $ switchTagPair @@ -429,47 +455,49 @@ -} recheck :: - (C vert, C horiz) => - Extent vert horiz (Unchecked height) (Unchecked width) -> - Extent vert horiz height width -recheck = - getAdapt $ - switchTagPair - (Adapt $ \(Square h) -> Square (deconsUnchecked h)) - (Adapt $ \(Wide h w) -> Wide (deconsUnchecked h) (deconsUnchecked w)) - (Adapt $ \(Tall h w) -> Tall (deconsUnchecked h) (deconsUnchecked w)) - (Adapt $ \(General h w) -> - General (deconsUnchecked h) (deconsUnchecked w)) - - + (Measure meas, C vert, C horiz) => + Extent meas vert horiz (Unchecked height) (Unchecked width) -> + Extent meas vert horiz height width +recheck (Square h) = Square (deconsUnchecked h) +recheck (Separate h w) = Separate (deconsUnchecked h) (deconsUnchecked w) -newtype Fuse height fuse width vert horiz = - Fuse { - getFuse :: - Extent vert horiz height fuse -> - Extent vert horiz fuse width -> - Maybe (Extent vert horiz height width) - } +recheckAppend :: + (Measure meas, C vert, C horiz) => + Extent meas vert horiz + (Unchecked heightA ::+ Unchecked heightB) + (Unchecked widthA ::+ Unchecked widthB) -> + Extent meas vert horiz (heightA::+heightB) (widthA::+widthB) +recheckAppend (Square (ha::+hb)) = + Square (deconsUnchecked ha ::+ deconsUnchecked hb) +recheckAppend (Separate (ha::+hb) (wa::+wb)) = + Separate + (deconsUnchecked ha ::+ deconsUnchecked hb) + (deconsUnchecked wa ::+ deconsUnchecked wb) fuse :: - (C vert, C horiz, Eq fuse) => - Extent vert horiz height fuse -> - Extent vert horiz fuse width -> - Maybe (Extent vert horiz height width) -fuse = - getFuse $ - switchTagPair - (Fuse $ \(Square s0) (Square s1) -> toMaybe (s0==s1) $ Square s0) - (Fuse $ \(Wide h f0) (Wide f1 w) -> toMaybe (f0==f1) $ Wide h w) - (Fuse $ \(Tall h f0) (Tall f1 w) -> toMaybe (f0==f1) $ Tall h w) - (Fuse $ \(General h f0) (General f1 w) -> toMaybe (f0==f1) $ General h w) + (Measure meas, C vert, C horiz, Eq fuse) => + Extent meas vert horiz height fuse -> + Extent meas vert horiz fuse width -> + Maybe (Extent meas vert horiz height width) +fuse (Square s0) (Square s1) = toMaybe (s0==s1) $ Square s0 +fuse (Separate h f0) (Separate f1 w) = toMaybe (f0==f1) $ Separate h w +relaxMeasureWith :: + (Measure measA, Measure measB, + MultiplyMeasure measA measB ~ measC, + C vert, C horiz) => + Extent measA vertA horizA heightA widthA -> + Extent measB vert horiz height width -> + Extent measC vert horiz height width +relaxMeasureWith (Square _) = id +relaxMeasureWith (Separate _ _) = relaxMeasure + kronecker :: - (C vert, C horiz) => - Extent vert horiz heightA widthA -> - Extent vert horiz heightB widthB -> - Extent vert horiz (heightA,heightB) (widthA,widthB) + (Measure meas, C vert, C horiz) => + Extent meas vert horiz heightA widthA -> + Extent meas vert horiz heightB widthB -> + Extent meas vert horiz (heightA,heightB) (widthA,widthB) kronecker = stackGen (,) (,) @@ -496,16 +524,16 @@ -} newtype AppendMode vertA vertB vertC height widthA widthB = AppendMode ( - Extent vertA Big height widthA -> - Extent vertB Big height widthB -> - Extent vertC Big height (widthA:+:widthB) + Extent Size vertA Big height widthA -> + Extent Size vertB Big height widthB -> + Extent Size vertC Big height (widthA::+widthB) ) appendLeftAux :: (C vertA, C vertB) => AppendMode vertA vertB vertA height widthA widthB appendLeftAux = AppendMode $ \extentA extentB -> - widen (width extentA :+: width extentB) extentA + widen (width extentA ::+ width extentB) extentA appendSame :: (C vert) => AppendMode vert vert vert height widthA widthB appendSame = appendLeftAux @@ -516,7 +544,7 @@ appendRight :: (C vert) => AppendMode Big vert vert height widthA widthB appendRight = AppendMode $ \extentA extentB -> - widen (width extentA :+: width extentB) extentB + widen (width extentA ::+ width extentB) extentB type family Append a b type instance Append Small b = Small @@ -537,46 +565,33 @@ stack :: - (C vert, C horiz) => - Extent vert horiz heightA widthA -> - Extent vert horiz heightB widthB -> - Extent vert horiz (heightA:+:heightB) (widthA:+:widthB) -stack = stackGen (:+:) (:+:) - -newtype Stack f heightA widthA heightB widthB vert horiz = - Stack { - getStack :: - Extent vert horiz heightA widthA -> - Extent vert horiz heightB widthB -> - Extent vert horiz (f heightA heightB) (f widthA widthB) - } + (Measure meas, C vert, C horiz) => + Extent meas vert horiz heightA widthA -> + Extent meas vert horiz heightB widthB -> + Extent meas vert horiz (heightA::+heightB) (widthA::+widthB) +stack = stackGen (::+) (::+) stackGen :: - (C vert, C horiz) => + (Measure meas, C vert, C horiz) => (heightA -> heightB -> f heightA heightB) -> (widthA -> widthB -> f widthA widthB) -> - Extent vert horiz heightA widthA -> - Extent vert horiz heightB widthB -> - Extent vert horiz (f heightA heightB) (f widthA widthB) -stackGen fh fw = - getStack $ - switchTagPair - (Stack $ \(Square sa) (Square sb) -> - Square (fh sa sb)) - (Stack $ \(Wide ha wa) (Wide hb wb) -> - Wide (fh ha hb) (fw wa wb)) - (Stack $ \(Tall ha wa) (Tall hb wb) -> - Tall (fh ha hb) (fw wa wb)) - (Stack $ \(General ha wa) (General hb wb) -> - General (fh ha hb) (fw wa wb)) - + Extent meas vert horiz heightA widthA -> + Extent meas vert horiz heightB widthB -> + Extent meas vert horiz (f heightA heightB) (f widthA widthB) +stackGen fh _f (Square sa) (Square sb) = Square (fh sa sb) +stackGen fh fw (Separate ha wa) (Separate hb wb) = + Separate (fh ha hb) (fw wa wb) type family Multiply a b type instance Multiply Small b = b type instance Multiply Big b = Big +type family MultiplyMeasure a b +type instance MultiplyMeasure Shape b = b +type instance MultiplyMeasure Size b = Size + data TagFact a = C a => TagFact newtype MultiplyTagLaw b a = @@ -591,43 +606,71 @@ (MultiplyTagLaw $ flip const) (MultiplyTagLaw const) -heightFact :: (C vert) => Extent vert horiz height width -> TagFact vert +heightFact :: (C vert) => Extent meas vert horiz height width -> TagFact vert heightFact _ = TagFact -widthFact :: (C horiz) => Extent vert horiz height width -> TagFact horiz +widthFact :: (C horiz) => Extent meas vert horiz height width -> TagFact horiz widthFact _ = TagFact -newtype Unify height fuse width heightC widthC vertB horizB vertA horizA = +data MeasureFact a = Measure a => MeasureFact + +newtype MultiplyMeasureLaw b a = + MultiplyMeasureLaw { + getMultiplyMeasureLaw :: + MeasureFact a -> MeasureFact b -> MeasureFact (MultiplyMeasure a b) + } + +multiplyMeasureLaw :: + MeasureFact a -> MeasureFact b -> MeasureFact (MultiplyMeasure a b) +multiplyMeasureLaw a@MeasureFact = + ($a) $ getMultiplyMeasureLaw $ + switchMeasure + (MultiplyMeasureLaw $ flip const) + (MultiplyMeasureLaw const) + +measureFact :: + (Measure meas) => Extent meas vert horiz height width -> MeasureFact meas +measureFact _ = MeasureFact + + +newtype + Unify height fuse width heightC widthC + measB vertB horizB measA vertA horizA = Unify { getUnify :: - Extent vertA horizA height fuse -> - Extent vertB horizB fuse width -> - Extent (Multiply vertA vertB) (Multiply horizA horizB) heightC widthC + Extent measA vertA horizA height fuse -> + Extent measB vertB horizB fuse width -> + Extent (MultiplyMeasure measA measB) + (Multiply vertA vertB) (Multiply horizA horizB) heightC widthC } unifyLeft :: - (C vertA, C horizA, C vertB, C horizB) => - Extent vertA horizA height fuse -> - Extent vertB horizB fuse width -> - Extent (Multiply vertA vertB) (Multiply horizA horizB) height fuse + (Measure measA, Measure measB, C vertA, C horizA, C vertB, C horizB) => + Extent measA vertA horizA height fuse -> + Extent measB vertB horizB fuse width -> + Extent (MultiplyMeasure measA measB) + (Multiply vertA vertB) (Multiply horizA horizB) height fuse unifyLeft = getUnify $ - switchTagPair + switchTagTriple (Unify $ const . fromSquareLiberal) + (Unify $ const . fromLiberalSquare) (Unify $ const . generalizeWide) (Unify $ const . generalizeTall) (Unify $ const . toGeneral) unifyRight :: - (C vertA, C horizA, C vertB, C horizB) => - Extent vertA horizA height fuse -> - Extent vertB horizB fuse width -> - Extent (Multiply vertA vertB) (Multiply horizA horizB) fuse width + (Measure measA, Measure measB, C vertA, C horizA, C vertB, C horizB) => + Extent measA vertA horizA height fuse -> + Extent measB vertB horizB fuse width -> + Extent (MultiplyMeasure measA measB) + (Multiply vertA vertB) (Multiply horizA horizB) fuse width unifyRight = getUnify $ - switchTagPair + switchTagTriple (Unify $ const id) + (Unify $ const relaxMeasure) (Unify $ const genToWide) (Unify $ const genToTall) (Unify $ const toGeneral) diff --git a/src/Numeric/LAPACK/Matrix/Extent/Strict.hs b/src/Numeric/LAPACK/Matrix/Extent/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Extent/Strict.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} +module Numeric.LAPACK.Matrix.Extent.Strict where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Extent.Private + (C, Extent, Measure, switchTag, + Shape, Size, Small, Big, errorTagTriple) + +import qualified Data.Array.Comfort.Shape as Shape + + +newtype Map measA vertA horizA measB vertB horizB height width = + Map {apply :: Extent.Map measA vertA horizA measB vertB horizB height width} + + +{- | +Admissible tag combinations are: + +> meas vert horiz +> Shape Small Small - Square +> Size Small Small - LiberalSquare +> Size Big Small - Tall +> Size Small Big - Wide +> Size Big Big - General + +We can enforce this set with the constraints + +> (Extent.Measured meas vert, Extent.Measured meas horiz) + +However, in some cases it leads to constraints +like @Measured meas Small@ or @Measured meas Big@. +The former one is morally equivalent to @Measure meas@ +and the latter one is morally equivalent to @meas ~ Size@. +However, in order to convince the compiler +you would have to go through 'switchMeasured'. + +In order to circumvent this trouble +we use internal functions with weaker constraints: + +> (Extent.Measure meas, Extent.C vert, Extent.C horiz) + +This is typesafe whenever the input +is based on one of the five admissible extent types. +We only need the strict constraints +when constructing matrices of arbitrary extent type, +i.e. this almost only concerns 'Numeric.LAPACK.Matrix.Extent.fromSquare'. +-} +class (Measure meas, C tag) => Measured meas tag where + switchMeasured :: f Shape Small -> f Size Small -> f Size Big -> f meas tag +instance (tag ~ Small) => Measured Shape tag where + switchMeasured f _ _ = f +instance (C tag) => Measured Size tag where + switchMeasured _ = switchTag + +{- +Alternative set of instances: + +instance (Measure meas) => Measured meas Small where +instance (meas ~ Size) => Measured meas Big where +-} + + +newtype RotRight3 f c a b = RotRight3 {getRotRight3 :: f a b c} + +switchTagTriple :: + (Measured meas vert, Measured meas horiz) => + f Shape Small Small -> f Size Small Small -> f Size Small Big -> + f Size Big Small -> f Size Big Big -> f meas vert horiz +switchTagTriple fSquare fLiberalSquare fWide fTall fGeneral = + getRotRight3 $ + switchMeasured + (RotRight3 $ switchTag fSquare errorTagTriple) + (RotRight3 $ switchTag fLiberalSquare fWide) + (RotRight3 $ switchTag fTall fGeneral) + + +type family MeasureTarget meas sh +type instance MeasureTarget Shape sh = sh +type instance MeasureTarget Size sh = Int + +type family Dimension meas height width +type instance Dimension Shape height width = height +type instance Dimension Size height width = (height, width) + + +data Cons_ height width meas vert horiz = + Cons { + getCons :: + (MeasureTarget meas height ~ MeasureTarget meas width) => + Dimension meas height width -> Extent meas vert horiz height width + } + +consChecked :: + (Measured meas vert, Measured meas horiz) => + (Shape.C height, Shape.C width) => + (MeasureTarget meas height ~ MeasureTarget meas width) => + Dimension meas height width -> + Extent meas vert horiz height width +consChecked = + getCons $ + switchTagTriple + (Cons Extent.Square) + (Cons $ \(height, width) -> + if Shape.size height == Shape.size width + then Extent.liberalSquare height width + else error "Extent.liberalSquare: height and width size differ") + (Cons $ \(height, width) -> + if Shape.size height <= Shape.size width + then Extent.wide height width + else error "Extent.wide: width smaller than height") + (Cons $ \(height, width) -> + if Shape.size height >= Shape.size width + then Extent.tall height width + else error "Extent.tall: height smaller than width") + (Cons $ uncurry Extent.general) + + +unifiers :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Extent.MultiplyMeasure measA measB ~ measC) => + (Extent.Multiply vertA vertB ~ vertC) => + (Extent.Multiply horizA horizB ~ horizC) => + Extent measA vertA horizA height fuse -> + Extent measB vertB horizB fuse width -> + ((Extent.MeasureFact measC, Extent.TagFact vertC, Extent.TagFact horizC), + (Map measA vertA horizA measC vertC horizC height fuse, + Map measB vertB horizB measC vertC horizC fuse width)) +unifiers a b = + ((Extent.multiplyMeasureLaw (Extent.measureFact a) (Extent.measureFact b), + Extent.multiplyTagLaw (Extent.heightFact a) (Extent.heightFact b), + Extent.multiplyTagLaw (Extent.widthFact a) (Extent.widthFact b)), + (Map $ flip Extent.unifyLeft b, Map $ Extent.unifyRight a)) diff --git a/src/Numeric/LAPACK/Matrix/Full.hs b/src/Numeric/LAPACK/Matrix/Full.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Full.hs @@ -0,0 +1,107 @@ +module Numeric.LAPACK.Matrix.Full ( + Full, + Unpacked.Unpacked, + identity, + diagonal, + mapExtent, + mapHeight, + mapWidth, + transpose, + adjoint, + multiplyVector, + multiply, + ) where + +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Plain as Plain +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import Numeric.LAPACK.Matrix.Array (Full) +import Numeric.LAPACK.Vector (Vector) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Shape as Shape + + +identity :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C sh, Class.Floating a) => + sh -> Full meas vert horiz sh sh a +identity = ArrMatrix.lift0 . Plain.identity + +diagonal :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C sh, Class.Floating a) => + Vector sh a -> Full meas vert horiz sh sh a +diagonal = ArrMatrix.lift0 . Plain.diagonal + + +mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Full measA vertA horizA height width a -> + Full measB vertB horizB height width a +mapExtent = Unpacked.mapExtent + +{- | +The number of rows must be maintained by the height mapping function. +-} +mapHeight :: + (Extent.C vert, Extent.C horiz, + Shape.C heightA, Shape.C heightB, Shape.C width) => + (heightA -> heightB) -> + Full Extent.Size vert horiz heightA width a -> + Full Extent.Size vert horiz heightB width a +mapHeight = ArrMatrix.lift1 . Plain.mapHeight + +{- | +The number of columns must be maintained by the width mapping function. +-} +mapWidth :: + (Extent.C vert, Extent.C horiz, + Shape.C widthA, Shape.C widthB, Shape.C height) => + (widthA -> widthB) -> + Full Extent.Size vert horiz height widthA a -> + Full Extent.Size vert horiz height widthB a +mapWidth = ArrMatrix.lift1 . Plain.mapWidth + + +transpose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> Full meas horiz vert width height a +transpose = Unpacked.transpose + +{- | +conjugate transpose + +Problem: @adjoint a \<\> a@ is always square, +but how to convince the type checker to choose the Square type? + +Anser: Use @Hermitian.toSquare $ Hermitian.gramian a@ instead. +-} +adjoint :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> Full meas horiz vert width height a +adjoint = ArrMatrix.lift1 Basic.adjoint + + +multiplyVector :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full meas vert horiz height width a -> Vector width a -> Vector height a +multiplyVector = Unpacked.multiplyVector + +multiply :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, + Shape.C fuse, Eq fuse, + Shape.C width, + Class.Floating a) => + Full meas vert horiz height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +multiply = Unpacked.multiply diff --git a/src/Numeric/LAPACK/Matrix/Function.hs b/src/Numeric/LAPACK/Matrix/Function.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Function.hs @@ -0,0 +1,617 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Function ( + SqRt, sqrt, sqrtSchur, sqrtDenmanBeavers, + Exp, exp, expRealHermitian, + Log, log, logUnipotentUpper, + LiftReal, liftReal, + ) where + +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Matrix.Lazy.UpperTriangular as LazyUpper +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as ArrMosaic +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Quadratic as Quad +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Diagonal as Diagonal +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import qualified Numeric.LAPACK.Shape.Private as PrivShape +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Array.Mosaic + (UnitUpperP, LowerP, UpperP, FlexUpperP, + HermitianP, HermitianPosSemidefP) +import Numeric.LAPACK.Matrix.Array (Quadratic, ArrayMatrix, packTag) +import Numeric.LAPACK.Matrix.Square (Square) +import Numeric.LAPACK.Matrix + ((#!), (#+#), (#-#), (#\##), (#*\), (#*##), (##*#)) +import Numeric.LAPACK.Vector ((|+|), (|-|)) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Bool as Bool +import Type.Data.Bool (False, True) + +import Foreign.Storable (Storable) + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Complex as Complex +import qualified Data.List.HT as ListHT +import qualified Data.Stream as Stream +import Data.Complex (Complex) +import Data.Semigroup ((<>)) +import Data.Function.HT (nest) +import Data.Tuple.HT (mapFst, swap) +import Data.Stream (Stream) + +import qualified Prelude as P +import Prelude hiding (sqrt, exp, log) + + +class (MatrixShape.Property property) => SqRt property where + sqrt :: + (Layout.Packing pack, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Shape.C sh, Class.Real a) => + Quadratic pack property lower upper sh a -> + Quadratic pack property lower upper sh a + +instance SqRt Omni.Unit where + sqrt a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerIdentity -> a + Omni.PowerUpperTriangular -> sqrtUpper (const Scalar.one) a + Omni.PowerLowerTriangular -> + Triangular.transpose . + sqrtUpper (const Scalar.one) . + Triangular.transpose $ a + Omni.PowerDiagonal -> error "non-unit diagonal impossible" + Omni.PowerFull -> error "unit full matrix impossible" + +{- | +For Full matrices: +Explicit solution for matrices up to size 2. +Solution via 'sqrtDenmanBeavers' for larger sizes. +-} +instance SqRt Omni.Arbitrary where + sqrt m = + case Omni.powerSingleton $ ArrMatrix.shape m of + Omni.PowerDiagonal -> liftDiagonal P.sqrt m + Omni.PowerUpperTriangular -> sqrtUpper P.sqrt m + Omni.PowerLowerTriangular -> + Triangular.transpose . sqrtUpper P.sqrt . Triangular.transpose $ m + Omni.PowerFull -> + if Shape.size (Quad.size m) <= 2 + then + ArrMatrix.Array $ Array.fromList (ArrMatrix.shape m) $ + case Array.toList $ ArrMatrix.unwrap m of + [qA,qB,qC,qD] -> + let ((a,b),(c,d)) = sqrt2 ((qA,qB),(qC,qD)) + in [a,b,c,d] + [qA] -> [P.sqrt qA] + _ -> [] + else + case Scalar.precisionOfFunctor m of + Scalar.Float -> sqrtDenmanBeavers m + Scalar.Double -> sqrtDenmanBeavers m + +instance SqRt Omni.Symmetric where + sqrt a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerSymmetric -> + Symmetric.fromHermitian . sqrtHermitian . Hermitian.fromSymmetric + $ a + _ -> error "Symmetric.sqrt: impossible shape" + +instance + (neg ~ False, Bool.C zero, Bool.C pos) => + SqRt (Omni.Hermitian neg zero pos) where + sqrt a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerDiagonal -> liftHermitianDiagonal P.sqrt a + Omni.PowerHermitian -> sqrtHermitian a + _ -> error "Hermitian.sqrt: impossible shape" + +sqrtHermitian :: + (Layout.Packing pack, + Bool.C neg, Bool.C zero, Bool.C pos, Omni.Hermitian neg zero pos ~ herm, + Shape.C sh, Class.Real a) => + Quadratic pack herm Layout.Filled Layout.Filled sh a -> + Quadratic pack herm Layout.Filled Layout.Filled sh a +sqrtHermitian a = + case Scalar.precisionOfFunctor a of + Scalar.Float -> liftHermitian P.sqrt a + Scalar.Double -> liftHermitian P.sqrt a + +sqrtUpper :: + (Layout.Packing pack, Omni.TriDiag diag, Shape.C sh, Class.Floating a) => + (a -> a) -> FlexUpperP pack diag sh a -> FlexUpperP pack diag sh a +sqrtUpper sqrtF a = + Triangular.adaptOrder a $ ArrMatrix.lift1 Mosaic.reunpack $ + LazyUpper.toStorable $ LazyUpper.sqrt sqrtF $ LazyUpper.fromStorable a + +{- +/A B\ = /a b\. /a b\ = /a*a+b*c a*b+b*d\ = /a²+b*c b*(a+d)\ +\C D/ \c d/ \c d/ \c*a+d*c c*b+d*d/ \c*(a+d) d²+b*c / + +b/c = B/C B*c = C*b +b*C/B = c +A=a²+b²*C/B +D=d²+b²*C/B + +a²-d² = A-D +B = b*(a+d) +B*(a-d) = b*(a²-d²) = b*(A-D) +C*(a-d) = c*(a²-d²) = c*(A-D) + +(4*B*C-(A+D)^2)*b^4 + 2*B^2*(A-D)*b^2 - B^4 = 0 + +with x = B/b = C/c = a+d: +maxima: + poly_buchberger([a²+b*c-A,a*b+b*d-B,c*a+d*c-C,b*c+d²-D,x-(a+d)],[a,d,b,c,x]); + +x^4-2*(A+D)*x^2+(A-D)^2+4*B*C = 0 +c = C/x, b = B/x +a² = A - b*c = A - B*C/x² +-} +sqrt2 :: (Floating a) => ((a,a),(a,a)) -> ((a,a),(a,a)) +sqrt2 ((a,b),(c,d)) = + let x = P.sqrt $ a+d + 2 * P.sqrt (a*d - b*c) + y = (d-a)/x + in (((x-y)/2, b/x), (c/x, (x+y)/2)) + + +{- | +Square root solver that works on the Schur decomposition. + +Schur decomposition enables computing the square root +of (some) singular matrices like @((1,0),(0,0))@. +However, the Schur decomposition might emit small negative values +on the diagonal, where exact computation would yield zeros. +This would let the square root solver fail. +And there are singular matrices that have no square root, at all, +e.g. @((0,1),(0,0))@. + +The solver is restricted to a real triangular Schur matrix. +The check for non-real eigenvalues may exclude matrices +that actually have a real-valued square root. +E.g. @sqrt ((0,-2),(2,0)) = ((1,-1),(1,-1))@ + +In the future we might fix this +by solving 2x2 blocks at the diagonal using 'sqrt2'. +-} +sqrtSchur :: (Shape.C sh, Class.Real a) => Square sh a -> Square sh a +sqrtSchur = applyUnchecked $ applyPermutable $ \a -> + let (q,u) = Square.schur $ checkZeroOffDiagonal a + in q <> sqrtUpper P.sqrt (Triangular.takeUpper u) #*## Square.adjoint q + +checkZeroOffDiagonal :: + (Shape.Indexed sh, Class.Floating a) => + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +checkZeroOffDiagonal a = + if all (\ij -> Scalar.isZero (a#!ij)) $ + ListHT.mapAdjacent (flip (,)) $ Shape.indices $ Quad.size a + then a + else error "sqrtSchur: non-real eigenvalues" + +{- | +Iterative square root solver, similar to Newton iteration. + +Eigenvalues must all be positive, +otherwise, the iteration might loop forever, +or if an eigenvalue is zero, the computation of matrix inverse will fail. +-} +sqrtDenmanBeavers :: + (ArrMatrix.Homogeneous prop, ArrMatrix.Additive prop) => + (Layout.Packing pack, Omni.PowerStrip lower, Omni.PowerStrip upper) => + (Shape.C sh, Class.Floating a, Scalar.RealOf a ~ ar, Class.Real ar) => + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +sqrtDenmanBeavers = applyUnchecked $ \a -> + limit (Scalar.selectReal 1e-6 1e-14) $ fmap fst $ + Stream.iterate + (\(b,c) -> + (Matrix.scaleReal 0.5 (b #+# Matrix.inverse c), + Matrix.scaleReal 0.5 (Matrix.inverse b #+# c))) + (a, Matrix.identityFrom a) + +limit :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, + Class.Floating a, Scalar.RealOf a ~ ar, Class.Real ar, + ArrMatrix.ArrayMatrix + pack prop lower upper meas vert horiz height width ~ m) => + ar -> Stream (m a) -> m a +limit eps = + ArrMatrix.Array . snd . Stream.head . + Stream.dropWhile + (\(b0,b1) -> + Vector.normInf (b0|-|b1) > 0.5*eps * Vector.normInf (b0|+|b1)) . + streamMapAdjacent (,) . fmap ArrMatrix.unwrap + +streamMapAdjacent :: (a -> a -> b) -> Stream a -> Stream b +streamMapAdjacent f xs = Stream.zipWith f xs (Stream.tail xs) + + +class (MatrixShape.Property property) => Exp property where + exp :: + (Layout.Packing pack, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Shape.C sh, Class.Floating a) => + Quadratic pack property lower upper sh a -> + Quadratic pack property lower upper sh a + +instance Exp Omni.Arbitrary where + exp a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerDiagonal -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> liftDiagonal P.exp a + Scalar.Complex -> liftDiagonal P.exp a + Omni.PowerFull -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> + ArrMatrix.liftUnpacked1 id $ + applyUnchecked (expScaledPade (#\##)) $ Matrix.toFull a + Scalar.Complex -> + ArrMatrix.liftUnpacked1 id $ + applyUnchecked (expScaledPade (#\##)) $ Matrix.toFull a + Omni.PowerUpperTriangular -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> applyUnchecked (expScaledPade solveUpper) a + Scalar.Complex -> applyUnchecked (expScaledPade solveUpper) a + Omni.PowerLowerTriangular -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> applyUnchecked (expScaledPade solveLower) a + Scalar.Complex -> applyUnchecked (expScaledPade solveLower) a + +solveUpper :: + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + UpperP pack sh a -> UpperP pack sh a -> UpperP pack sh a +solveUpper d n = + ArrMosaic.assureMirrored $ d #\## Triangular.toSquare n + +solveLower :: + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + LowerP pack sh a -> LowerP pack sh a -> LowerP pack sh a +solveLower d n = + ArrMosaic.assureMirrored $ d #\## Triangular.toSquare n + + +instance + (neg ~ True, zero ~ True, pos ~ True) => + Exp (Omni.Hermitian neg zero pos) where + exp a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerDiagonal -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> liftHermitianDiagonal P.exp a + Scalar.Complex -> liftHermitianDiagonal P.exp a + Omni.PowerHermitian -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> liftHermitian P.exp a + Scalar.Complex -> liftHermitian P.exp a + _ -> error "Hermitian.exp: impossible shape" + +instance Exp Omni.Symmetric where + exp a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerSymmetric -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> + Symmetric.fromHermitian . liftHermitian P.exp . + Hermitian.fromSymmetric $ a + Scalar.Complex -> + applyUnchecked + (expScaledPade + (\d n -> + Symmetric.assureSymmetry $ + d #\## Symmetric.toSquare n)) + a + _ -> error "Symmetric.exp: impossible shape" + +{- +"Nineteen Dubious Ways to Compute the Exponential of a Matrix, +Twenty-Five Years Later." +by Cleve Moler and Charles Van Loan +11. Matrix Exponential in MATLAB. +-} +expScaledPade :: + (ArrMatrix.Homogeneous prop, ArrMatrix.Subtractive prop) => + (Layout.Packing pack, Omni.PowerStrip lower, Omni.PowerStrip upper) => + (Shape.C sh, Eq sh, + Class.Floating a, Scalar.RealOf a ~ ar, Class.Real ar) => + (Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a) -> + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +expScaledPade solve a0 = + let s = max 0 $ (1+) $ ceiling $ logBase 2 $ norm1 a0 + a = Matrix.scaleReal ((1/2)^s) a0 + (odds,evens) = deinterleave $ NonEmpty.tail expPadeCoefficients + Stream.Cons eye as = Matrix.powers a + (oddPowers,evenPowers) = deinterleave $ Stream.toList as + v = foldl (#+#) eye $ zipWith Matrix.scaleReal evens evenPowers + u = + fmap (NonEmpty.foldl1 (#+#)) $ NonEmpty.fetch $ + zipWith Matrix.scaleReal odds oddPowers + op vm f um = maybe vm (f vm) um + in nest s Matrix.square $ solve (op v (#-#) u) (op v (#+#) u) + +{- +Move to utility-ht. +Cf. storable-vector, synthesizer-core. +However, they differ in details. +-} +deinterleave :: [a] -> ([a],[a]) +deinterleave = + let go [] = ([],[]) + go (x:xs) = mapFst (x:) $ swap $ go xs + in go + +expPadeCoefficients :: (Class.Real a) => NonEmpty.T [] a +expPadeCoefficients = + let eps = Scalar.selectReal 1e-8 1e-16 + q = expPadeOrder eps + coeff k = fromIntegral (q-k+1) / fromIntegral (k*(2*q-k+1)) + in NonEmpty.scanl (*) (1 `asTypeOf` eps) $ map coeff [1..q] + +expPadeOrder :: (Class.Real a) => a -> Int +expPadeOrder eps = + let factorials = scanl (*) 1 $ iterate (1+) 1 + in subtract 1 $ length $ takeWhile id $ + zipWith3 (\num den twoPower -> num > den*twoPower*eps) + factorials (ListHT.sieve 2 factorials) (iterate (2*) 1) + + +{- | +Mathematically the name 'expRealSymmetric' would be more common, +but we support definiteness tags only for the 'Hermitian' type. +Formally the result is always positive definite, +but negative eigenvalues easily yield numerically singular matrices as result. +-} +expRealHermitian :: + (Layout.Packing pack, Shape.C sh, Class.Real a) => + HermitianP pack sh a -> HermitianPosSemidefP pack sh a +expRealHermitian = + Hermitian.relaxSemidefinite . + Hermitian.assurePositiveDefiniteness . + exp + + +class (MatrixShape.Property property) => Log property where + log :: + (Layout.Packing pack, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Shape.C sh, Class.Real a) => + Quadratic pack property lower upper sh a -> + Quadratic pack property lower upper sh a + +instance Log Omni.Arbitrary where + log = liftReal P.log + +instance + (neg ~ True, zero ~ True, pos ~ True) => + Log (Omni.Hermitian neg zero pos) where + log = liftReal P.log + +instance Log Omni.Symmetric where + log = liftReal P.log + + +logUnipotentUpper :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + UnitUpperP pack sh a -> UpperP pack sh a +logUnipotentUpper = logUnipotent . Triangular.relaxUnitDiagonal + +{- | +Logarithm for unipotent matrices. +It is an unchecked error, if the matrix is not unipotent. +-} +logUnipotent :: + (Layout.Packing pack, Omni.PowerStrip lower, Omni.PowerStrip upper) => + (ArrMatrix.Scale prop, ArrMatrix.Subtractive prop) => + (Shape.C sh, Class.Floating a) => + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +logUnipotent a = + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> logUnipotentAux a + Scalar.Complex -> logUnipotentAux a + +-- cf. numeric-prelude:PowerSeries +logUnipotentAux :: + (Layout.Packing pack, Omni.PowerStrip lower, Omni.PowerStrip upper) => + (ArrMatrix.Scale prop, ArrMatrix.Subtractive prop) => + (Shape.C sh, Class.Floating a, Scalar.RealOf a ~ ar, Class.Real ar) => + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +logUnipotentAux = applyUnchecked $ \a -> + let b = a #-# Matrix.identityFrom a + in foldl (#+#) (ArrMatrix.zero $ ArrMatrix.shape b) $ + zipWith ArrMatrix.scale + (zipWith (/) (cycle [1,-1]) (iterate (1+) 1)) + (Stream.takeWhile ((0<) . normInf) $ Matrix.powers1 b) + + +class (MatrixShape.Property property) => LiftReal property where + {- | + Lift any function with a Taylor expansion + to a diagonalizable matrix. + -} + liftReal :: + (Layout.Packing pack, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Shape.C sh, Class.Real a) => + (a -> a) -> + Quadratic pack property lower upper sh a -> + Quadratic pack property lower upper sh a + +{- | +Generic algorithm that applies a scalar function +to the elements of the diagonal factor +of a full, triangular or diagonal matrix with distinct eigenvalues. +It is not checked whether the matrix has distinct eigenvalues. +-} +instance LiftReal Omni.Arbitrary where + liftReal f a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerDiagonal -> liftDiagonal f a + Omni.PowerUpperTriangular -> flip applyUnchecked a $ \b -> + let (vr,d,vlAdj) = Triangular.eigensystem b + scal = Triangular.takeDiagonal $ vlAdj <> vr + in ArrMosaic.assureMirrored $ + Triangular.toSquare vr + #*\ Vector.divide (Array.map f d) scal + ##*# vlAdj + Omni.PowerLowerTriangular -> flip applyUnchecked a $ \b -> + let (vr,d,vlAdj) = Triangular.eigensystem b + scal = Triangular.takeDiagonal $ vlAdj <> vr + in ArrMosaic.assureMirrored $ + Triangular.toSquare vr + #*\ Vector.divide (Array.map f d) scal + ##*# vlAdj + Omni.PowerFull -> + case Scalar.precisionOfFunctor a of + Scalar.Float -> liftRealFull f a + Scalar.Double -> liftRealFull f a + +liftRealFull :: + (MatrixShape.Property prop, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Shape.C sh, Class.Real a, Scalar.RealOf a ~ a) => + (a -> a) -> + Quadratic Layout.Unpacked prop lower upper sh a -> + Quadratic Layout.Unpacked prop lower upper sh a +liftRealFull f = applyPermutable $ applyUnchecked $ \a -> + let (vr,d,vlAdj) = Square.eigensystem $ Matrix.toFull a + vrR = matrixRealPart vr + vlAdjR = matrixRealPart vlAdj + dR = Array.map Complex.realPart d + scal = Square.takeDiagonal $ vlAdjR <> vrR + in if Scalar.isZero $ Vector.normInf $ Array.map Complex.imagPart d + then ArrMatrix.liftUnpacked1 id $ + vrR #*\ Vector.divide (Array.map f dR) scal ##*# vlAdjR + else error "liftReal: non-real eigenvalues" + +matrixRealPart :: + (ArrayMatrix pack property lower upper meas vert horiz height width ~ matrix, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Real a) => + matrix (Complex a) -> matrix a +matrixRealPart = + ArrMatrix.Array . Array.map Complex.realPart . ArrMatrix.unwrap + + +instance + (neg ~ True, zero ~ True, pos ~ True) => + LiftReal (Omni.Hermitian neg zero pos) where + liftReal f a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerDiagonal -> liftHermitianDiagonal f a + Omni.PowerHermitian -> liftHermitianReal f a + _ -> error "Hermitian.liftReal: impossible shape" + +instance LiftReal Omni.Symmetric where + liftReal f a = + case Omni.powerSingleton $ ArrMatrix.shape a of + Omni.PowerSymmetric -> + Symmetric.fromHermitian . + liftHermitianReal f . Hermitian.fromSymmetric $ a + _ -> error "Symmetric.liftReal: impossible shape" + +liftHermitianReal :: + (Layout.Packing pack, Shape.C sh, Class.Real a) => + (a -> a) -> HermitianP pack sh a -> HermitianP pack sh a +liftHermitianReal f a = + case Scalar.precisionOfFunctor a of + Scalar.Float -> liftHermitian f a + Scalar.Double -> liftHermitian f a + + +norm1 :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + ArrMatrix.ArrayMatrix pack prop lower upper meas vert horiz height width a -> + Scalar.RealOf a +norm1 = Vector.norm1 . ArrMatrix.unwrap + +normInf :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + ArrMatrix.ArrayMatrix pack prop lower upper meas vert horiz height width a -> + Scalar.RealOf a +normInf = Vector.normInf . ArrMatrix.unwrap + + +liftDiagonal :: + (Layout.Packing pack, Shape.C sh, Class.Floating a, Class.Floating b) => + (a -> b) -> + Quadratic pack Omni.Arbitrary Layout.Empty Layout.Empty sh a -> + Quadratic pack Omni.Arbitrary Layout.Empty Layout.Empty sh b +liftDiagonal f = Diagonal.lift $ Array.map f + +liftHermitianDiagonal :: + (Layout.Packing pack, + Bool.C neg, Bool.C zero, Bool.C pos, Omni.Hermitian neg zero pos ~ herm, + Shape.C sh, Class.Floating a, Class.Floating b) => + (a -> b) -> + Quadratic pack herm Layout.Empty Layout.Empty sh a -> + Quadratic pack herm Layout.Empty Layout.Empty sh b +liftHermitianDiagonal f a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 (Array.map f) a + Layout.Unpacked -> + let b = Square.diagonal $ Array.map f $ Quad.takeDiagonal a + in ArrMatrix.liftUnpacked1 id $ + if ArrMatrix.order a == ArrMatrix.order b + then b + else Square.transpose b + +liftHermitian :: + (Layout.Packing pack, + Bool.C neg, Bool.C zero, Bool.C pos, Omni.Hermitian neg zero pos ~ herm, + Shape.C sh, Class.Floating a, Scalar.RealOf a ~ ar, Storable ar) => + (ar -> ar) -> + Quadratic pack herm Layout.Filled Layout.Filled sh a -> + Quadratic pack herm Layout.Filled Layout.Filled sh a +liftHermitian f = applyPermutable $ applyUnchecked $ \a -> + let (q,d) = Hermitian.eigensystem a + in ArrMatrix.lift1 id $ + Hermitian.congruenceDiagonalAdjoint (Square.toFull q) (Array.map f d) + + +applyPermutable :: + (Shape.C sh, Class.Floating a) => + (Quadratic pack prop lower upper (ExtShape.IntIndexed sh) a -> + Quadratic pack prop lower upper (ExtShape.IntIndexed sh) a) -> + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +applyPermutable f = + Quad.mapSize ExtShape.deconsIntIndexed . + f . + Quad.mapSize ExtShape.IntIndexed + +applyUnchecked :: + (Shape.C sh, Class.Floating a) => + (Quadratic pack prop lower upper (PrivShape.Unchecked sh) a -> + Quadratic pack prop lower upper (PrivShape.Unchecked sh) a) -> + Quadratic pack prop lower upper sh a -> + Quadratic pack prop lower upper sh a +applyUnchecked f = + Quad.mapSize PrivShape.deconsUnchecked . + f . + Quad.mapSize PrivShape.Unchecked diff --git a/src/Numeric/LAPACK/Matrix/Hermitian.hs b/src/Numeric/LAPACK/Matrix/Hermitian.hs --- a/src/Numeric/LAPACK/Matrix/Hermitian.hs +++ b/src/Numeric/LAPACK/Matrix/Hermitian.hs @@ -1,9 +1,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Hermitian ( + FlexHermitian, Hermitian, + HermitianPosDef, + HermitianPosSemidef, Transposition(..), + Hermitian.Semidefinite, + Hermitian.assureFullRank, + Hermitian.assureAnyRank, + Hermitian.relaxSemidefinite, + Hermitian.relaxIndefinite, + Hermitian.assurePositiveDefiniteness, + Hermitian.relaxDefiniteness, + Hermitian.asUnknownDefiniteness, + + pack, size, fromList, autoFromList, @@ -18,14 +32,19 @@ takeTopRight, takeBottomRight, + toSquare, + fromSymmetric, + + negate, + multiplyVector, - square, multiplyFull, + square, + outer, sumRank1, sumRank1NonEmpty, sumRank2, sumRank2NonEmpty, - toSquare, fromSymmetric, gramian, gramianAdjoint, congruenceDiagonal, congruenceDiagonalAdjoint, congruence, congruenceAdjoint, @@ -40,15 +59,34 @@ eigensystem, ) where -import qualified Numeric.LAPACK.Matrix.Hermitian.Eigen as Eigen import qualified Numeric.LAPACK.Matrix.Hermitian.Linear as Linear +import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear + as LinearPD +import qualified Numeric.LAPACK.Matrix.Hermitian.Eigen as Eigen import qualified Numeric.LAPACK.Matrix.Hermitian.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic + +import qualified Numeric.LAPACK.Matrix.Full as Full +import qualified Numeric.LAPACK.Matrix.Array.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as ArrUnpacked +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array.Triangular (Hermitian, Symmetric) -import Numeric.LAPACK.Matrix.Array (Full, General, Square) -import Numeric.LAPACK.Matrix.Shape.Private (Order) +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Array.Mosaic + (FlexHermitian, FlexHermitianP, + Hermitian, HermitianP, + HermitianPosSemidef, HermitianPosSemidefP, HermitianPosDef, + SymmetricP) +import Numeric.LAPACK.Matrix.Array (Full, General, Square, packTag) +import Numeric.LAPACK.Matrix.Layout.Private (Order) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed, Transposed)) import Numeric.LAPACK.Matrix.Private (ShapeInt) import Numeric.LAPACK.Vector (Vector) @@ -56,43 +94,66 @@ import qualified Numeric.Netlib.Class as Class +import qualified Type.Data.Bool as TBool +import Type.Data.Bool (True) + import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) - -import Foreign.Storable (Storable) +import Data.Array.Comfort.Shape ((::+)) import qualified Data.NonEmpty as NonEmpty import Data.Tuple.HT (mapFst) +import Prelude hiding (negate) -size :: Hermitian sh a -> sh -size = MatrixShape.hermitianSize . ArrMatrix.shape -fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Hermitian sh a -fromList order sh = ArrMatrix.lift0 . Basic.fromList order sh +size :: FlexHermitianP pack neg zero pos sh a -> sh +size = Omni.squareSize . ArrMatrix.shape -autoFromList :: (Storable a) => Order -> [a] -> Hermitian ShapeInt a -autoFromList order = ArrMatrix.lift0 . Basic.autoFromList order -identity :: (Shape.C sh, Class.Floating a) => Order -> sh -> Hermitian sh a -identity order = ArrMatrix.lift0 . Basic.identity order +fromList :: + (Shape.C sh, Class.Floating a) => Order -> sh -> [a] -> Hermitian sh a +fromList order sh = ArrMatrix.fromVector . Mosaic.fromList order sh +autoFromList :: (Class.Floating a) => Order -> [a] -> Hermitian ShapeInt a +autoFromList order = ArrMatrix.fromVector . Mosaic.autoFromList order + + +identity :: + (Shape.C sh, Class.Floating a) => + Order -> sh -> HermitianPosDef sh a +identity order = ArrMatrix.lift0 . Packed.identity order + diagonal :: (Shape.C sh, Class.Floating a) => Order -> Vector sh (RealOf a) -> Hermitian sh a diagonal order = ArrMatrix.lift0 . Basic.diagonal order takeDiagonal :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> Vector sh (RealOf a) + (TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Floating a) => + FlexHermitian neg zero pos sh a -> Vector sh (RealOf a) takeDiagonal = Basic.takeDiagonal . ArrMatrix.toVector forceOrder :: - (Shape.C sh, Class.Floating a) => - Order -> Hermitian sh a -> Hermitian sh a -forceOrder = ArrMatrix.lift1 . Basic.forceOrder + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Floating a) => + Order -> + FlexHermitianP pack neg zero pos sh a -> + FlexHermitianP pack neg zero pos sh a +forceOrder order a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 (Packed.forceOrder order) a + Layout.Unpacked -> ArrMatrix.liftUnpacked1 (FullBasic.forceOrder order) a + +pack :: + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> FlexHermitian neg zero pos sh a +pack = ArrMatrix.lift1 Mosaic.pack + + {- | > toSquare (stack a b c) > @@ -106,144 +167,235 @@ The function is most efficient when the order of all blocks match. -} stack :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - Hermitian sh0 a -> General sh0 sh1 a -> Hermitian sh1 a -> - Hermitian (sh0:+:sh1) a -stack = ArrMatrix.lift3 Basic.stack + (Layout.Packing pack, + Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => + HermitianP pack sh0 a -> General sh0 sh1 a -> HermitianP pack sh1 a -> + HermitianP pack (sh0::+sh1) a +stack a = + case packTag a of + Layout.Packed -> ArrMatrix.lift3 Packed.stackUpper a + Layout.Unpacked -> + ArrMatrix.liftUnpacked3 + (\a_ b_ c_ -> + FullBasic.stackMosaic a_ b_ (FullBasic.adjoint b_) c_) + a infixr 2 *%%%# (*%%%#) :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - (Hermitian sh0 a, General sh0 sh1 a) -> Hermitian sh1 a -> - Hermitian (sh0:+:sh1) a + (Layout.Packing pack, + Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => + (HermitianP pack sh0 a, General sh0 sh1 a) -> HermitianP pack sh1 a -> + HermitianP pack (sh0::+sh1) a (*%%%#) = uncurry stack +{- +The definiteness is transfered from the big matrix to its parts, +because it literally means to restrict the set of vectors in @x^T*A*x@ +to ones that have parts of the vectors zeroed. +-} split :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> - (Hermitian sh0 a, General sh0 sh1 a, Hermitian sh1 a) + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexHermitianP pack neg zero pos (sh0::+sh1) a -> + (FlexHermitianP pack neg zero pos sh0 a, + General sh0 sh1 a, + FlexHermitianP pack neg zero pos sh1 a) split a = (takeTopLeft a, takeTopRight a, takeBottomRight a) +{- | +Sub-matrices maintain definiteness of the original matrix. +Consider x^* A x > 0. +Then y^* (take A) y = x^* A x where some components of x are zero. +-} takeTopLeft :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> Hermitian sh0 a -takeTopLeft = ArrMatrix.lift1 Basic.takeTopLeft + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexHermitianP pack neg zero pos (sh0::+sh1) a -> + FlexHermitianP pack neg zero pos sh0 a +takeTopLeft a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeTopLeft a + Layout.Unpacked -> ArrUnpacked.takeTopLeft a takeTopRight :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> General sh0 sh1 a -takeTopRight = ArrMatrix.lift1 Basic.takeTopRight + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexHermitianP pack neg zero pos (sh0::+sh1) a -> General sh0 sh1 a +takeTopRight a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeTopRight a + Layout.Unpacked -> ArrUnpacked.takeTopRight a takeBottomRight :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> Hermitian sh1 a -takeBottomRight = ArrMatrix.lift1 Basic.takeBottomRight + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh0, Shape.C sh1, Class.Floating a) => + FlexHermitianP pack neg zero pos (sh0::+sh1) a -> + FlexHermitianP pack neg zero pos sh1 a +takeBottomRight a = + case packTag a of + Layout.Unpacked -> ArrUnpacked.takeBottomRight a + Layout.Packed -> ArrMatrix.lift1 Packed.takeBottomRight a -multiplyVector :: - (Shape.C sh, Eq sh, Class.Floating a) => - Transposition -> Hermitian sh a -> Vector sh a -> Vector sh a -multiplyVector order = Basic.multiplyVector order . ArrMatrix.toVector +negate :: + (TBool.C neg, TBool.C zero, TBool.C pos, Shape.C sh, Class.Floating a) => + Hermitian.AnyHermitianP pack neg zero pos bands sh a -> + Hermitian.AnyHermitianP pack pos zero neg bands sh a +negate a = + case ArrMatrix.shape a of + Omni.Full _ -> ArrMatrix.liftUnpacked1 Vector.negate a + Omni.Hermitian _ -> ArrMatrix.lift1 Vector.negate a + Omni.BandedHermitian _ -> ArrMatrix.lift1 Vector.negate a -square :: - (Shape.C sh, Eq sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -square = ArrMatrix.lift1 Basic.square +multiplyVector :: + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Eq sh, Class.Floating a) => + Transposition -> FlexHermitianP pack neg zero pos sh a -> + Vector sh a -> Vector sh a +multiplyVector trans = + (case trans of + NonTransposed -> Symmetric.multiplyVector + Transposed -> Symmetric.multiplyVector . Mosaic.transpose) . + ArrMatrix.toVector + multiplyFull :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Transposition -> Hermitian height a -> - Full vert horiz height width a -> - Full vert horiz height width a -multiplyFull = ArrMatrix.lift2 . Basic.multiplyFull + Transposition -> FlexHermitianP pack neg zero pos height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull trans = + ArrMatrix.lift2 $ + case trans of + NonTransposed -> Symmetric.multiplyFull + Transposed -> Symmetric.multiplyFull . Mosaic.transpose +square :: + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> + FlexHermitianP pack neg zero pos sh a +square = ArrMatrix.lift1 $ Mosaic.square Omni.Arbitrary + + outer :: - (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Hermitian sh a -outer order = ArrMatrix.lift0 . Basic.outer order + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> HermitianPosSemidefP pack sh a +outer order = ArrMatrix.lift0 . Symmetric.outerUpper order sumRank1 :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> sh -> [(RealOf a, Vector sh a)] -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(RealOf a, Vector sh a)] -> HermitianPosSemidefP pack sh a sumRank1 order sh = ArrMatrix.lift0 . Basic.sumRank1 order sh sumRank1NonEmpty :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> NonEmpty.T [] (RealOf a, Vector sh a) -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> + NonEmpty.T [] (RealOf a, Vector sh a) -> HermitianPosSemidefP pack sh a sumRank1NonEmpty order (NonEmpty.Cons x xs) = sumRank1 order (Array.shape $ snd x) (x:xs) sumRank2 :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> sh -> [(a, (Vector sh a, Vector sh a))] -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(a, (Vector sh a, Vector sh a))] -> HermitianP pack sh a sumRank2 order sh = ArrMatrix.lift0 . Basic.sumRank2 order sh sumRank2NonEmpty :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> NonEmpty.T [] (a, (Vector sh a, Vector sh a)) -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> + NonEmpty.T [] (a, (Vector sh a, Vector sh a)) -> HermitianP pack sh a sumRank2NonEmpty order (NonEmpty.Cons xy xys) = sumRank2 order (Array.shape $ fst $ snd xy) (xy:xys) toSquare :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Square sh a -toSquare = ArrMatrix.lift1 Basic.toSquare + (Layout.Packing pack, + TBool.C neg, TBool.C zero, TBool.C pos, Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> Square sh a +toSquare a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Symmetric.toSquare a + Layout.Unpacked -> ArrMatrix.liftUnpacked1 id a -fromSymmetric :: (Shape.C sh, Class.Real a) => Symmetric sh a -> Hermitian sh a +fromSymmetric :: + (Layout.Packing pack, Shape.C sh, Class.Real a) => + SymmetricP pack sh a -> HermitianP pack sh a fromSymmetric = - ArrMatrix.lift1 $ Array.mapShape MatrixShape.hermitianFromSymmetric + ArrMatrix.lift1 $ Array.mapShape Layout.hermitianFromSymmetric {- | gramian A = A^H * A -} gramian :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Hermitian width a -gramian = ArrMatrix.lift1 Basic.gramian + General height width a -> HermitianPosSemidefP pack width a +gramian = ArrMatrix.lift1 Symmetric.gramian {- | gramianAdjoint A = A * A^H = gramian (A^H) -} gramianAdjoint :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Hermitian height a -gramianAdjoint = ArrMatrix.lift1 Basic.gramianAdjoint + General height width a -> HermitianPosSemidefP pack height a +gramianAdjoint = ArrMatrix.lift1 Symmetric.gramianTransposed {- | congruenceDiagonal D A = A^H * D * A -} congruenceDiagonal :: + (Layout.Packing pack) => (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Vector height (RealOf a) -> General height width a -> Hermitian width a -congruenceDiagonal = ArrMatrix.lift1 . Basic.congruenceDiagonal + Vector height (RealOf a) -> General height width a -> HermitianP pack width a +congruenceDiagonal = ArrMatrix.lift1 . Symmetric.congruenceRealDiagonal {- | congruenceDiagonalAdjoint A D = A * D * A^H -} congruenceDiagonalAdjoint :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Vector width (RealOf a) -> Hermitian height a + General height width a -> Vector width (RealOf a) -> HermitianP pack height a congruenceDiagonalAdjoint a = - ArrMatrix.lift0 . Basic.congruenceDiagonalAdjoint (ArrMatrix.toVector a) + ArrMatrix.lift0 . + Symmetric.congruenceRealDiagonalTransposed (ArrMatrix.toVector a) {- | congruence B A = A^H * B * A -} congruence :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Hermitian height a -> General height width a -> Hermitian width a -congruence = ArrMatrix.lift2 Basic.congruence + (Layout.Packing pack) => + (TBool.C neg, TBool.C pos, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + FlexHermitianP pack neg True pos height a -> + General height width a -> + FlexHermitianP pack neg True pos width a +congruence = + ArrMatrix.lift2 $ \b -> Symmetric.congruence (Mosaic.unpackDirty b) {- | congruenceAdjoint B A = A * B * A^H -} congruenceAdjoint :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Hermitian width a -> Hermitian height a -congruenceAdjoint = ArrMatrix.lift2 Basic.congruenceAdjoint + (Layout.Packing pack) => + (TBool.C neg, TBool.C pos, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + General height width a -> + FlexHermitianP pack neg True pos width a -> + FlexHermitianP pack neg True pos height a +congruenceAdjoint = + ArrMatrix.lift2 $ \a -> + Symmetric.congruenceTransposed a . Mosaic.unpackDirty {- | @@ -253,12 +405,15 @@ thus I like to call it Hermitian anticommutator. -} anticommutator :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> Hermitian width a -anticommutator = ArrMatrix.lift2 $ Basic.scaledAnticommutator one + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> HermitianP pack width a +anticommutator = + ArrMatrix.lift2 $ + Symmetric.scaledAnticommutator Layout.ConjugateMirror one {- | anticommutatorAdjoint A B @@ -266,56 +421,110 @@ = anticommutator (adjoint A) (adjoint B) -} anticommutatorAdjoint :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> Hermitian height a -anticommutatorAdjoint = ArrMatrix.lift2 $ Basic.scaledAnticommutatorAdjoint one + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> HermitianP pack height a +anticommutatorAdjoint = + ArrMatrix.lift2 $ + Symmetric.scaledAnticommutatorTransposed Layout.ConjugateMirror one {- | scaledAnticommutator alpha A B = alpha * A^H * B + conj alpha * B^H * A -} _scaledAnticommutator :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => a -> - Full vert horiz height width a -> - Full vert horiz height width a -> Hermitian width a -_scaledAnticommutator = ArrMatrix.lift2 . Basic.scaledAnticommutator + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> HermitianP pack width a +_scaledAnticommutator = + ArrMatrix.lift2 . + Symmetric.scaledAnticommutator Layout.ConjugateMirror {- | addAdjoint A = A^H + A -} -addAdjoint :: (Shape.C sh, Class.Floating a) => Square sh a -> Hermitian sh a -addAdjoint = ArrMatrix.lift1 Basic.addAdjoint +addAdjoint :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Square sh a -> HermitianP pack sh a +addAdjoint a = + let pck = Layout.autoPacking + in ArrMatrix.requirePacking pck $ + case pck of + Layout.Packed -> ArrMatrix.lift1 Symmetric.addMirrored a + Layout.Unpacked -> + ArrMatrix.liftUnpacked1 FullBasic.recheck $ + let au = ArrUnpacked.uncheck a + in ArrMatrix.add (Full.adjoint au) au solve :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve = ArrMatrix.lift2 Linear.solve + FlexHermitianP pack neg zero pos sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve a = + case Omni.hermitianSet $ ArrMatrix.shape a of + (TBool.False, _, TBool.True) -> ArrMatrix.lift2 LinearPD.solve a + (TBool.True, _, TBool.False) -> + ArrMatrix.negate . ArrMatrix.lift2 LinearPD.solve (negate a) + _ -> ArrMatrix.lift2 Symmetric.solve a -inverse :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -inverse = ArrMatrix.lift1 Linear.inverse +inverse :: + (Layout.Packing pack, + TBool.C neg, TBool.C zero, TBool.C pos, Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> + FlexHermitianP pack neg zero pos sh a +inverse a = + case Omni.hermitianSet $ ArrMatrix.shape a of + (TBool.False, _, TBool.True) -> ArrMatrix.lift1 LinearPD.inverse a + (TBool.True, _, TBool.False) -> + negate $ ArrMatrix.lift1 LinearPD.inverse $ negate a + _ -> ArrMatrix.lift1 Symmetric.inverse a -determinant :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a -determinant = Linear.determinant . ArrMatrix.toVector +determinant :: + (Layout.Packing pack, + TBool.C neg, TBool.C zero, TBool.C pos, Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> RealOf a +determinant a = + case Omni.hermitianSet $ ArrMatrix.shape a of + (TBool.False, TBool.False, TBool.True) -> + LinearPD.determinant $ ArrMatrix.toVector a + (TBool.True, TBool.False, TBool.False) -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> determinantNegDef a + Scalar.Complex -> determinantNegDef a + _ -> Linear.determinant $ ArrMatrix.toVector a +determinantNegDef :: + (Layout.Packing pack, + Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + FlexHermitianP pack TBool.True TBool.False TBool.False sh a -> ar +determinantNegDef a = + OmniMatrix.signNegativeDeterminant (ArrMatrix.shape a) * + (LinearPD.determinant $ ArrMatrix.toVector $ negate a) + eigenvalues :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> Vector sh (RealOf a) + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + ExtShape.Permutable sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> Vector sh (RealOf a) eigenvalues = Eigen.values . ArrMatrix.toVector {- | For symmetric eigenvalue problems, @eigensystem@ and @schur@ coincide. -} eigensystem :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + ExtShape.Permutable sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> (Square sh a, Vector sh (RealOf a)) eigensystem = mapFst ArrMatrix.lift0 . Eigen.decompose . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Basic.hs @@ -1,63 +1,33 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Hermitian.Basic ( Hermitian, + HermitianP, Transposition(..), - fromList, - autoFromList, - recheck, - identity, diagonal, takeDiagonal, - forceOrder, - stack, - takeTopLeft, - takeTopRight, - takeBottomRight, - - multiplyVector, - multiplyFull, - square, power, - outer, sumRank1, sumRank2, - - toSquare, - gramian, gramianAdjoint, - congruenceDiagonal, congruenceDiagonalAdjoint, - congruence, congruenceAdjoint, - scaledAnticommutator, scaledAnticommutatorAdjoint, - addAdjoint, - - takeUpper, ) where -import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric -import qualified Numeric.LAPACK.Matrix.Triangular.Private as Triangular -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Split as Split +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Scalar as Scalar import Numeric.LAPACK.Matrix.Hermitian.Private (Diagonal(..), TakeDiagonal(..)) -import Numeric.LAPACK.Matrix.Triangular.Private - (forPointers, pack, unpack, unpackToTemp, - diagonalPointers, diagonalPointerPairs, - rowMajorPointers, columnMajorPointers) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), flipOrder, sideSwapFromOrder, - uploFromOrder) +import Numeric.LAPACK.Matrix.Symmetric.Unified (complement) +import Numeric.LAPACK.Matrix.Mosaic.Private + (forPointers, diagonalPointerPairs, + rowMajorPointers, columnMajorPointers, + withPacking, noLabel, applyFuncPair, triArg) +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor,ColumnMajor), uploFromOrder) import Numeric.LAPACK.Matrix.Modifier - (Transposition(NonTransposed, Transposed), transposeOrder, + (Transposition(NonTransposed, Transposed), Conjugation(Conjugated), conjugatedOnRowMajor) -import Numeric.LAPACK.Matrix.Private - (Full, General, Square, argSquare, ShapeInt, shapeInt) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (RealOf, zero, one) -import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) -import Numeric.LAPACK.Private - (fill, lacgv, realPtr, - copyConjugate, condConjugate, conjugateToTemp, condConjugateToTemp) +import Numeric.LAPACK.Scalar (RealOf, zero) +import Numeric.LAPACK.Private (fill, realPtr, condConjugate) import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.BLAS.FFI.Complex as BlasComplex @@ -66,59 +36,24 @@ import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape ((:+:)((:+:))) import Foreign.C.Types (CInt, CChar) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable, poke, peek) -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.Trans.Cont (ContT, evalContT) import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) import Data.Foldable (forM_) -import Data.Function.HT (powerAssociative) - -type Hermitian sh = Array (MatrixShape.Hermitian sh) - - -fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Hermitian sh a -fromList order sh = - CheckedArray.fromList (MatrixShape.Hermitian order sh) - -autoFromList :: (Storable a) => Order -> [a] -> Hermitian ShapeInt a -autoFromList order xs = - fromList order - (shapeInt $ MatrixShape.triangleExtent "Hermitian.autoFromList" $ - length xs) - xs - -uncheck :: Hermitian sh a -> Hermitian (Unchecked sh) a -uncheck = - Array.mapShape $ - \(MatrixShape.Hermitian order sh) -> - MatrixShape.Hermitian order (Unchecked sh) - -recheck :: Hermitian (Unchecked sh) a -> Hermitian sh a -recheck = - Array.mapShape $ - \(MatrixShape.Hermitian order (Unchecked sh)) -> - MatrixShape.Hermitian order sh +type Hermitian sh = Array (Layout.Hermitian sh) +type HermitianP pack sh = Array (Layout.HermitianP pack sh) -identity :: (Shape.C sh, Class.Floating a) => Order -> sh -> Hermitian sh a -identity order sh = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ - \triSize aPtr -> do - fill zero triSize aPtr - mapM_ (flip poke one) $ diagonalPointers order (Shape.size sh) aPtr - diagonal :: (Shape.C sh, Class.Floating a) => Order -> Vector sh (RealOf a) -> Hermitian sh a @@ -132,7 +67,7 @@ (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => Order -> Vector sh ar -> Hermitian sh a diagonalAux order (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + Array.unsafeCreateWithSize (Layout.hermitian order sh) $ \triSize aPtr -> do fill zero triSize aPtr withForeignPtr x $ \xPtr -> @@ -152,240 +87,93 @@ takeDiagonalAux :: (Shape.C sh, Storable a, RealOf a ~ ar, Storable ar) => Hermitian sh a -> Vector sh ar -takeDiagonalAux (Array (MatrixShape.Hermitian order sh) a) = +takeDiagonalAux (Array (Layout.Mosaic _pack _mirror _upper order sh) a) = Array.unsafeCreateWithSize sh $ \n xPtr -> withForeignPtr a $ \aPtr -> forM_ (diagonalPointerPairs order n xPtr aPtr) $ \(dstPtr,srcPtr) -> poke dstPtr =<< peek (realPtr srcPtr) -{- -This is not maximally efficient. -It fills up a whole square. -This wastes memory but enables more regular memory access patterns. -Additionally, it fills unused parts of the square with mirrored values. --} -forceOrder :: - (Shape.C sh, Class.Floating a) => - Order -> Hermitian sh a -> Hermitian sh a -forceOrder newOrder a = - if MatrixShape.hermitianOrder (Array.shape a) == newOrder - then a - else fromUpperPart $ Basic.forceOrder newOrder $ toSquare a - -fromUpperPart :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> Hermitian width a -fromUpperPart = Triangular.fromUpperPart MatrixShape.Hermitian - -{- -Naming is inconsistent to Triangular.takeUpper, -because here Hermitian is the input -and in Triangular.takeUpper, Triangular is the output. --} -takeUpper :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> - Array (MatrixShape.UpperTriangular MatrixShape.NonUnit sh) a -takeUpper = - Array.mapShape - (\(MatrixShape.Hermitian order sh) -> - MatrixShape.Triangular MatrixShape.NonUnit MatrixShape.upper order sh) - - -stack :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - Hermitian sh0 a -> General sh0 sh1 a -> Hermitian sh1 a -> - Hermitian (sh0:+:sh1) a -stack a b c = - let order = MatrixShape.fullOrder $ Array.shape b - in Triangular.stack "Hermitian" (MatrixShape.Hermitian order) - (forceOrder order a) b (forceOrder order c) - -takeTopLeft :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> Hermitian sh0 a -takeTopLeft = - Triangular.takeTopLeft - (\(MatrixShape.Hermitian order sh@(sh0:+:_sh1)) -> - (MatrixShape.Hermitian order sh0, (order,sh))) - -takeTopRight :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> General sh0 sh1 a -takeTopRight = - Triangular.takeTopRight (\(MatrixShape.Hermitian order sh) -> (order,sh)) - -takeBottomRight :: - (Shape.C sh0, Shape.C sh1, Class.Floating a) => - Hermitian (sh0:+:sh1) a -> Hermitian sh1 a -takeBottomRight = - Triangular.takeBottomRight - (\(MatrixShape.Hermitian order sh@(_sh0:+:sh1)) -> - (MatrixShape.Hermitian order sh1, (order,sh))) - - -multiplyVector :: - (Shape.C sh, Eq sh, Class.Floating a) => - Transposition -> Hermitian sh a -> Vector sh a -> Vector sh a -multiplyVector transposed - (Array (MatrixShape.Hermitian order shA) a) (Array shX x) = - Array.unsafeCreateWithSize shX $ \n yPtr -> do - Call.assert "Hermitian.multiplyVector: width shapes mismatch" (shA == shX) - evalContT $ do - let conj = conjugatedOnRowMajor $ transposeOrder transposed order - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- ContT $ withForeignPtr a - xPtr <- condConjugateToTemp conj n x - incxPtr <- Call.cint 1 - betaPtr <- Call.number zero - incyPtr <- Call.cint 1 - liftIO $ do - BlasGen.hpmv - uploPtr nPtr alphaPtr aPtr xPtr incxPtr betaPtr yPtr incyPtr - condConjugate conj nPtr yPtr incyPtr - - -square :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -square (Array shape@(MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate shape $ - Symmetric.square Conjugated order (Shape.size sh) a - -{- -Requires frequent unpacking and packing of triangles. --} -power :: - (Shape.C sh, Class.Floating a) => Integer -> Hermitian sh a -> Hermitian sh a -power n a0@(Array (MatrixShape.Hermitian order sh) _) = - recheck $ - powerAssociative - (\a b -> fromUpperPart $ multiplyFull NonTransposed a $ toSquare b) - (identity order $ Unchecked sh) - (uncheck a0) - n - - -multiplyFull :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, - Class.Floating a) => - Transposition -> Hermitian height a -> - Full vert horiz height width a -> - Full vert horiz height width a -multiplyFull transposed - (Array (MatrixShape.Hermitian orderA shA) a) - (Array shapeB@(MatrixShape.Full orderB extentB) b) = - Array.unsafeCreate shapeB $ \cPtr -> do - let (height,width) = Extent.dimensions extentB - Call.assert "Hermitian.multiplyFull: shapes mismatch" (shA == height) - let m0 = Shape.size height - let n0 = Shape.size width - let size = m0*m0 - evalContT $ do - let (side,(m,n)) = sideSwapFromOrder orderB (m0,n0) - sidePtr <- Call.char side - uploPtr <- Call.char $ uploFromOrder orderA - mPtr <- Call.cint m - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- unpackToTemp (unpack orderA) m0 a - ldaPtr <- Call.leadingDim m0 - incaPtr <- Call.cint 1 - sizePtr <- Call.cint size - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.leadingDim m - betaPtr <- Call.number zero - ldcPtr <- Call.leadingDim m - liftIO $ do - when (transposeOrder transposed orderA /= orderB) $ - lacgv sizePtr aPtr incaPtr - BlasGen.hemm sidePtr uploPtr - mPtr nPtr alphaPtr aPtr ldaPtr - bPtr ldbPtr betaPtr cPtr ldcPtr - - - withConjBuffer :: (Shape.C sh, Class.Floating a) => - Order -> sh -> Int -> Ptr a -> - (Ptr CChar -> Ptr CInt -> Ptr CInt -> IO ()) -> ContT r IO () -withConjBuffer order sh triSize aPtr act = do + Layout.PackingSingleton pack -> Order -> sh -> Int -> Ptr a -> + (Ptr CChar -> Int -> Ptr CInt -> Ptr CInt -> IO ()) -> ContT r IO () +withConjBuffer pack order sh triSize aPtr act = do uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint $ Shape.size sh + let n = Shape.size sh + nPtr <- Call.cint n incxPtr <- Call.cint 1 sizePtr <- Call.cint triSize liftIO $ do fill zero triSize aPtr - act uploPtr nPtr incxPtr + act uploPtr n nPtr incxPtr condConjugate (conjugatedOnRowMajor order) sizePtr aPtr incxPtr - -outer :: - (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Hermitian sh a -outer order (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ - \triSize aPtr -> - evalContT $ do - alphaPtr <- realOneArg aPtr - xPtr <- ContT $ withForeignPtr x - withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incxPtr -> - hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr + complement pack Conjugated order n aPtr +{- +Not easy to generalize to Symmetric +because LapackComplex.spr and LapackComplex.syr +expect complex parameter 'alpha'. +-} sumRank1 :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> sh -> [(RealOf a, Vector sh a)] -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(RealOf a, Vector sh a)] -> HermitianP pack sh a sumRank1 = getSumRank1 $ Class.switchFloating (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) (SumRank1 sumRank1Aux) -type SumRank1_ sh ar a = Order -> sh -> [(ar, Vector sh a)] -> Hermitian sh a +type SumRank1_ pack sh ar a = + Order -> sh -> [(ar, Vector sh a)] -> HermitianP pack sh a -newtype SumRank1 sh a = SumRank1 {getSumRank1 :: SumRank1_ sh (RealOf a) a} +newtype SumRank1 pack sh a = + SumRank1 {getSumRank1 :: SumRank1_ pack sh (RealOf a) a} sumRank1Aux :: - (Shape.C sh, Eq sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - SumRank1_ sh ar a + (Layout.Packing pack, Shape.C sh, Eq sh, + Class.Floating a, RealOf a ~ ar, Storable ar) => + SumRank1_ pack sh ar a sumRank1Aux order sh xs = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + let pack = Layout.autoPacking + in Array.unsafeCreateWithSize (Layout.hermitianP pack order sh) $ \triSize aPtr -> evalContT $ do alphaPtr <- Call.alloca - withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incxPtr -> + withConjBuffer pack order sh triSize aPtr $ \uploPtr n nPtr incxPtr -> do forM_ xs $ \(alpha, Array shX x) -> withForeignPtr x $ \xPtr -> do Call.assert "Hermitian.sumRank1: non-matching vector size" (sh==shX) poke alphaPtr alpha - hpr uploPtr nPtr alphaPtr xPtr incxPtr aPtr - - -type HPR_ a = - Ptr CChar -> Ptr CInt -> - Ptr (RealOf a) -> Ptr a -> Ptr CInt -> Ptr a -> IO () - -newtype HPR a = HPR {getHPR :: HPR_ a} - -hpr :: Class.Floating a => HPR_ a -hpr = - getHPR $ - Class.switchFloating - (HPR BlasReal.spr) (HPR BlasReal.spr) - (HPR BlasComplex.hpr) (HPR BlasComplex.hpr) + evalContT $ withPacking pack $ + case Scalar.complexSingletonOfFunctor aPtr of + Scalar.Real -> + applyFuncPair + (noLabel BlasReal.spr) (noLabel BlasReal.syr) + uploPtr nPtr alphaPtr xPtr incxPtr (triArg aPtr n) + Scalar.Complex -> + applyFuncPair + (noLabel BlasComplex.hpr) (noLabel BlasComplex.her) + uploPtr nPtr alphaPtr xPtr incxPtr (triArg aPtr n) +{- +Not easy to generalize to Symmetric +because there are no Complex.spr2 and Complex.syr2. +However, there is BlasComplex.syr2k. +-} sumRank2 :: - (Shape.C sh, Eq sh, Class.Floating a) => - Order -> sh -> [(a, (Vector sh a, Vector sh a))] -> Hermitian sh a + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(a, (Vector sh a, Vector sh a))] -> HermitianP pack sh a sumRank2 order sh xys = - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ + let pack = Layout.autoPacking + in Array.unsafeCreateWithSize (Layout.hermitianP pack order sh) $ \triSize aPtr -> evalContT $ do alphaPtr <- Call.alloca - withConjBuffer order sh triSize aPtr $ \uploPtr nPtr incPtr -> + withConjBuffer pack order sh triSize aPtr $ \uploPtr n nPtr incPtr -> do forM_ xys $ \(alpha, (Array shX x, Array shY y)) -> withForeignPtr x $ \xPtr -> withForeignPtr y $ \yPtr -> do @@ -394,281 +182,10 @@ Call.assert "Hermitian.sumRank2: non-matching y vector size" (sh==shY) poke alphaPtr alpha - BlasGen.hpr2 uploPtr nPtr alphaPtr xPtr incPtr yPtr incPtr aPtr - - -{- -It is not strictly necessary to keep the 'order'. -It would be neither more complicated nor less efficient -to change the order via the conversion. --} -toSquare, _toSquare :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> Square sh a -_toSquare (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate (MatrixShape.square order sh) $ \bPtr -> - evalContT $ do - let n = Shape.size sh - aPtr <- ContT $ withForeignPtr a - conjPtr <- conjugateToTemp (Shape.triangleSize n) a - liftIO $ do - unpack (flipOrder order) n conjPtr bPtr -- wrong - unpack order n aPtr bPtr - -toSquare (Array (MatrixShape.Hermitian order sh) a) = - Array.unsafeCreate (MatrixShape.square order sh) $ \bPtr -> - withForeignPtr a $ \aPtr -> - Symmetric.unpack Conjugated order (Shape.size sh) aPtr bPtr - - -gramian :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Hermitian width a -gramian (Array (MatrixShape.Full order extent) a) = - Array.unsafeCreate (MatrixShape.Hermitian order $ Extent.width extent) $ - \bPtr -> gramianIO order a bPtr $ gramianParameters order extent - -gramianParameters :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Order -> - Extent.Extent vert horiz height width -> - ((Int, Int), (Char, Char, Int)) -gramianParameters order extent = - let (height, width) = Extent.dimensions extent - n = Shape.size width - k = Shape.size height - in ((n,k), - case order of - ColumnMajor -> ('U', 'C', k) - RowMajor -> ('L', 'N', n)) - - -gramianAdjoint :: - (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Hermitian height a -gramianAdjoint (Array (MatrixShape.Full order extent) a) = - Array.unsafeCreate (MatrixShape.Hermitian order $ Extent.height extent) $ - \bPtr -> gramianIO order a bPtr $ gramianAdjointParameters order extent - -gramianAdjointParameters :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Order -> - Extent.Extent vert horiz height width -> - ((Int, Int), (Char, Char, Int)) -gramianAdjointParameters order extent = - let (height, width) = Extent.dimensions extent - n = Shape.size height - k = Shape.size width - in ((n,k), - case order of - ColumnMajor -> ('U', 'N', n) - RowMajor -> ('L', 'C', k)) - -{- -Another way to unify 'gramian' and 'gramianAdjoint' -would have been this function: - -> gramianConjugation :: -> Conjugation -> General height width a -> Hermitian width a - -with - -> gramianAdjoint a = gramianConjugation (transpose a) - -but I would like to have - -> order (gramianAdjoint a) = order a --} -gramianIO :: - (Class.Floating a) => - Order -> - ForeignPtr a -> Ptr a -> - ((Int, Int), (Char, Char, Int)) -> IO () -gramianIO order a bPtr ((n,k), (uplo,trans,lda)) = - evalContT $ do - uploPtr <- Call.char uplo - transPtr <- Call.char trans - nPtr <- Call.cint n - kPtr <- Call.cint k - alphaPtr <- realOneArg a - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.leadingDim lda - betaPtr <- realZeroArg a - cPtr <- Call.allocaArray (n*n) - ldcPtr <- Call.leadingDim n - liftIO $ do - herk uploPtr transPtr - nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr - pack order n cPtr bPtr - - -type HERK_ a = - Ptr CChar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr (RealOf a) -> Ptr a -> - Ptr CInt -> Ptr (RealOf a) -> Ptr a -> Ptr CInt -> IO () - -newtype HERK a = HERK {getHERK :: HERK_ a} - -herk :: Class.Floating a => HERK_ a -herk = - getHERK $ - Class.switchFloating - (HERK BlasReal.syrk) - (HERK BlasReal.syrk) - (HERK BlasComplex.herk) - (HERK BlasComplex.herk) - - -skipCheckCongruence :: - ((sh -> Unchecked sh) -> matrix0 -> matrix1) -> - (matrix1 -> Hermitian (Unchecked sh) a) -> matrix0 -> Hermitian sh a -skipCheckCongruence mapSize f a = - recheck $ f $ mapSize Unchecked a - - -congruenceDiagonal :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Vector height (RealOf a) -> General height width a -> Hermitian width a -congruenceDiagonal d = - skipCheckCongruence Basic.mapWidth $ \a -> - scaledAnticommutator 0.5 a $ Basic.scaleRowsReal d a - -congruenceDiagonalAdjoint :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Vector width (RealOf a) -> Hermitian height a -congruenceDiagonalAdjoint = - flip $ \d -> skipCheckCongruence Basic.mapHeight $ \a -> - scaledAnticommutatorAdjoint 0.5 a $ Basic.scaleColumnsReal d a - - -congruence :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Hermitian height a -> General height width a -> Hermitian width a -congruence b = - skipCheckCongruence Basic.mapWidth $ \a -> - scaledAnticommutator one a $ - Split.tallMultiplyR NonTransposed - (Split.takeHalf MatrixShape.hermitianOrder b) a - -congruenceAdjoint :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Hermitian width a -> Hermitian height a -congruenceAdjoint = - flip $ \b -> skipCheckCongruence Basic.mapHeight $ \a -> - scaledAnticommutatorAdjoint one a $ - Basic.swapMultiply (Split.tallMultiplyR Transposed) - a (Split.takeHalf MatrixShape.hermitianOrder b) - - -scaledAnticommutator :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - a -> - Full vert horiz height width a -> - Full vert horiz height width a -> Hermitian width a -scaledAnticommutator alpha arr (Array (MatrixShape.Full order extentB) b) = do - let (Array (MatrixShape.Full _ extentA) a) = Basic.forceOrder order arr - Array.unsafeCreate (MatrixShape.Hermitian order $ Extent.width extentB) $ - \cpPtr -> do - Call.assert "Hermitian.anticommutator: extents mismatch" - (extentA==extentB) - scaledAnticommutatorIO alpha order a b cpPtr $ - gramianParameters order extentB - -scaledAnticommutatorAdjoint :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - a -> - Full vert horiz height width a -> - Full vert horiz height width a -> Hermitian height a -scaledAnticommutatorAdjoint - alpha arr (Array (MatrixShape.Full order extentB) b) = do - let (Array (MatrixShape.Full _ extentA) a) = Basic.forceOrder order arr - Array.unsafeCreate (MatrixShape.Hermitian order $ Extent.height extentB) $ - \cpPtr -> do - Call.assert "Hermitian.anticommutatorAdjoint: extents mismatch" - (extentA==extentB) - scaledAnticommutatorIO alpha order a b cpPtr $ - gramianAdjointParameters order extentB - -scaledAnticommutatorIO :: - (Class.Floating a) => - a -> - Order -> ForeignPtr a -> ForeignPtr a -> Ptr a -> - ((Int, Int), (Char, Char, Int)) -> IO () -scaledAnticommutatorIO alpha order a b cpPtr ((n,k), (uplo,trans,lda)) = - evalContT $ do - uploPtr <- Call.char uplo - transPtr <- Call.char trans - nPtr <- Call.cint n - kPtr <- Call.cint k - alphaPtr <- Call.number alpha - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.leadingDim lda - bPtr <- ContT $ withForeignPtr b - let ldbPtr = ldaPtr - betaPtr <- realZeroArg aPtr - cPtr <- Call.allocaArray (n*n) - ldcPtr <- Call.leadingDim n - liftIO $ do - her2k uploPtr transPtr nPtr kPtr alphaPtr - aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr - pack order n cPtr cpPtr - - -type HER2K_ a = - Ptr CChar -> Ptr CChar -> Ptr CInt -> Ptr CInt -> Ptr a -> - Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> - Ptr (RealOf a) -> Ptr a -> Ptr CInt -> IO () - -newtype HER2K a = HER2K {getHER2K :: HER2K_ a} - -her2k :: Class.Floating a => HER2K_ a -her2k = - getHER2K $ - Class.switchFloating - (HER2K BlasReal.syr2k) - (HER2K BlasReal.syr2k) - (HER2K BlasComplex.her2k) - (HER2K BlasComplex.her2k) - - -addAdjoint, _addAdjoint :: - (Shape.C sh, Class.Floating a) => Square sh a -> Hermitian sh a -_addAdjoint = - argSquare $ \order sh a -> - Array.unsafeCreateWithSize (MatrixShape.Hermitian order sh) $ \bSize bPtr -> do - let n = Shape.size sh - evalContT $ do - alphaPtr <- Call.number one - incxPtr <- Call.cint 1 - aPtr <- ContT $ withForeignPtr a - sizePtr <- Call.cint bSize - conjPtr <- Call.allocaArray bSize - liftIO $ do - pack order n aPtr bPtr - pack (flipOrder order) n aPtr conjPtr -- wrong - lacgv sizePtr conjPtr incxPtr - BlasGen.axpy sizePtr alphaPtr conjPtr incxPtr bPtr incxPtr - -addAdjoint = - argSquare $ \order sh a -> - Array.unsafeCreate (MatrixShape.Hermitian order sh) $ \bPtr -> do - let n = Shape.size sh - evalContT $ do - alphaPtr <- Call.number one - incxPtr <- Call.cint 1 - incnPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - liftIO $ case order of - RowMajor -> - forPointers (rowMajorPointers n aPtr bPtr) $ - \nPtr (srcPtr,dstPtr) -> do - copyConjugate nPtr srcPtr incnPtr dstPtr incxPtr - BlasGen.axpy nPtr alphaPtr srcPtr incxPtr dstPtr incxPtr - ColumnMajor -> - forPointers (columnMajorPointers n aPtr bPtr) $ - \nPtr ((srcRowPtr,srcColumnPtr),dstPtr) -> do - copyConjugate nPtr srcRowPtr incnPtr dstPtr incxPtr - BlasGen.axpy nPtr alphaPtr srcColumnPtr incxPtr dstPtr incxPtr + evalContT $ withPacking pack $ + applyFuncPair (noLabel BlasGen.hpr2) (noLabel BlasGen.her2) + uploPtr nPtr + alphaPtr xPtr incPtr yPtr incPtr (triArg aPtr n) _pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () @@ -685,23 +202,3 @@ forPointers (rowMajorPointers n fullPtr packedPtr) $ \nPtr (srcPtr,dstPtr) -> BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr - - -realZeroArg, realOneArg :: - (Class.Floating a) => f a -> ContT r IO (Ptr (RealOf a)) -realZeroArg = - runRealArg $ - Class.switchFloating - (RealArg $ const $ Call.number zero) - (RealArg $ const $ Call.number zero) - (RealArg $ const $ Call.number zero) - (RealArg $ const $ Call.number zero) -realOneArg = - runRealArg $ - Class.switchFloating - (RealArg $ const $ Call.number one) - (RealArg $ const $ Call.number one) - (RealArg $ const $ Call.number one) - (RealArg $ const $ Call.number one) - -newtype RealArg f g a = RealArg {runRealArg :: f a -> g (Ptr (RealOf a))} diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs --- a/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Eigen.hs @@ -1,19 +1,22 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Hermitian.Eigen ( values, decompose, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) -import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..)) +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Scalar as Scalar +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian, HermitianP) import Numeric.LAPACK.Matrix.Square.Basic (Square) -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), uploFromOrder) +import Numeric.LAPACK.Matrix.Layout.Private (Order(ColumnMajor), uploFromOrder) import Numeric.LAPACK.Matrix.Modifier (conjugatedOnRowMajor) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) import Numeric.LAPACK.Private - (copyToTemp, copyCondConjugateToTemp, withInfo, eigenMsg) + (copyToTemp, copyCondConjugate, copyCondConjugateToTemp, + withAutoWorkspaceInfo, withInfo, eigenMsg) import qualified Numeric.LAPACK.FFI.Complex as LapackComplex import qualified Numeric.LAPACK.FFI.Real as LapackReal @@ -22,33 +25,36 @@ import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as ArrayIO import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) import Data.Array.Comfort.Shape (triangleSize) import Foreign.C.Types (CInt, CChar) import Foreign.Ptr (Ptr, nullPtr) +import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable (Storable) -import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) -import Data.Complex (Complex) - values :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> Vector sh (RealOf a) -values = - runTakeDiagonal $ - Class.switchFloating - (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) - (TakeDiagonal valuesAux) (TakeDiagonal valuesAux) + (ExtShape.Permutable sh, Class.Floating a) => + HermitianP pack sh a -> Vector sh (RealOf a) +values a = + case Layout.mosaicPack $ Array.shape a of + Layout.Packed -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> valuesPacked a + Scalar.Complex -> valuesPacked a + Layout.Unpacked -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> valuesUnpacked a + Scalar.Complex -> valuesUnpacked a -valuesAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => +valuesPacked :: + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => Hermitian sh a -> Vector sh ar -valuesAux (Array (MatrixShape.Hermitian order size) a) = +valuesPacked (Array (Layout.Mosaic _pack _mirror _upper order size) a) = Array.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do jobzPtr <- Call.char 'N' @@ -59,25 +65,40 @@ liftIO $ withInfo eigenMsg "hpev" $ hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr +valuesUnpacked :: + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + HermitianP Layout.Unpacked sh a -> Vector sh ar +valuesUnpacked (Array (Layout.Mosaic _pack _mirror _upper order size) a) = + Array.unsafeCreateWithSize size $ \n wPtr -> + evalContT $ do + jobzPtr <- Call.char 'N' + uploPtr <- Call.char $ uploFromOrder order + aPtr <- copyToTemp (n*n) a + ldaPtr <- Call.leadingDim n + liftIO $ + withAutoWorkspaceInfo eigenMsg "heev" $ + heev jobzPtr uploPtr n aPtr ldaPtr wPtr -decompose :: - (Shape.C sh, Class.Floating a) => - Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) -decompose = - getDecompose $ - Class.switchFloating - (Decompose decomposeAux) (Decompose decomposeAux) - (Decompose decomposeAux) (Decompose decomposeAux) -type Decompose_ sh a = Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) - -newtype Decompose sh a = Decompose {getDecompose :: Decompose_ sh a} +decompose :: + (ExtShape.Permutable sh, Class.Floating a) => + HermitianP pack sh a -> (Square sh a, Vector sh (RealOf a)) +decompose a = + case Layout.mosaicPack $ Array.shape a of + Layout.Packed -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> decomposePacked a + Scalar.Complex -> decomposePacked a + Layout.Unpacked -> + case Scalar.complexSingletonOfFunctor a of + Scalar.Real -> decomposeUnpacked a + Scalar.Complex -> decomposeUnpacked a -decomposeAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => - Decompose_ sh a -decomposeAux (Array (MatrixShape.Hermitian order size) a) = - Array.unsafeCreateWithSizeAndResult (MatrixShape.square ColumnMajor size) $ +decomposePacked :: + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + Hermitian sh a -> (Square sh a, Vector sh (RealOf a)) +decomposePacked (Array (Layout.Mosaic _pack _mirror _upper order size) a) = + Array.unsafeCreateWithSizeAndResult (Layout.square ColumnMajor size) $ \_ zPtr -> ArrayIO.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do @@ -89,34 +110,60 @@ liftIO $ withInfo eigenMsg "hpev" $ hpev jobzPtr uploPtr n aPtr wPtr zPtr ldzPtr - -type HPEV_ ar a = - Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr ar -> +hpev :: + (Class.Floating a) => + Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr (RealOf a) -> Ptr a -> Ptr CInt -> Ptr CInt -> IO () +hpev jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = evalContT $ do + nPtr <- Call.cint n + case Scalar.complexSingletonOfFunctor apPtr of + Scalar.Real -> do + workPtr <- Call.allocaArray (3*n) + liftIO $ + LapackReal.spev jobzPtr uploPtr + nPtr apPtr wPtr zPtr ldzPtr workPtr infoPtr + Scalar.Complex -> do + workPtr <- Call.allocaArray (max 1 (2*n-1)) + rworkPtr <- Call.allocaArray (max 1 (3*n-2)) + liftIO $ + LapackComplex.hpev jobzPtr uploPtr + nPtr apPtr wPtr zPtr ldzPtr workPtr rworkPtr infoPtr -newtype HPEV a = HPEV {getHPEV :: HPEV_ (RealOf a) a} -hpev :: Class.Floating a => HPEV_ (RealOf a) a -hpev = - getHPEV $ - Class.switchFloating - (HPEV spevReal) (HPEV spevReal) (HPEV hpevComplex) (HPEV hpevComplex) - -spevReal :: Class.Real a => HPEV_ a a -spevReal jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = +decomposeUnpacked :: + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + HermitianP Layout.Unpacked sh a -> (Square sh a, Vector sh (RealOf a)) +decomposeUnpacked + (Array (Layout.Mosaic _pack _mirror _upper order size) a) = + Array.unsafeCreateWithSizeAndResult (Layout.square ColumnMajor size) $ + \squareSize vPtr -> + ArrayIO.unsafeCreateWithSize size $ \n wPtr -> evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (3*n) - liftIO $ - LapackReal.spev - jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr infoPtr + jobzPtr <- Call.char 'V' + uploPtr <- Call.char $ uploFromOrder order + sizePtr <- Call.cint squareSize + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim n + incPtr <- Call.cint 1 + liftIO $ do + copyCondConjugate (conjugatedOnRowMajor order) + sizePtr aPtr incPtr vPtr incPtr + withAutoWorkspaceInfo eigenMsg "heev" $ + heev jobzPtr uploPtr n vPtr ldaPtr wPtr -hpevComplex :: Class.Real a => HPEV_ a (Complex a) -hpevComplex jobzPtr uploPtr n apPtr wPtr zPtr ldzPtr infoPtr = - evalContT $ do - nPtr <- Call.cint n - workPtr <- Call.allocaArray (max 1 (2*n-1)) - rworkPtr <- Call.allocaArray (max 1 (3*n-2)) - liftIO $ - LapackComplex.hpev - jobzPtr uploPtr nPtr apPtr wPtr zPtr ldzPtr workPtr rworkPtr infoPtr +heev :: + (Class.Floating a) => + Ptr CChar -> Ptr CChar -> Int -> Ptr a -> Ptr CInt -> + Ptr (RealOf a) -> Ptr a -> Ptr CInt -> Ptr CInt -> IO () +heev jobzPtr uploPtr n aPtr ldaPtr wPtr workPtr lworkPtr infoPtr = + evalContT $ do + nPtr <- Call.cint n + liftIO $ case Scalar.complexSingletonOfFunctor aPtr of + Scalar.Real -> + LapackReal.syev jobzPtr uploPtr nPtr aPtr ldaPtr wPtr + workPtr lworkPtr infoPtr + Scalar.Complex -> evalContT $ do + rworkPtr <- Call.allocaArray (max 1 (3*n-2)) + liftIO $ + LapackComplex.heev jobzPtr uploPtr nPtr aPtr ldaPtr wPtr + workPtr lworkPtr rworkPtr infoPtr diff --git a/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs b/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs --- a/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/Hermitian/Linear.hs @@ -1,60 +1,33 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Matrix.Hermitian.Linear ( - solve, - inverse, determinant, ) where -import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import Numeric.LAPACK.Matrix.Hermitian.Basic (HermitianP) import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) -import Numeric.LAPACK.Matrix.Modifier (Conjugation(Conjugated)) -import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Scalar (RealOf, absoluteSquared) import Numeric.LAPACK.Private (realPtr) import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import System.IO.Unsafe (unsafePerformIO) - import Foreign.Ptr (Ptr) import Foreign.Storable (peek) -solve :: - (Extent.C vert, Extent.C horiz, - Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve (Array (MatrixShape.Hermitian orderA shA) a) = - Symmetric.solve "Hermitian.solve" Conjugated orderA shA a - - -inverse :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a -inverse (Array shape@(MatrixShape.Hermitian order sh) a) = - Array.unsafeCreateWithSize shape $ - Symmetric.inverse Conjugated order (Shape.size sh) a - - -determinant :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a +determinant :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + HermitianP pack sh a -> RealOf a determinant = getDeterminant $ Class.switchFloating - (Determinant determinantAux) (Determinant determinantAux) - (Determinant determinantAux) (Determinant determinantAux) - -determinantAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian sh a -> ar -determinantAux (Array (MatrixShape.Hermitian order sh) a) = - unsafePerformIO $ - Symmetric.determinant Conjugated - peekBlockDeterminant order (Shape.size sh) a + (Determinant $ Symmetric.determinant peekBlockDeterminant) + (Determinant $ Symmetric.determinant peekBlockDeterminant) + (Determinant $ Symmetric.determinant peekBlockDeterminant) + (Determinant $ Symmetric.determinant peekBlockDeterminant) peekBlockDeterminant :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => diff --git a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs --- a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs +++ b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite.hs @@ -1,4 +1,13 @@ +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.HermitianPositiveDefinite ( + Hermitian.Semidefinite, + Hermitian.assureFullRank, + Hermitian.assureAnyRank, + Hermitian.relaxSemidefinite, + Hermitian.relaxIndefinite, + Hermitian.assurePositiveDefiniteness, + Hermitian.relaxDefiniteness, + solve, solveDecomposed, inverse, @@ -8,9 +17,11 @@ import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear as Linear +import qualified Numeric.LAPACK.Matrix.Array.Hermitian as Hermitian import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array.Triangular (Hermitian, Upper) +import Numeric.LAPACK.Matrix.Array.Mosaic (HermitianPosDefP, UpperP) import Numeric.LAPACK.Matrix.Array (Full) import Numeric.LAPACK.Scalar (RealOf) @@ -19,10 +30,12 @@ import qualified Data.Array.Comfort.Shape as Shape + solve :: - (Extent.C vert, Extent.C horiz, - Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Layout.Packing pack, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + HermitianPosDefP pack sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a solve = ArrMatrix.lift2 Linear.solve {- | @@ -30,19 +43,26 @@ > solve (gramian u) b == solveDecomposed u b -} solveDecomposed :: - (Extent.C vert, Extent.C horiz, - Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Upper sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Layout.Packing pack, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + UpperP pack sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a solveDecomposed = ArrMatrix.lift2 Linear.solveDecomposed -inverse :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a +inverse :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + HermitianPosDefP pack sh a -> HermitianPosDefP pack sh a inverse = ArrMatrix.lift1 Linear.inverse {- | Cholesky decomposition -} -decompose :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Upper sh a +decompose :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + HermitianPosDefP pack sh a -> UpperP pack sh a decompose = ArrMatrix.lift1 Linear.decompose -determinant :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a +determinant :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + HermitianPosDefP pack sh a -> RealOf a determinant = Linear.determinant . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs --- a/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/HermitianPositiveDefinite/Linear.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.HermitianPositiveDefinite.Linear ( solve, solveDecomposed, @@ -7,18 +8,21 @@ determinant, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Hermitian.Basic (Hermitian) +import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(..)) -import Numeric.LAPACK.Matrix.Triangular.Basic (Upper, takeDiagonal) -import Numeric.LAPACK.Matrix.Triangular.Private (copyTriangleToTemp) -import Numeric.LAPACK.Matrix.Shape.Private (NonUnit(NonUnit), uploFromOrder) +import Numeric.LAPACK.Matrix.Mosaic.Private + (withPackingLinear, label, applyFuncPair, triArg, copyTriangleToTemp) +import Numeric.LAPACK.Matrix.Mosaic.Basic (takeDiagonal) +import Numeric.LAPACK.Matrix.Layout.Private (uploFromOrder) import Numeric.LAPACK.Matrix.Modifier (Conjugation(Conjugated)) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Linear.Private (solver) -import Numeric.LAPACK.Scalar (RealOf, realPart) -import Numeric.LAPACK.Private (copyBlock, withInfo, rankMsg, definiteMsg) +import Numeric.LAPACK.Scalar (RealOf, realPart, zero) +import Numeric.LAPACK.Private + (copySubTrapezoid, copyBlock, fill, rankMsg, definiteMsg) import qualified Numeric.LAPACK.FFI.Generic as LapackGen import qualified Numeric.Netlib.Utility as Call @@ -27,7 +31,6 @@ import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape (triangleSize) import Foreign.ForeignPtr (withForeignPtr) @@ -35,61 +38,95 @@ import Control.Monad.IO.Class (liftIO) +type Hermitian pack sh = Array (Layout.HermitianP pack sh) +type Upper pack sh = Array (Layout.UpperTriangularP pack sh) + solve :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Hermitian sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve (Array (MatrixShape.Hermitian orderA shA) a) = + Hermitian pack sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve (Array shape@(Layout.Mosaic pack _mirror _upper orderA shA) a) = solver "Hermitian.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do uploPtr <- Call.char $ uploFromOrder orderA - apPtr <- copyTriangleToTemp Conjugated orderA (triangleSize n) a - liftIO $ - withInfo definiteMsg "ppsv" $ - LapackGen.ppsv uploPtr nPtr nrhsPtr apPtr xPtr ldxPtr + aPtr <- copyTriangleToTemp Conjugated orderA (Shape.size shape) a + withPackingLinear definiteMsg pack $ + applyFuncPair + (label "ppsv" LapackGen.ppsv) + (label "posv" LapackGen.posv) + uploPtr nPtr nrhsPtr (triArg aPtr n) xPtr ldxPtr solveDecomposed :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Upper sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solveDecomposed (Array (MatrixShape.Triangular NonUnit _uplo orderA shA) a) = + Upper pack sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solveDecomposed + (Array + shape@(Layout.Mosaic pack Layout.NoMirror _upper orderA shA) + a) = solver "Hermitian.solveDecomposed" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do uploPtr <- Call.char $ uploFromOrder orderA - apPtr <- copyTriangleToTemp Conjugated orderA (triangleSize n) a - liftIO $ - withInfo rankMsg "pptrs" $ - LapackGen.pptrs uploPtr nPtr nrhsPtr apPtr xPtr ldxPtr + aPtr <- copyTriangleToTemp Conjugated orderA (Shape.size shape) a + withPackingLinear rankMsg pack $ + applyFuncPair + (label "pptrs" LapackGen.pptrs) + (label "potrs" LapackGen.potrs) + uploPtr nPtr nrhsPtr (triArg aPtr n) xPtr ldxPtr -inverse :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Hermitian sh a +inverse :: + (Shape.C sh, Class.Floating a) => Hermitian pack sh a -> Hermitian pack sh a inverse - (Array shape@(MatrixShape.Hermitian order sh) a) = + (Array shape@(Layout.Mosaic pack _mirror _upper order sh) a) = Array.unsafeCreateWithSize shape $ \triSize bPtr -> do + + let n = Shape.size sh evalContT $ do uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint $ Shape.size sh + nPtr <- Call.cint n aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo definiteMsg "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr - withInfo rankMsg "pptri" $ LapackGen.pptri uploPtr nPtr bPtr + liftIO $ copyBlock triSize aPtr bPtr + withPackingLinear definiteMsg pack $ + applyFuncPair + (label "pptrf" LapackGen.pptrf) + (label "potrf" LapackGen.potrf) + uploPtr nPtr (triArg bPtr n) + withPackingLinear rankMsg pack $ + applyFuncPair + (label "pptri" LapackGen.pptri) + (label "potri" LapackGen.potri) + uploPtr nPtr (triArg bPtr n) + Symmetric.complement pack Conjugated order n bPtr -decompose :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> Upper sh a +decompose :: + (Shape.C sh, Class.Floating a) => Hermitian pack sh a -> Upper pack sh a decompose - (Array (MatrixShape.Hermitian order sh) a) = + (Array (Layout.Mosaic pack _mirror upper order sh) a) = Array.unsafeCreateWithSize - (MatrixShape.Triangular NonUnit MatrixShape.upper order sh) $ - \triSize bPtr -> do + (Layout.Mosaic pack Layout.NoMirror upper order sh) $ + \triSize bPtr -> do evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint $ Shape.size sh + let uplo = uploFromOrder order + uploPtr <- Call.char uplo + let n = Shape.size sh + nPtr <- Call.cint n aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo definiteMsg "pptrf" $ LapackGen.pptrf uploPtr nPtr bPtr + let packed = + case pack of Layout.Packed -> True; Layout.Unpacked -> False + liftIO $ + if packed + then copyBlock triSize aPtr bPtr + else do + fill zero (n*n) bPtr + copySubTrapezoid uplo n n n aPtr n bPtr + withPackingLinear definiteMsg pack $ + applyFuncPair + (label "pptrf" LapackGen.pptrf) (label "potrf" LapackGen.potrf) + uploPtr nPtr (triArg bPtr n) -determinant :: (Shape.C sh, Class.Floating a) => Hermitian sh a -> RealOf a +determinant :: (Shape.C sh, Class.Floating a) => Hermitian pack sh a -> RealOf a determinant = getDeterminant $ Class.switchFloating @@ -98,7 +135,6 @@ determinantAux :: (Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian sh a -> ar + Hermitian pack sh a -> ar determinantAux = - (^(2::Int)) . product . map realPart . - Array.toList . takeDiagonal . decompose + (^(2::Int)) . Vector.product . Array.map realPart . takeDiagonal . decompose diff --git a/src/Numeric/LAPACK/Matrix/Indexed.hs b/src/Numeric/LAPACK/Matrix/Indexed.hs --- a/src/Numeric/LAPACK/Matrix/Indexed.hs +++ b/src/Numeric/LAPACK/Matrix/Indexed.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Indexed where -import qualified Numeric.LAPACK.Matrix.Plain.Indexed as ArrIndexed +import qualified Numeric.LAPACK.Matrix.Array.Indexed as ArrIndexed +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Type as Matrix import qualified Numeric.LAPACK.Permutation as Perm import Numeric.LAPACK.Matrix.Type (Matrix) import Numeric.LAPACK.Scalar (one, zero) @@ -11,28 +13,29 @@ import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable.Unchecked as UArray +import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable ((!)) infixl 9 #! -class (Type.Box typ) => Indexed typ where +class (Matrix.Box typ) => Indexed typ where (#!) :: - (Class.Floating a) => - Matrix typ a -> - (Shape.Index (Type.HeightOf typ), Shape.Index (Type.WidthOf typ)) -> a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + (Shape.Index height, Shape.Index width) -> a -instance (ArrIndexed.Indexed sh) => Indexed (ArrMatrix.Array sh) where - ArrMatrix.Array arr #! ij = arr ArrIndexed.#! ij +instance Indexed (ArrMatrix.Array pack property) where + (#!) a@(ArrMatrix.Array _) = (ArrIndexed.#!) a -instance (Shape.Indexed size) => Indexed (Type.Scale size) where - Type.Scale sh a #! (i,j) = +instance Indexed Matrix.Scale where + Matrix.Scale sh a #! (i,j) = if Shape.offset sh i == Shape.offset sh j then a else zero -instance (Shape.Indexed size) => Indexed (Permutation size) where - Type.Permutation (Permutation perm) #! (i,j) = - let psh@(Perm.Shape sh) = UArray.shape perm +instance Indexed Matrix.Permutation where + Matrix.Permutation (Permutation perm) #! (i,j) = + let psh@(Perm.Shape sh) = Array.shape perm reindex = Shape.indexFromOffset psh . Shape.offset sh in if perm ! reindex i == reindex j then one else zero diff --git a/src/Numeric/LAPACK/Matrix/Inverse.hs b/src/Numeric/LAPACK/Matrix/Inverse.hs --- a/src/Numeric/LAPACK/Matrix/Inverse.hs +++ b/src/Numeric/LAPACK/Matrix/Inverse.hs @@ -1,56 +1,117 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} module Numeric.LAPACK.Matrix.Inverse where -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Class as MatrixClass import qualified Numeric.LAPACK.Matrix.Divide as Divide import qualified Numeric.LAPACK.Matrix.Multiply as Multiply import Numeric.LAPACK.Matrix.Divide ((#\|), (-/#)) +import Numeric.LAPACK.Matrix.Type (Matrix) +import qualified Type.Data.Num.Unary as Unary + data Inverse typ -newtype instance Type.Matrix (Inverse typ) a = Inverse (Type.Matrix typ a) +data instance + Matrix (Inverse typ) + extraLower extraUpper lowerf upperf meas vert horiz height width a + where + Inverse :: + (Omni.Strip lower, Fill lower ~ lowerf, Omni.PowerStrip lowerf, + Omni.Strip upper, Fill upper ~ upperf, Omni.PowerStrip upperf) => + Matrix.QuadraticMeas typ xl xu upper lower meas width height a -> + Matrix.QuadraticMeas (Inverse typ) (xl,lower) (xu,upper) + lowerf upperf meas height width a +type family Fill offDiag +type instance Fill (Layout.Bands Unary.Zero) = Layout.Bands Unary.Zero +type instance Fill (Layout.Bands (Unary.Succ k)) = Layout.Filled +type instance Fill Layout.Filled = Layout.Filled -instance (Type.MultiplySame typ) => Type.MultiplySame (Inverse typ) where - multiplySame (Inverse a) (Inverse b) = Inverse $ Type.multiplySame b a +data PowerStripFact c = (Omni.PowerStrip c) => PowerStripFact -instance (Type.Box typ) => Type.Box (Inverse typ) where - type HeightOf (Inverse typ) = Type.HeightOf typ - type WidthOf (Inverse typ) = Type.WidthOf typ - height (Inverse m) = Type.height m - width (Inverse m) = Type.width m +filledPowerStripFact :: + (Omni.Strip c) => Omni.StripSingleton c -> PowerStripFact (Fill c) +filledPowerStripFact w = + case w of + Omni.StripFilled -> PowerStripFact + Omni.StripBands Unary.Zero -> PowerStripFact + Omni.StripBands Unary.Succ -> PowerStripFact + + +instance (Matrix.Transpose typ) => Matrix.Transpose (Inverse typ) where + transpose (Inverse a) = Inverse $ Matrix.transpose a + +instance + (Matrix.MultiplySame typ xl xu, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Matrix.MultiplySame (Inverse typ) (xl,lower) (xu,upper) where + multiplySame (Inverse a) (Inverse b) = Inverse $ Matrix.multiplySame b a + +instance (Matrix.Box typ) => Matrix.Box (Inverse typ) where + extent (Inverse m) = Extent.transpose $ Matrix.extent m + height (Inverse m) = Matrix.width m + width (Inverse m) = Matrix.height m + +instance (Matrix.ToQuadratic typ) => Matrix.ToQuadratic (Inverse typ) where + heightToQuadratic (Inverse m) = Inverse $ Matrix.widthToQuadratic m + widthToQuadratic (Inverse m) = Inverse $ Matrix.heightToQuadratic m + instance (MatrixClass.Complex typ) => MatrixClass.Complex (Inverse typ) where conjugate (Inverse m) = Inverse $ MatrixClass.conjugate m fromReal (Inverse m) = Inverse $ MatrixClass.fromReal m toComplex (Inverse m) = Inverse $ MatrixClass.toComplex m -instance (Divide.Solve typ) => Multiply.MultiplyVector (Inverse typ) where +instance + (Divide.Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper) => + Multiply.MultiplyVector (Inverse typ) (xl,lower) (xu,upper) where matrixVector (Inverse a) x = a#\|x vectorMatrix x (Inverse a) = x-/#a -instance (Divide.Solve typ) => Multiply.MultiplySquare (Inverse typ) where - transposableSquare trans (Inverse a) b = Divide.solve trans a b +instance + (Divide.Solve typ xl xu, Matrix.ToQuadratic typ, + Omni.Strip lower, Omni.Strip upper) => + Multiply.MultiplySquare (Inverse typ) (xl,lower) (xu,upper) where + transposableSquare trans (Inverse a) = Divide.solve trans a squareFull (Inverse a) b = Divide.solveRight a b fullSquare b (Inverse a) = Divide.solveLeft b a -instance (Multiply.Power typ) => Multiply.Power (Inverse typ) where +instance + (Multiply.Power typ xl xu, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Multiply.Power (Inverse typ) (xl,lower) (xu,upper) where square (Inverse a) = Inverse $ Multiply.square a power n (Inverse a) = Inverse $ Multiply.power n a + powers1 (Inverse a) = fmap Inverse $ Multiply.powers1 a -instance (Divide.Determinant typ) => Divide.Determinant (Inverse typ) where +instance + (Divide.Determinant typ xl xu, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Divide.Determinant (Inverse typ) (xl,lower) (xu,upper) where determinant (Inverse a) = recip $ Divide.determinant a -instance (Multiply.MultiplySquare typ) => Divide.Solve (Inverse typ) where - solve trans (Inverse a) b = Multiply.transposableSquare trans a b +instance + (Multiply.MultiplySquare typ xl xu, Matrix.ToQuadratic typ, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Divide.Solve (Inverse typ) (xl,lower) (xu,upper) where + solve trans (Inverse a) = Multiply.transposableSquare trans a solveRight (Inverse a) b = Multiply.squareFull a b solveLeft b (Inverse a) = Multiply.fullSquare b a instance - (Divide.Inverse typ, Multiply.MultiplySquare typ) => - Divide.Inverse (Inverse typ) where + (Divide.Inverse typ xl xu, Multiply.MultiplySquare typ xl xu, + Matrix.ToQuadratic typ, MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Divide.Inverse (Inverse typ) (xl,lower) (xu,upper) where inverse (Inverse a) = Inverse $ Divide.inverse a diff --git a/src/Numeric/LAPACK/Matrix/Layout.hs b/src/Numeric/LAPACK/Matrix/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Layout.hs @@ -0,0 +1,84 @@ +module Numeric.LAPACK.Matrix.Layout ( + General, + Tall, + Wide, + Square, + Full(..), fullHeight, fullWidth, + Order(..), flipOrder, + general, + square, + liberalSquare, + wide, + tall, + + Split, + SplitGeneral, + Triangle(..), + Reflector(..), + splitGeneral, + splitFromFull, + + Mosaic(..), + Packing(..), PackingSingleton(..), Packed, Unpacked, + Mirror(..), MirrorSingleton(..), + autoUplo, + Triangular, + LowerTriangular, LowerTriangularP, + lowerTriangular, lowerTriangularP, + UpperTriangular, UpperTriangularP, + upperTriangular, upperTriangularP, + Symmetric, SymmetricP, + symmetric, symmetricP, + Hermitian, HermitianP, + hermitian, hermitianP, + + Diagonal, + diagonal, + Banded(..), + BandedGeneral, + BandedSquare, + BandedLowerTriangular, + BandedUpperTriangular, + BandedIndex(..), + bandedGeneral, + bandedSquare, + bandedFromFull, + UnaryProxy, + addOffDiagonals, + + BandedHermitian(..), + bandedHermitian, + ) where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Layout.Private + + +type SplitGeneral lower height width = + Split lower Extent.Size Extent.Big Extent.Big height width + +splitGeneral :: + lower -> Order -> height -> width -> SplitGeneral lower height width +splitGeneral lowerPart order height width = + Split lowerPart order $ Extent.general height width + +splitFromFull :: + lower -> + Full meas vert horiz height width -> + Split lower meas vert horiz height width +splitFromFull lowerPart (Full order extent) = Split lowerPart order extent + + +diagonal :: Order -> size -> Diagonal size +diagonal order = Banded (u0,u0) order . Extent.square + + +bandedFromFull :: + (UnaryProxy sub, UnaryProxy super) -> + Full meas vert horiz height width -> + Banded sub super meas vert horiz height width +bandedFromFull offDiag (Full order extent) = Banded offDiag order extent + + +bandedHermitian :: UnaryProxy off -> Order -> size -> BandedHermitian off size +bandedHermitian = BandedHermitian diff --git a/src/Numeric/LAPACK/Matrix/Layout/Private.hs b/src/Numeric/LAPACK/Matrix/Layout/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Layout/Private.hs @@ -0,0 +1,989 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Layout.Private where + +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Extent.Private (Extent) + +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary.Proof as Proof +import qualified Type.Data.Num.Unary as Unary +import Type.Data.Num.Unary (unary, (:+:)) +import Type.Data.Num (integralFromProxy) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape (triangleSize, triangleRoot) + +import Control.DeepSeq (NFData, rnf) +import Control.Applicative ((<$>)) + +import Data.List (tails) +import Data.Tuple.HT (mapSnd, swap) +import Data.Bool.HT (if') + + +data Order = RowMajor | ColumnMajor + deriving (Eq, Show) + +instance NFData Order where + rnf RowMajor = () + rnf ColumnMajor = () + +flipOrder :: Order -> Order +flipOrder RowMajor = ColumnMajor +flipOrder ColumnMajor = RowMajor + +transposeFromOrder :: Order -> Char +transposeFromOrder RowMajor = 'T' +transposeFromOrder ColumnMajor = 'N' + +swapOnRowMajor :: Order -> (a,a) -> (a,a) +swapOnRowMajor order = + case order of + RowMajor -> swap + ColumnMajor -> id + +sideSwapFromOrder :: Order -> (a,a) -> (Char, (a,a)) +sideSwapFromOrder order (m0,n0) = + let ((side,m), (_,n)) = swapOnRowMajor order (('L', m0), ('R', n0)) + in (side,(m,n)) + + +mapChecked :: + (Shape.C sha, Shape.C shb) => + String -> (sha -> shb) -> sha -> shb +mapChecked name f sizeA = + let sizeB = f sizeA + in if Shape.size sizeA == Shape.size sizeB + then sizeB + else error $ name ++ ": sizes mismatch" + + +data Full meas vert horiz height width = + Full { + fullOrder :: Order, + fullExtent :: Extent meas vert horiz height width + } deriving (Eq, Show) + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + NFData height, NFData width) => + NFData (Full meas vert horiz height width) where + rnf (Full order extent) = rnf (order, extent) + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Shape.C (Full meas vert horiz height width) where + + size (Full _ extent) = Shape.size (Extent.dimensions extent) + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Full meas vert horiz height width) where + + type Index (Full meas vert horiz height width) = + (Shape.Index height, Shape.Index width) + indices (Full order extent) = fullIndices order extent + + unifiedOffset (Full RowMajor extent) = + Shape.unifiedOffset (Extent.dimensions extent) + unifiedOffset (Full ColumnMajor extent) = + Shape.unifiedOffset (swap $ Extent.dimensions extent) . swap + + unifiedSizeOffset (Full RowMajor extent) = + Shape.unifiedSizeOffset (Extent.dimensions extent) + unifiedSizeOffset (Full ColumnMajor extent) = + mapSnd (.swap) $ + Shape.unifiedSizeOffset (swap $ Extent.dimensions extent) + + inBounds (Full _ extent) = Shape.inBounds (Extent.dimensions extent) + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Full meas vert horiz height width) where + + unifiedIndexFromOffset (Full order extent) = + fullIndexFromOffset order extent + + +transpose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width -> Full meas horiz vert width height +transpose (Full order extent) = Full (flipOrder order) (Extent.transpose extent) + +inverse :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width -> Full meas horiz vert width height +inverse (Full order extent) = Full order (Extent.transpose extent) + +dimensions :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width -> (Int, Int) +dimensions (Full order extent) = + swapOnRowMajor order + (Shape.size $ Extent.height extent, + Shape.size $ Extent.width extent) + +fullHeight :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width -> height +fullHeight = Extent.height . fullExtent + +fullWidth :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width -> width +fullWidth = Extent.width . fullExtent + + +fullIndices :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed a, Shape.Indexed b) => + Order -> Extent meas vert horiz a b -> [(Shape.Index a, Shape.Index b)] +fullIndices order extent = + case order of + RowMajor -> Shape.indices $ Extent.dimensions extent + ColumnMajor -> map swap $ Shape.indices $ swap $ Extent.dimensions extent + +fullIndexFromOffset :: + (Shape.Checking check, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.InvIndexed a, Shape.InvIndexed b) => + Order -> Extent meas vert horiz a b -> Int -> + Shape.Result check (Shape.Index a, Shape.Index b) +fullIndexFromOffset order extent = + case order of + RowMajor -> + Shape.unifiedIndexFromOffset (Extent.dimensions extent) + ColumnMajor -> + fmap swap . + Shape.unifiedIndexFromOffset (swap $ Extent.dimensions extent) + + +type General height width = Full Extent.Size Extent.Big Extent.Big height width +type Tall height width = Full Extent.Size Extent.Big Extent.Small height width +type Wide height width = Full Extent.Size Extent.Small Extent.Big height width +type LiberalSquare height width = SquareMeas Extent.Size height width +type Square size = SquareMeas Extent.Shape size size +type SquareMeas meas height width = + Full meas Extent.Small Extent.Small height width + + +fullMapExtent :: + Extent.Map measA vertA horizA measB vertB horizB height width -> + Full measA vertA horizA height width -> + Full measB vertB horizB height width +fullMapExtent f (Full order extent) = Full order $ f extent + +general :: Order -> height -> width -> General height width +general order height width = Full order $ Extent.general height width + +tall :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Tall height width +tall order height width = + if Shape.size height >= Shape.size width + then Full order $ Extent.tall height width + else error "Layout.tall: height smaller than width" + +wide :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Wide height width +wide order height width = + if Shape.size height <= Shape.size width + then Full order $ Extent.wide height width + else error "Layout.wide: width smaller than height" + +liberalSquare :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> LiberalSquare height width +liberalSquare order height width = + if Shape.size height == Shape.size width + then Full order $ Extent.liberalSquare height width + else error "Layout.liberalSquare: height and width sizes differ" + +square :: Order -> sh -> Square sh +square order sh = Full order $ Extent.square sh + + +caseTallWide :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width -> + Either (Tall height width) (Wide height width) +caseTallWide (Full order extent) = + either (Left . Full order) (Right . Full order) $ + Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent + + +data Split lower meas vert horiz height width = + Split { + splitLower :: lower, + splitOrder :: Order, + splitExtent :: Extent meas vert horiz height width + } deriving (Eq, Show) + +splitHeight :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Split lower meas vert horiz height width -> height +splitHeight = Extent.height . splitExtent + +splitWidth :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Split lower meas vert horiz height width -> width +splitWidth = Extent.width . splitExtent + +splitMapExtent :: + Extent.Map measA vertA horizA measB vertB horizB height width -> + Split lower measA vertA horizA height width -> + Split lower measB vertB horizB height width +splitMapExtent f (Split lowerPart order extent) = + Split lowerPart order $ f extent + + +caseTallWideSplit :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Split lower meas vert horiz height width -> + Either + (Split lower Extent.Size Extent.Big Extent.Small height width) + (Split lower Extent.Size Extent.Small Extent.Big height width) +caseTallWideSplit (Split lowerPart order extent) = + either (Left . Split lowerPart order) (Right . Split lowerPart order) $ + Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent + +data Reflector = Reflector deriving (Eq, Show) +data Triangle = Triangle deriving (Eq, Show) + +instance NFData Reflector where rnf Reflector = () +instance NFData Triangle where rnf Triangle = () + +splitPart :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width) => + Split lower meas vert horiz height width -> + (Shape.Index height, Shape.Index width) -> Either lower Triangle +splitPart (Split lowerPart _ extent) (r,c) = + if Shape.offset (Extent.height extent) r > + Shape.offset (Extent.width extent) c + then Left lowerPart + else Right Triangle + +instance + (NFData lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + NFData height, NFData width) => + NFData (Split lower meas vert horiz height width) where + rnf (Split lowerPart order extent) = rnf (lowerPart, order, extent) + +instance + (Eq lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Shape.C (Split lower meas vert horiz height width) where + + size (Split _ _ extent) = Shape.size (Extent.dimensions extent) + +instance + (Eq lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Split lower meas vert horiz height width) where + + type Index (Split lower meas vert horiz height width) = + (Either lower Triangle, + (Shape.Index height, Shape.Index width)) + + indices sh@(Split _ order extent) = + map (\ix -> (splitPart sh ix, ix)) $ fullIndices order extent + + unifiedOffset sh@(Split _ order extent) (part,ix) = do + Shape.assert "Shape.Split.offset: wrong matrix part" $ + part == splitPart sh ix + case order of + RowMajor -> Shape.unifiedOffset (Extent.dimensions extent) ix + ColumnMajor -> + Shape.unifiedOffset (swap $ Extent.dimensions extent) (swap ix) + + unifiedSizeOffset sh@(Split _ order extent) = + let check (part,ix) a = do + Shape.assert "Shape.Split.sizeOffset: wrong matrix part" $ + part == splitPart sh ix + return a + in case order of + RowMajor -> + mapSnd + (\getOffset (part,ix) -> check (part,ix) =<< getOffset ix) $ + Shape.unifiedSizeOffset (Extent.dimensions extent) + ColumnMajor -> + mapSnd + (\getOffset (part,ix) -> + check (part,ix) =<< getOffset (swap ix)) $ + Shape.unifiedSizeOffset (swap $ Extent.dimensions extent) + + inBounds sh@(Split _ _ extent) (part,ix) = + Shape.inBounds (Extent.dimensions extent) ix + && + part == splitPart sh ix + +instance + (Eq lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Split lower meas vert horiz height width) where + + unifiedIndexFromOffset sh@(Split _ order extent) k = do + ix <- fullIndexFromOffset order extent k + return (splitPart sh ix, ix) + + + +data Mosaic pack mirror uplo size = + Mosaic { + mosaicPack :: PackingSingleton pack, + mosaicMirror :: MirrorSingleton mirror, + mosaicUplo :: UpLoSingleton uplo, + mosaicOrder :: Order, + mosaicSize :: size + } deriving (Eq, Show) + +data Packed +data Unpacked + +data PackingSingleton pack where + Packed :: PackingSingleton Packed + Unpacked :: PackingSingleton Unpacked + +deriving instance Eq (PackingSingleton pack) +deriving instance Show (PackingSingleton pack) + +instance NFData (PackingSingleton pack) where + rnf Packed = () + rnf Unpacked = () + +class Packing pack where autoPacking :: PackingSingleton pack +instance Packing Unpacked where autoPacking = Unpacked +instance Packing Packed where autoPacking = Packed + +squareFromMosaic :: Mosaic Unpacked mirror uplo size -> Square size +squareFromMosaic (Mosaic {mosaicOrder = order, mosaicSize = size}) = + square order size + +mosaicFromSquare :: + (Mirror mirror, UpLo uplo) => Square size -> Mosaic Unpacked mirror uplo size +mosaicFromSquare (Full {fullOrder = order, fullExtent = extent}) = + Mosaic { + mosaicPack = Unpacked, + mosaicMirror = autoMirror, + mosaicUplo = autoUplo, + mosaicOrder = order, + mosaicSize = Extent.squareSize extent + } + + +data NoMirror +data SimpleMirror +data ConjugateMirror + +data MirrorSingleton mirror where + NoMirror :: MirrorSingleton NoMirror + SimpleMirror :: MirrorSingleton SimpleMirror + ConjugateMirror :: MirrorSingleton ConjugateMirror + +deriving instance Eq (MirrorSingleton mirror) +deriving instance Show (MirrorSingleton mirror) + +instance NFData (MirrorSingleton mirror) where + rnf NoMirror = () + rnf SimpleMirror = () + rnf ConjugateMirror = () + +class Mirror mirror where autoMirror :: MirrorSingleton mirror +instance Mirror NoMirror where autoMirror = NoMirror +instance Mirror SimpleMirror where autoMirror = SimpleMirror +instance Mirror ConjugateMirror where autoMirror = ConjugateMirror + + +type TriangularP pack = Mosaic pack NoMirror +type Triangular = TriangularP Packed + +type LowerTriangularP pack = TriangularP pack Shape.Lower +type LowerTriangular = Triangular Shape.Lower + +type UpperTriangularP pack = TriangularP pack Shape.Upper +type UpperTriangular = Triangular Shape.Upper + +triangular :: UpLoSingleton uplo -> Order -> size -> Triangular uplo size +triangular = Mosaic Packed NoMirror + +upperTriangular :: Order -> size -> UpperTriangular size +upperTriangular = triangular Upper + +lowerTriangular :: Order -> size -> LowerTriangular size +lowerTriangular = triangular Lower + + +triangularP :: + PackingSingleton pack -> + UpLoSingleton uplo -> Order -> size -> TriangularP pack uplo size +triangularP pack = Mosaic pack NoMirror + +upperTriangularP :: + PackingSingleton pack -> Order -> size -> UpperTriangularP pack size +upperTriangularP pack = triangularP pack Upper + +lowerTriangularP :: + PackingSingleton pack -> Order -> size -> LowerTriangularP pack size +lowerTriangularP pack = triangularP pack Lower + + +type SymmetricP pack = Mosaic pack SimpleMirror Shape.Upper +type Symmetric = SymmetricP Packed + +symmetric :: Order -> size -> Symmetric size +symmetric = symmetricP Packed + +symmetricP :: PackingSingleton pack -> Order -> size -> SymmetricP pack size +symmetricP pack = Mosaic pack SimpleMirror Upper + +symmetricFromHermitian :: HermitianP pack size -> SymmetricP pack size +symmetricFromHermitian (Mosaic pack ConjugateMirror upper order size) = + Mosaic pack SimpleMirror upper order size + + +type HermitianP pack = Mosaic pack ConjugateMirror Shape.Upper +type Hermitian = HermitianP Packed + +hermitian :: Order -> size -> Hermitian size +hermitian = hermitianP Packed + +hermitianP :: PackingSingleton pack -> Order -> size -> HermitianP pack size +hermitianP pack = Mosaic pack ConjugateMirror Upper + +hermitianFromSymmetric :: SymmetricP pack size -> HermitianP pack size +hermitianFromSymmetric (Mosaic pack SimpleMirror upper order size) = + Mosaic pack ConjugateMirror upper order size + +uploFromOrder :: Order -> Char +uploFromOrder RowMajor = 'L' +uploFromOrder ColumnMajor = 'U' + + + +newtype Bands offDiag = Bands (UnaryProxy offDiag) deriving (Eq, Show) +type Empty = Bands TypeNum.U0 +data Filled = Filled deriving (Eq, Show) + +u0 :: UnaryProxy TypeNum.U0 +u0 = unary TypeNum.u0 + +empty :: Empty +empty = Bands u0 + +type family TriTransposed uplo +type instance TriTransposed Shape.Lower = Shape.Upper +type instance TriTransposed Shape.Upper = Shape.Lower + +triangularTranspose :: + (UpLo uplo) => + Mosaic pack mirror uplo sh -> + Mosaic pack mirror (TriTransposed uplo) sh +triangularTranspose (Mosaic pack mirror uplo order size) = + Mosaic pack mirror + (case uplo of + Lower -> Upper + Upper -> Lower) + (flipOrder order) + size + + +autoUplo :: (UpLo uplo) => UpLoSingleton uplo +autoUplo = switchUpLo Upper Lower + +uploOrder :: UpLoSingleton uplo -> Order -> Order +uploOrder uplo = case uplo of Lower -> flipOrder; Upper -> id + + +class UpLo uplo where + switchUpLo :: f Shape.Upper -> f Shape.Lower -> f uplo + +instance UpLo Shape.Upper where + switchUpLo f _ = f + +instance UpLo Shape.Lower where + switchUpLo _ f = f + +data UpLoSingleton uplo where + Lower :: UpLoSingleton Shape.Lower + Upper :: UpLoSingleton Shape.Upper + +instance Eq (UpLoSingleton uplo) where + Lower == Lower = True + Upper == Upper = True + +instance Show (UpLoSingleton uplo) where + show Lower = "Lower" + show Upper = "Upper" + +instance NFData (UpLoSingleton uplo) where + rnf Lower = () + rnf Upper = () + +uploChar :: UpLoSingleton uplo -> Char +uploChar Lower = 'L' +uploChar Upper = 'U' + + +instance + (UpLo uplo, NFData size) => + NFData (Mosaic pack mirror uplo size) where + rnf (Mosaic pack mirror uplo order size) = + rnf (pack, mirror, uplo, order, size) + +instance + (UpLo uplo, Shape.C size) => + Shape.C (Mosaic pack mirror uplo size) where + + size (Mosaic pack _mirror _uplo order size) = + case pack of + Packed -> triangleSize $ Shape.size size + Unpacked -> Shape.size $ square order size + +instance + (UpLo uplo, Shape.Indexed size) => + Shape.Indexed (Mosaic pack mirror uplo size) where + type Index (Mosaic pack mirror uplo size) = + (Shape.Index size, Shape.Index size) + + indices (Mosaic pack _mirror uplo order size) = + case (pack,uplo) of + (Unpacked,_) -> Shape.indices $ square order size + (Packed,Upper) -> triangleIndices order size + (Packed,Lower) -> map swap $ triangleIndices (flipOrder order) size + + unifiedOffset (Mosaic pack _mirror uplo order size) = + case (pack,uplo) of + (Unpacked,_) -> Shape.unifiedOffset $ square order size + (Packed,Upper) -> triangleOffset order size + (Packed,Lower) -> triangleOffset (flipOrder order) size . swap + + unifiedSizeOffset (Mosaic pack _mirror uplo order size) = + case (pack,uplo) of + (Unpacked,_) -> Shape.unifiedSizeOffset $ square order size + (Packed,Upper) -> triangleSizeOffset order size + (Packed,Lower) -> + mapSnd (.swap) $ triangleSizeOffset (flipOrder order) size + + inBounds (Mosaic pack _mirror uplo _ size) ix@(r,c) = + Shape.inBounds (size,size) ix + && + case (pack,uplo) of + (Unpacked,_) -> True + (Packed,Upper) -> Shape.offset size r <= Shape.offset size c + (Packed,Lower) -> Shape.offset size r >= Shape.offset size c + +instance + (UpLo uplo, Shape.InvIndexed size) => + Shape.InvIndexed (Mosaic pack mirror uplo size) where + + unifiedIndexFromOffset (Mosaic pack _mirror uplo order size) k = + case (pack,uplo) of + (Unpacked,_) -> + Shape.unifiedIndexFromOffset (square order size) k + (Packed,Upper) -> triangleIndexFromOffset order size k + (Packed,Lower) -> + swap <$> triangleIndexFromOffset (flipOrder order) size k + + +squareRootDouble :: Int -> Double +squareRootDouble = sqrt . fromIntegral + +squareExtent :: String -> Int -> Int +squareExtent name size = + let n = round $ squareRootDouble size + in if size == n*n + then n + else error (name ++ ": no square number of elements") + + +triangleRootDouble :: Int -> Double +triangleRootDouble = triangleRoot . fromIntegral + +triangleExtent :: String -> Int -> Int +triangleExtent name size = + let n = round $ triangleRootDouble size + in if size == triangleSize n + then n + else error (name ++ ": no triangular number of elements") + +triangleIndices :: + (Shape.Indexed sh) => Order -> sh -> [(Shape.Index sh, Shape.Index sh)] +triangleIndices RowMajor = Shape.indices . Shape.upperTriangular +triangleIndices ColumnMajor = map swap . Shape.indices . Shape.lowerTriangular + +triangleOffset :: + (Shape.Checking check, Shape.Indexed sh) => + Order -> sh -> (Shape.Index sh, Shape.Index sh) -> Shape.Result check Int +triangleOffset order size = + case order of + RowMajor -> Shape.unifiedOffset (Shape.upperTriangular size) + ColumnMajor -> Shape.unifiedOffset (Shape.lowerTriangular size) . swap + +triangleSizeOffset :: + (Shape.Checking check, Shape.Indexed sh) => + Order -> sh -> + (Int, (Shape.Index sh, Shape.Index sh) -> Shape.Result check Int) +triangleSizeOffset order size = + case order of + RowMajor -> Shape.unifiedSizeOffset (Shape.upperTriangular size) + ColumnMajor -> + mapSnd (.swap) $ Shape.unifiedSizeOffset (Shape.lowerTriangular size) + +triangleIndexFromOffset :: + (Shape.Checking check, Shape.InvIndexed sh) => + Order -> sh -> Int -> Shape.Result check (Shape.Index sh, Shape.Index sh) +triangleIndexFromOffset order size = + case order of + RowMajor -> Shape.unifiedIndexFromOffset (Shape.upperTriangular size) + ColumnMajor -> + fmap swap . Shape.unifiedIndexFromOffset (Shape.lowerTriangular size) + + +type UnaryProxy a = Proxy (Unary.Un a) + +data Banded sub super meas vert horiz height width = + Banded { + bandedOffDiagonals :: (UnaryProxy sub, UnaryProxy super), + bandedOrder :: Order, + bandedExtent :: Extent meas vert horiz height width + } deriving (Eq, Show) + +type BandedGeneral sub super = + Banded sub super Extent.Size Extent.Big Extent.Big +type BandedSquareMeas sub super meas height width = + Banded sub super meas Extent.Small Extent.Small height width +type BandedSquare sub super size = + BandedSquareMeas sub super Extent.Shape size size + +type BandedLowerTriangular sub size = BandedSquare sub TypeNum.U0 size +type BandedUpperTriangular super size = BandedSquare TypeNum.U0 super size + +type Diagonal size = BandedSquare TypeNum.U0 TypeNum.U0 size +type RectangularDiagonal = Banded TypeNum.U0 TypeNum.U0 + + +bandedHeight :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width -> height +bandedHeight = Extent.height . bandedExtent + +bandedWidth :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width -> width +bandedWidth = Extent.width . bandedExtent + +bandedMapExtent :: + Extent.Map measA vertA horizA measB vertB horizB height width -> + Banded sub super measA vertA horizA height width -> + Banded sub super measB vertB horizB height width +bandedMapExtent f (Banded offDiag order extent) = + Banded offDiag order $ f extent + +bandedBreadth :: + (Unary.Natural sub, Unary.Natural super) => + (UnaryProxy sub, UnaryProxy super) -> Int +bandedBreadth (sub,super) = + integralFromProxy sub + 1 + integralFromProxy super + +numOffDiagonals :: + (Unary.Natural sub, Unary.Natural super) => + Order -> (UnaryProxy sub, UnaryProxy super) -> (Int,Int) +numOffDiagonals order (sub,super) = + swapOnRowMajor order (integralFromProxy sub, integralFromProxy super) + +natFromProxy :: (Unary.Natural n) => UnaryProxy n -> Proof.Nat n +natFromProxy Proxy = Proof.Nat + +addOffDiagonals :: + (Unary.Natural subA, Unary.Natural superA, + Unary.Natural subB, Unary.Natural superB, + (subA :+: subB) ~ subC, + (superA :+: superB) ~ superC) => + (UnaryProxy subA, UnaryProxy superA) -> + (UnaryProxy subB, UnaryProxy superB) -> + ((Proof.Nat subC, Proof.Nat superC), + (UnaryProxy subC, UnaryProxy superC)) +addOffDiagonals (subA,superA) (subB,superB) = + ((Proof.addNat (natFromProxy subA) (natFromProxy subB), + Proof.addNat (natFromProxy superA) (natFromProxy superB)), + (Proxy,Proxy)) + +bandedTranspose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Banded sub super meas vert horiz height width -> + Banded super sub meas horiz vert width height +bandedTranspose (Banded (sub,super) order extent) = + Banded (super,sub) (flipOrder order) (Extent.transpose extent) + +diagonalInverse :: + (Extent.Measure meas) => + BandedSquareMeas TypeNum.U0 TypeNum.U0 meas height width -> + BandedSquareMeas TypeNum.U0 TypeNum.U0 meas width height +diagonalInverse (Banded (sub,super) order extent) = + Banded (super,sub) order (Extent.transpose extent) + + +bandedGeneral :: + (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> + BandedGeneral sub super height width +bandedGeneral offDiag order height width = + Banded offDiag order (Extent.general height width) + +bandedSquare :: + (UnaryProxy sub, UnaryProxy super) -> Order -> size -> + BandedSquare sub super size +bandedSquare offDiag order = Banded offDiag order . Extent.square + +rectangularDiagonal :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width) => + Extent meas vert horiz height width -> + (Int, RectangularDiagonal meas vert horiz height width) +rectangularDiagonal extent = + let m = Shape.size $ Extent.height extent + n = Shape.size $ Extent.width extent + order = if m <= n then RowMajor else ColumnMajor + in (min m n, Banded (u0,u0) order extent) + + +data BandedIndex row column = + InsideBox row column + | VertOutsideBox Int column + | HorizOutsideBox row Int + deriving (Eq, Show) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + NFData height, NFData width) => + NFData (Banded sub super meas vert horiz height width) where + rnf (Banded (Proxy,Proxy) order extent) = rnf (order, extent) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Shape.C (Banded sub super meas vert horiz height width) where + + size (Banded offDiag order extent) = + bandedBreadth offDiag * + case order of + RowMajor -> Shape.size (Extent.height extent) + ColumnMajor -> Shape.size (Extent.width extent) + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width) => + Shape.Indexed (Banded sub super meas vert horiz height width) where + + type Index (Banded sub super meas vert horiz height width) = + BandedIndex (Shape.Index height) (Shape.Index width) + indices (Banded (sub,super) order extent) = + let (height,width) = Extent.dimensions extent + in case order of + RowMajor -> + map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ + bandedIndicesRowMajor (sub,super) (height,width) + ColumnMajor -> + map (\(c,r) -> + either (flip VertOutsideBox c) (flip InsideBox c) r) $ + bandedIndicesRowMajor (super,sub) (width,height) + + unifiedOffset shape@(Banded (sub,super) order extent) ix = do + Shape.assert "Banded.offset: index outside band" $ + Shape.inBounds shape ix + let (height,width) = Extent.dimensions extent + kl = integralFromProxy sub + ku = integralFromProxy super + return $ bandedOffset (kl,ku) order (height,width) ix + + inBounds (Banded (sub,super) order extent) ix = + let (height,width) = Extent.dimensions extent + kl = integralFromProxy sub + ku = integralFromProxy super + insideBand r c = Shape.inBounds (Shape.Range (-kl) ku) (c-r) + in case (order,ix) of + (_, InsideBox r c) -> + Shape.inBounds (height,width) (r,c) + && + insideBand (Shape.offset height r) (Shape.offset width c) + (RowMajor, HorizOutsideBox r c) -> + Shape.inBounds height r + && + insideBand (Shape.offset height r) (outsideOffset width c) + (ColumnMajor, VertOutsideBox r c) -> + Shape.inBounds width c + && + insideBand (outsideOffset height r) (Shape.offset width c) + _ -> False + +instance + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.InvIndexed height, Shape.InvIndexed width) => + Shape.InvIndexed (Banded sub super meas vert horiz height width) where + + unifiedIndexFromOffset (Banded (sub,super) order extent) j = + bandedIndexFromOffset + (integralFromProxy sub, integralFromProxy super) order + (Extent.dimensions extent) j + +outsideOffset :: Shape.C sh => sh -> Int -> Int +outsideOffset size k = if k<0 then k else Shape.size size + k + +bandedOffset :: + (Shape.Indexed height, Shape.Indexed width) => + (Int, Int) -> Order -> (height, width) -> + BandedIndex (Shape.Index height) (Shape.Index width) -> Int +bandedOffset (kl,ku) order (height,width) ix = + let k = kl+ku + in case ix of + InsideBox r c -> + let i = Shape.uncheckedOffset height r + j = Shape.uncheckedOffset width c + in case order of + RowMajor -> k*i + kl+j + ColumnMajor -> k*j + ku+i + VertOutsideBox r c -> + let i = outsideOffset height r + j = Shape.uncheckedOffset width c + in k*j + ku+i + HorizOutsideBox r c -> + let i = Shape.uncheckedOffset height r + j = outsideOffset width c + in k*i + kl+j + +bandedIndicesRowMajor :: + (Unary.Natural sub, Unary.Natural super, + Shape.Indexed height, Shape.Indexed width) => + (UnaryProxy sub, UnaryProxy super) -> + (height, width) -> + [(Shape.Index height, Either Int (Shape.Index width))] +bandedIndicesRowMajor (sub,super) (height,width) = + let kl = integralFromProxy sub + ku = integralFromProxy super + in concat $ + zipWith (\r -> map ((,) r)) (Shape.indices height) $ + map (take (kl+1+ku)) $ tails $ + (map Left $ take kl $ iterate (1+) (-kl)) ++ + (map Right $ Shape.indices width) ++ + (map Left $ iterate (1+) 0) + +bandedIndexFromOffset :: + (Shape.Checking check, Shape.InvIndexed height, Shape.InvIndexed width) => + (Int,Int) -> Order -> (height,width) -> Int -> + Shape.Result check (BandedIndex (Shape.Index height) (Shape.Index width)) +bandedIndexFromOffset (kl,ku) order (height,width) = + case order of + RowMajor -> let n = Shape.size width in \j -> do + let (rb,cb) = divMod j (kl+1+ku) + r <- Shape.unifiedIndexFromOffset height rb + let ci = rb+cb-kl + if' (ci<0) (return $ HorizOutsideBox r ci) $ + if' (ci>=n) (return $ HorizOutsideBox r (ci-n)) $ + (InsideBox r <$> Shape.unifiedIndexFromOffset width ci) + ColumnMajor -> \j -> do + let m = Shape.size height + let (cb,rb) = divMod j (kl+1+ku) + c <- Shape.unifiedIndexFromOffset width cb + let ri = rb+cb-ku + if' (ri<0) (return $ VertOutsideBox ri c) $ + if' (ri>=m) (return $ VertOutsideBox (ri-m) c) $ + (flip InsideBox c <$> Shape.unifiedIndexFromOffset height ri) + + +data BandedHermitian off size = + BandedHermitian { + bandedHermitianOffDiagonals :: UnaryProxy off, + bandedHermitianOrder :: Order, + bandedHermitianSize :: size + } deriving (Eq, Show) + +instance (Unary.Natural off, NFData size) => + NFData (BandedHermitian off size) where + rnf (BandedHermitian Proxy order size) = rnf (order, size) + +instance (Unary.Natural off, Shape.C size) => + Shape.C (BandedHermitian off size) where + + size (BandedHermitian offDiag _order size) = + (1 + integralFromProxy offDiag) * Shape.size size + +instance (Unary.Natural off, Shape.Indexed size) => + Shape.Indexed (BandedHermitian off size) where + type Index (BandedHermitian off size) = + BandedIndex (Shape.Index size) (Shape.Index size) + indices (BandedHermitian offDiag order size) = + case order of + RowMajor -> + map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ + bandedIndicesRowMajor (u0, offDiag) (size,size) + ColumnMajor -> + map (\(c,r) -> + either (flip VertOutsideBox c) (flip InsideBox c) r) $ + bandedIndicesRowMajor (offDiag, u0) (size,size) + + unifiedOffset shape@(BandedHermitian offDiag order size) ix = do + Shape.assert "BandedHermitian.offset: index outside band" $ + Shape.inBounds shape ix + let k = integralFromProxy offDiag + return $ bandedOffset (0,k) order (size,size) ix + + inBounds (BandedHermitian offDiag order size) ix = + let ku = integralFromProxy offDiag + insideBand r c = Shape.inBounds (Shape.Range 0 ku) (c-r) + in case (order,ix) of + (_, InsideBox r c) -> + Shape.inBounds (size,size) (r,c) + && + insideBand (Shape.offset size r) (Shape.offset size c) + (RowMajor, HorizOutsideBox r c) -> + Shape.inBounds size r + && + insideBand (Shape.offset size r) (outsideOffset size c) + (ColumnMajor, VertOutsideBox r c) -> + Shape.inBounds size c + && + insideBand (outsideOffset size r) (Shape.offset size c) + _ -> False + +instance (Unary.Natural off, Shape.InvIndexed size) => + Shape.InvIndexed (BandedHermitian off size) where + + unifiedIndexFromOffset (BandedHermitian offDiag order size) j = + bandedHermitianIndexFromOffset + (integralFromProxy offDiag) order size j + +bandedHermitianIndexFromOffset :: + (Shape.Checking check, Shape.InvIndexed sh, Shape.Index sh ~ ix) => + Int -> Order -> sh -> Int -> Shape.Result check (BandedIndex ix ix) +bandedHermitianIndexFromOffset k order size = + case order of + RowMajor -> let n = Shape.size size in \j -> do + let (rb,cb) = divMod j (k+1) + r <- Shape.unifiedIndexFromOffset size rb + let ci = rb+cb + if ci Shape.unifiedIndexFromOffset size ci + else return $ HorizOutsideBox r (ci-n) + ColumnMajor -> \j -> do + let (cb,rb) = divMod j (k+1) + c <- Shape.unifiedIndexFromOffset size cb + let ri = rb+cb-k + if ri>=0 + then flip InsideBox c <$> Shape.unifiedIndexFromOffset size ri + else return $ VertOutsideBox ri c diff --git a/src/Numeric/LAPACK/Matrix/Lazy/UpperTriangular.hs b/src/Numeric/LAPACK/Matrix/Lazy/UpperTriangular.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Lazy/UpperTriangular.hs @@ -0,0 +1,165 @@ +module Numeric.LAPACK.Matrix.Lazy.UpperTriangular where + +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as Mosaic +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Quadratic as Quad +import Numeric.LAPACK.Matrix.Array.Indexed ((#!)) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as StArray +import qualified Data.Array.Comfort.Boxed.Unchecked as Array +import qualified Data.Array.Comfort.Boxed as CheckedArray +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Boxed ((!)) + +import Prelude hiding (sqrt) + + + +type Upper sh = Array.Array (Shape.Triangular Shape.Upper (Shape.Deferred sh)) +type Vector sh = Array.Array (Shape.Deferred sh) + + +sample :: Shape.Indexed sh => sh -> (Shape.Index sh -> b) -> Array.Array sh b +sample shape f = fmap f $ CheckedArray.indices shape + + +fromStorable :: + (Shape.C sh, Class.Floating a) => + Mosaic.FlexUpperP pack diag sh a -> Upper sh a +fromStorable a0 = + let a = Quad.mapSize Shape.Deferred a0 + in sample (Shape.Triangular Shape.Upper (Quad.size a)) (a#!) + +toStorable :: + (Shape.C sh, Class.Floating a) => Upper sh a -> Mosaic.Upper sh a +toStorable = + Quad.mapSize (\(Shape.Deferred sh) -> sh) . + Triangular.fromUpperRowMajor . StArray.fromBoxed + + +scaleColumns :: (Shape.C sh, Num a) => Vector sh a -> Upper sh a -> Upper sh a +scaleColumns d a = sample (Array.shape a) $ \(i,j) -> a!(i,j) * d!j + +scaleRows :: (Shape.C sh, Num a) => Vector sh a -> Upper sh a -> Upper sh a +scaleRows d a = sample (Array.shape a) $ \(i,j) -> a!(i,j) * d!i + + +{- | +It is an unchecked error if the shapes mismatch. +-} +multiply :: (Shape.C sh, Num a) => Upper sh a -> Upper sh a -> Upper sh a +multiply a b = + sample (Array.shape a) $ + \(i@(Shape.DeferredIndex di), j@(Shape.DeferredIndex dj)) -> + sum $ map (\k -> a!(i,k)*b!(k,j)) $ map Shape.DeferredIndex [di..dj] + +{- | +@multiplyStrictPart a b@ +is almost @multiply (clearDiagonal a) (clearDiagonal b)@, +but it is more lazy +since it does not access the elements that are multiplied with zero. +-} +multiplyStrictPart :: + (Shape.C sh, Num a) => Upper sh a -> Upper sh a -> Upper sh a +multiplyStrictPart a b = + sample (Array.shape a) $ + \(i@(Shape.DeferredIndex di), j@(Shape.DeferredIndex dj)) -> + sum $ map (\k -> a!(i,k)*b!(k,j)) $ + map Shape.DeferredIndex [di+1..dj-1] + +takeDiagonal :: (Shape.C sh, Num a) => Upper sh a -> Vector sh a +takeDiagonal a = + sample (Shape.triangularSize $ Array.shape a) $ \i -> a!(i,i) + +replaceDiagonal :: + (Shape.C sh, Num a) => Vector sh a -> Upper sh a -> Upper sh a +replaceDiagonal d a = + sample (Array.shape a) $ \(i,j) -> if i==j then d!i else a!(i,j) + +rank2Part :: (Shape.C sh, Num a) => Vector sh a -> Upper sh a +rank2Part d = + sample (Shape.Triangular Shape.Upper $ Array.shape d) $ \(i,j) -> d!i + d!j + +rank2DiffPart :: (Shape.C sh, Num a) => Vector sh a -> Upper sh a +rank2DiffPart d = + sample (Shape.Triangular Shape.Upper $ Array.shape d) $ \(i,j) -> d!i - d!j + + +{- | +Lazy implicit solver +-} +{- +A = (D+U)*(D+U) = D*D + D*U + U*D + U*U + +let U = divide (A-D*D - U*U) (toColumn(D)*1^T+1*toRow(D)) +-} +sqrt :: (Shape.C sh, Fractional a) => (a -> a) -> Upper sh a -> Upper sh a +sqrt sqrtF = applyUnchecked $ \a -> + let d = fmap sqrtF $ takeDiagonal a + u = + Array.reshape (Array.shape a) $ + Array.zipWith (/) + (Array.zipWith (-) a (multiplyStrictPart u u)) + (rank2Part d) + in replaceDiagonal d u + + +{- | +Parlett recursion for lifting a scalar function to an upper triangular matrix. + +Given A and the diagonal of f(A) it solves A*f(A) = f(A)*A. + +Requires distinct values on the diagonal, +where even almost close values can produce dramatic errors. +But it admits for a nice lazy implicit implementation. +-} +{- +/g h i\ /a b c\ / x y\ / x y\ /a b c\ +| j k| = | d e| * | z| - | z| * | d e| +\ l/ \ f/ \ / \ / \ f/ + +h = a*x - x*d = (a-d)*x +k = d*z - z*f = (d-f)*z +i = a*y+b*z - (x*e+y*f) = b*z-x*e + (a-f)*y + + +0 = A*f(A) - f(A)*A + +A = E+V +f(A) = D+U + +0 = A*(D+U) - (D+U)*A +D*A-A*D = (E+V)*U - U*(E+V) +D*A-A*D + U*V-V*U = E*U-U*E + +U = divide (D*A-A*D + U*V-V*U) (toColumn(E)*1^T - 1*toRow(E)) +-} +parlett :: (Shape.C sh, Fractional a) => (a -> a) -> Upper sh a -> Upper sh a +parlett f = applyUnchecked $ \a -> + let e = takeDiagonal a + d = fmap f e + u = + Array.reshape (Array.shape a) $ + Array.zipWith (/) + (Array.zipWith (-) + (Array.zipWith (+) (scaleRows d a) (multiplyStrictPart u a)) + (Array.zipWith (+) (scaleColumns d a) (multiplyStrictPart a u))) + (rank2DiffPart e) + in replaceDiagonal d u + + +applyUnchecked :: + (Shape.C sh) => + (Upper (Unchecked sh) a -> Upper (Unchecked sh) a) -> + Upper sh a -> Upper sh a +applyUnchecked f = + Array.mapShape + (\(Shape.Triangular uplo (Shape.Deferred (Unchecked sh))) -> + Shape.Triangular uplo (Shape.Deferred sh)) . + f . + Array.mapShape + (\(Shape.Triangular uplo (Shape.Deferred sh)) -> + Shape.Triangular uplo (Shape.Deferred (Unchecked sh))) diff --git a/src/Numeric/LAPACK/Matrix/Modifier.hs b/src/Numeric/LAPACK/Matrix/Modifier.hs --- a/src/Numeric/LAPACK/Matrix/Modifier.hs +++ b/src/Numeric/LAPACK/Matrix/Modifier.hs @@ -1,6 +1,6 @@ module Numeric.LAPACK.Matrix.Modifier where -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor,ColumnMajor), flipOrder) import Data.Monoid (Monoid, mempty, mappend) @@ -21,6 +21,7 @@ transposeOrder :: Transposition -> Order -> Order transposeOrder NonTransposed = id transposeOrder Transposed = flipOrder + data Conjugation = NonConjugated | Conjugated diff --git a/src/Numeric/LAPACK/Matrix/ModifierTyped.hs b/src/Numeric/LAPACK/Matrix/ModifierTyped.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/ModifierTyped.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.ModifierTyped where + +import qualified Numeric.LAPACK.Matrix.Modifier as Mod +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Extent.Private (Extent, Small) + + +data Transposition heightA widthA heightB widthB where + NonTransposed :: Transposition height width height width + Transposed :: Transposition height width width height + +transposeTransposition :: + Transposition heightA widthA heightB widthB -> + Transposition widthA heightA widthB heightB +transposeTransposition trans = + case trans of + NonTransposed -> NonTransposed + Transposed -> Transposed + +transposeSquareExtent :: + (Extent.Measure meas) => + Transposition heightA widthA heightB widthB -> + Extent meas Small Small heightA widthA -> + Extent meas Small Small heightB widthB +transposeSquareExtent trans = + case trans of + NonTransposed -> id + Transposed -> Extent.transpose + +transpositionToUntyped :: + Transposition heightA widthA heightB widthB -> Mod.Transposition +transpositionToUntyped trans = + case trans of + NonTransposed -> Mod.NonTransposed + Transposed -> Mod.Transposed + + +fromSquareTransposition :: Mod.Transposition -> Transposition sh sh sh sh +fromSquareTransposition trans = + case trans of + Mod.NonTransposed -> NonTransposed + Mod.Transposed -> Transposed + + +data SquareTransposition sh height width where + SquareTransposition :: Mod.Transposition -> SquareTransposition sh sh sh + +squareFromTransposition :: + Transposition sh sh height width -> SquareTransposition sh height width +squareFromTransposition trans = + case trans of + NonTransposed -> SquareTransposition Mod.NonTransposed + Transposed -> SquareTransposition Mod.Transposed diff --git a/src/Numeric/LAPACK/Matrix/Mosaic/Basic.hs b/src/Numeric/LAPACK/Matrix/Mosaic/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Mosaic/Basic.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Mosaic.Basic ( + Mosaic.fromList, + Mosaic.autoFromList, + + Mosaic.transpose, + Mosaic.adjoint, + + Mosaic.repack, + pack, + unpack, + reunpack, + Mosaic.unpackDirty, + + Mos.takeUpper, + Mos.fromUpper, + + takeDiagonal, + toSquare, + square, + power, + powers1, + ) where + +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Mosaic.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Generic as Mosaic +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos +import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import Numeric.LAPACK.Matrix.Mosaic.Private (Mosaic) +import Numeric.LAPACK.Matrix.Shape.Omni (TriDiag, DiagSingleton) +import Numeric.LAPACK.Matrix.Private (Square) +import Numeric.LAPACK.Vector (Vector) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Stream (Stream) + + +takeDiagonal :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> Vector sh a +takeDiagonal a = + case Layout.mosaicPack $ Array.shape a of + Layout.Unpacked -> Square.takeDiagonal $ Unpacked.toSquare a + Layout.Packed -> Packed.takeDiagonal a + +toSquare :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Packed.Mosaic mirror uplo sh a -> Square sh a +toSquare a = + let shape = Array.shape a + in case Layout.mosaicMirror shape of + Layout.NoMirror -> Triangular.toSquare a + Layout.SimpleMirror -> + case Layout.mosaicUplo shape of + Layout.Upper -> Symmetric.toSquare a + Layout.Lower -> + Basic.transpose $ Symmetric.toSquare $ Mosaic.transpose a + Layout.ConjugateMirror -> + case Layout.mosaicUplo shape of + Layout.Upper -> Symmetric.toSquare a + Layout.Lower -> + Basic.transpose $ Symmetric.toSquare $ Mosaic.transpose a + +pack :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> Packed.Mosaic mirror uplo sh a +pack a = + case Layout.mosaicPack $ Array.shape a of + Layout.Packed -> a + Layout.Unpacked -> Mosaic.pack a + +unpack :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> Unpacked.Mosaic mirror uplo sh a +unpack a = + let shape = Array.shape a in + case Layout.mosaicPack shape of + Layout.Unpacked -> a + Layout.Packed -> + Unpacked.fromSquare (Layout.mosaicMirror shape) $ toSquare a + +reunpack :: + (Layout.Packing pack, Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Packed.Mosaic mirror uplo sh a -> Mosaic pack mirror uplo sh a +reunpack a = Mosaic.withPack $ \packing -> + case packing of + Layout.Unpacked -> unpack a + Layout.Packed -> a + + +square :: + (Layout.Packing pack, TriDiag diag, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Mosaic pack mirror uplo sh a -> Mosaic pack mirror uplo sh a +square diag = Mosaic.repack . Unpacked.square diag . unpack + +power :: + (Layout.Packing pack, TriDiag diag, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Integer -> Mosaic pack mirror uplo sh a -> Mosaic pack mirror uplo sh a +power diag n = Mosaic.repack . Unpacked.power diag n . unpack + +powers1 :: + (Layout.Packing pack, TriDiag diag, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Mosaic pack mirror uplo sh a -> Stream (Mosaic pack mirror uplo sh a) +powers1 diag = fmap Mosaic.repack . Unpacked.powers1 diag . unpack diff --git a/src/Numeric/LAPACK/Matrix/Mosaic/Generic.hs b/src/Numeric/LAPACK/Matrix/Mosaic/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Mosaic/Generic.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Mosaic.Generic where + +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Mosaic.Private + (Mosaic, MosaicPacked, MosaicUnpacked) +import Numeric.LAPACK.Matrix.Layout.Private (Order, TriTransposed, uploOrder) +import Numeric.LAPACK.Matrix.Private (ShapeInt, shapeInt) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Storable as CheckedArray +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (Storable) + + + +fromList :: + (Layout.Packing pack, Layout.Mirror mirror, + Layout.UpLo uplo, Shape.C sh, Storable a) => + Order -> sh -> [a] -> Mosaic pack mirror uplo sh a +fromList order sh = + CheckedArray.fromList + (Layout.Mosaic Layout.autoPacking Layout.autoMirror + Layout.autoUplo order sh) + +autoFromList :: + (Layout.Packing pack, Layout.Mirror mirror, + Layout.UpLo uplo, Storable a) => + Order -> [a] -> Mosaic pack mirror uplo ShapeInt a +autoFromList order xs = + let n = length xs + packed = Layout.autoPacking + name = "Triangular.autoFromList" + size = + case packed of + Layout.Packed -> Layout.triangleExtent name n + Layout.Unpacked -> Layout.squareExtent name n + in Array.fromList + (Layout.Mosaic packed Layout.autoMirror Layout.autoUplo + order (shapeInt size)) + xs + + +transpose :: + (Layout.UpLo uplo) => + Mosaic pack mirror uplo sh a -> Mosaic pack mirror (TriTransposed uplo) sh a +transpose (Array sh a) = Array (Layout.triangularTranspose sh) a + +adjoint :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> Mosaic pack mirror (TriTransposed uplo) sh a +adjoint = transpose . Vector.conjugate + + +unpackDirty :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> + MosaicUnpacked mirror uplo sh a +unpackDirty a = + case Layout.mosaicPack $ Array.shape a of + Layout.Unpacked -> a + Layout.Packed -> unpackDirtyAux a + +unpackDirtyAux :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + MosaicPacked mirror uplo sh a -> + MosaicUnpacked mirror uplo sh a +unpackDirtyAux + (Array (Layout.Mosaic Layout.Packed mirror uplo order sh) a) = + Array.unsafeCreate + (Layout.Mosaic Layout.Unpacked mirror uplo order sh) $ + \bPtr -> + withForeignPtr a $ \aPtr -> + Mos.unpack (uploOrder uplo order) (Shape.size sh) aPtr bPtr + + +pack :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + MosaicUnpacked mirror uplo sh a -> + MosaicPacked mirror uplo sh a +pack (Array (Layout.Mosaic Layout.Unpacked mirror uplo order sh) a) = + Array.unsafeCreate + (Layout.Mosaic Layout.Packed mirror uplo order sh) $ + \bPtr -> + withForeignPtr a $ \aPtr -> + Mos.pack (uploOrder uplo order) (Shape.size sh) aPtr bPtr + +withPack :: + (Layout.Packing pack) => + (Layout.PackingSingleton pack -> Mosaic pack mirror uplo sh a) -> + Mosaic pack mirror uplo sh a +withPack = ($ Layout.autoPacking) + +repack :: + (Layout.Packing pack, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + MosaicUnpacked mirror uplo sh a -> + Mosaic pack mirror uplo sh a +repack a = withPack $ \packing -> + case packing of + Layout.Unpacked -> a + Layout.Packed -> pack a diff --git a/src/Numeric/LAPACK/Matrix/Mosaic/Packed.hs b/src/Numeric/LAPACK/Matrix/Mosaic/Packed.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Mosaic/Packed.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Mosaic.Packed ( + Mosaic, + Triangular, + identity, + diagonal, + takeDiagonal, + forceOrder, + + stackLower, + stackUpper, + takeTopLeft, + Mos.takeTopRight, + takeBottomLeft, + takeBottomRight, + ) where + +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos +import qualified Numeric.LAPACK.Matrix.Mosaic.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import Numeric.LAPACK.Matrix.Mosaic.Private + (MosaicLower, MosaicUpper, diagonalPointers, diagonalPointerPairs) +import Numeric.LAPACK.Matrix.Mosaic.Generic (transpose, unpackDirty, pack) +import Numeric.LAPACK.Matrix.Layout.Private (Order, uploOrder) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Private (fill) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import Data.Array.Comfort.Shape ((::+)) + +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (poke, peek) + +import Data.Foldable (forM_) + + + +type Mosaic mirror uplo sh = + Array (Layout.Mosaic Layout.Packed mirror uplo sh) +type Triangular uplo sh = + Array (Layout.TriangularP Layout.Packed uplo sh) + + +identity :: + (Layout.Mirror mirror, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + Order -> sh -> Mosaic mirror uplo sh a +identity order sh = + let (realOrder, uplo) = autoUploOrder order + in Array.unsafeCreateWithSize + (Layout.Mosaic + Layout.Packed Layout.autoMirror uplo order sh) $ + \size aPtr -> do + let n = Shape.size sh + fill zero size aPtr + mapM_ (flip poke one) (diagonalPointers realOrder n aPtr) + +diagonal :: + (Layout.Mirror mirror, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> Mosaic mirror uplo sh a +diagonal order (Array sh x) = do + let (realOrder, uplo) = autoUploOrder order + Array.unsafeCreateWithSize + (Layout.Mosaic Layout.Packed Layout.autoMirror + uplo order sh) $ + \size aPtr -> do + let n = Shape.size sh + fill zero size aPtr + withForeignPtr x $ \xPtr -> + forM_ (diagonalPointerPairs realOrder n xPtr aPtr) $ + \(srcPtr,dstPtr) -> poke dstPtr =<< peek srcPtr + +takeDiagonal :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic mirror uplo sh a -> Vector sh a +takeDiagonal (Array (Layout.Mosaic _pack _mirror uplo order sh) a) = + Array.unsafeCreate sh $ \xPtr -> + withForeignPtr a $ \aPtr -> + mapM_ + (\(dstPtr,srcPtr) -> poke dstPtr =<< peek srcPtr) + (diagonalPointerPairs (uploOrder uplo order) (Shape.size sh) xPtr aPtr) + + +{- +This is not maximally efficient. +It fills up a whole square. +This wastes memory but enables more regular memory access patterns. +-} +forceOrder :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Order -> Mosaic mirror uplo sh a -> Mosaic mirror uplo sh a +forceOrder newOrder a = + let shape = Array.shape a + in if Layout.mosaicOrder shape == newOrder + then a + else pack $ Unpacked.forceOrder newOrder $ unpackDirty a + + +autoUploOrder :: + (Layout.UpLo uplo) => + Order -> (Order, Layout.UpLoSingleton uplo) +autoUploOrder order = + case Layout.autoUplo of + uplo -> (uploOrder uplo order, uplo) + + +{- +It does not make much sense to put +'stackLower', 'stackUpper', 'stackSymmetric' in one function +because in 'stackLower' and 'stackUpper' +the height and width of matrix b is swapped. +-} +stackLower :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + MosaicLower mirror width a -> + Matrix.General height width a -> + MosaicLower mirror height a -> + MosaicLower mirror (width::+height) a +stackLower a b c = + transpose $ stackUpper (transpose a) (Basic.transpose b) (transpose c) + +stackUpper :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + MosaicUpper mirror height a -> + Matrix.General height width a -> + MosaicUpper mirror width a -> + MosaicUpper mirror (height::+width) a +stackUpper a b c = + let order = Layout.fullOrder $ Array.shape b + in Mos.stack (forceOrder order a) b (forceOrder order c) + +takeTopLeft :: + (Layout.UpLo uplo, Shape.C height, Shape.C width, Class.Floating a) => + Mosaic mirror uplo (height::+width) a -> + Mosaic mirror uplo height a +takeTopLeft = + Mos.getMap $ + Layout.switchUpLo + (Mos.Map $ Mos.takeTopLeft) + (Mos.Map $ transpose . Mos.takeTopLeft . transpose) + +takeBottomLeft :: + (Shape.C height, Shape.C width, Class.Floating a) => + MosaicLower mirror (width::+height) a -> Matrix.General height width a +takeBottomLeft = Basic.transpose . Mos.takeTopRight . transpose + +takeBottomRight :: + (Layout.UpLo uplo, Shape.C height, Shape.C width, Class.Floating a) => + Mosaic mirror uplo (height::+width) a -> + Mosaic mirror uplo width a +takeBottomRight = + Mos.getMap $ + Layout.switchUpLo + (Mos.Map $ Mos.takeBottomRight) + (Mos.Map $ transpose . Mos.takeBottomRight . transpose) diff --git a/src/Numeric/LAPACK/Matrix/Mosaic/Private.hs b/src/Numeric/LAPACK/Matrix/Mosaic/Private.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Mosaic/Private.hs @@ -0,0 +1,472 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} +module Numeric.LAPACK.Matrix.Mosaic.Private where + +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder) +import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Scalar (zero) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) +import Numeric.LAPACK.Private + (pointerSeq, copyBlock, copyCondConjugateToTemp, + pokeCInt, fill, withAutoWorkspaceInfo, withInfo, errorCodeMsg) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import Data.Array.Comfort.Shape ((::+)((::+))) + +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array (advancePtr) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative (pure, (<*>)) + +import Data.Foldable (forM_) + + +type Mosaic pack mirror uplo sh = Array (Layout.Mosaic pack mirror uplo sh) +type MosaicPacked mirror uplo sh = Mosaic Layout.Packed mirror uplo sh +type MosaicUnpacked mirror uplo sh = Mosaic Layout.Unpacked mirror uplo sh + +type MosaicLower mirror sh = MosaicPacked mirror Shape.Lower sh +type MosaicUpper mirror sh = MosaicPacked mirror Shape.Upper sh + + +diagonalPointers :: (Storable a) => Order -> Int -> Ptr a -> [Ptr a] +diagonalPointers order n aPtr = + take n $ scanl advancePtr aPtr $ + case order of + RowMajor -> iterate pred n + ColumnMajor -> iterate succ 2 + +diagonalPointerPairs :: + (Storable a, Storable b) => + Order -> Int -> Ptr a -> Ptr b -> [(Ptr a, Ptr b)] +diagonalPointerPairs order n aPtr bPtr = + zip (pointerSeq 1 aPtr) $ diagonalPointers order n bPtr + + +columnMajorPointers :: + (Storable a) => Int -> Ptr a -> Ptr a -> [(Int, ((Ptr a, Ptr a), Ptr a))] +columnMajorPointers n fullPtr packedPtr = + let ds = iterate succ 1 + in take n $ zip ds $ + zip + (zip (pointerSeq 1 fullPtr) (pointerSeq n fullPtr)) + (scanl advancePtr packedPtr ds) + +rowMajorPointers :: + (Storable a) => Int -> Ptr a -> Ptr a -> [(Int, (Ptr a, Ptr a))] +rowMajorPointers n fullPtr packedPtr = + let ds = iterate pred n + in take n $ zip ds $ + zip (pointerSeq (n+1) fullPtr) (scanl advancePtr packedPtr ds) + + +forPointers :: [(Int, a)] -> (Ptr CInt -> a -> IO ()) -> IO () +forPointers xs act = + alloca $ \nPtr -> + forM_ xs $ \(d,ptrs) -> do + pokeCInt nPtr d + act nPtr ptrs + + +copyTriangleToTemp :: + Class.Floating a => + Conjugation -> Order -> Int -> ForeignPtr a -> ContT r IO (Ptr a) +copyTriangleToTemp conj order = + copyCondConjugateToTemp $ + case order of + RowMajor -> conj + ColumnMajor -> NonConjugated + + +unpackToTemp :: + Storable a => + (Int -> Ptr a -> Ptr a -> IO ()) -> + Int -> ForeignPtr a -> ContT r IO (Ptr a) +unpackToTemp f n a = do + apPtr <- ContT $ withForeignPtr a + aPtr <- Call.allocaArray (n*n) + liftIO $ f n apPtr aPtr + return aPtr + + +unpack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () +unpack order n packedPtr fullPtr = + evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + ldaPtr <- Call.leadingDim n + liftIO $ withInfo errorCodeMsg "tpttr" $ + LapackGen.tpttr uploPtr nPtr packedPtr fullPtr ldaPtr + +pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () +pack order n = packRect order n n + +packRect :: Class.Floating a => Order -> Int -> Int -> Ptr a -> Ptr a -> IO () +packRect order n ld fullPtr packedPtr = + evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + ldaPtr <- Call.leadingDim ld + liftIO $ withInfo errorCodeMsg "trttp" $ + LapackGen.trttp uploPtr nPtr fullPtr ldaPtr packedPtr + + +unpackZero, _unpackZero :: + Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () +_unpackZero order n packedPtr fullPtr = do + fill zero (n*n) fullPtr + unpack order n packedPtr fullPtr + +unpackZero order n packedPtr fullPtr = do + fillTriangle zero (flipOrder order) n fullPtr + unpack order n packedPtr fullPtr + +fillTriangle :: Class.Floating a => a -> Order -> Int -> Ptr a -> IO () +fillTriangle z order n aPtr = evalContT $ do + uploPtr <- Call.char $ uploFromOrder order + nPtr <- Call.cint n + zPtr <- Call.number z + liftIO $ LapackGen.laset uploPtr nPtr nPtr zPtr zPtr aPtr nPtr + + + +uncheck :: + Mosaic pack mirror uplo sh a -> Mosaic pack mirror uplo (Unchecked sh) a +uncheck = + Array.mapShape $ + \(Layout.Mosaic packing mirror uplo order sh) -> + Layout.Mosaic packing mirror uplo order (Unchecked sh) + +recheck :: + Mosaic pack mirror uplo (Unchecked sh) a -> Mosaic pack mirror uplo sh a +recheck = + Array.mapShape $ + \(Layout.Mosaic packing mirror uplo order (Unchecked sh)) -> + Layout.Mosaic packing mirror uplo order sh + + +stack :: + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + MosaicUpper mirror height a -> + Matrix.General height width a -> + MosaicUpper mirror width a -> + MosaicUpper mirror (height::+width) a +stack (Array sha a) (Array (Layout.Full order extent) b) (Array shc c) = + let name = show $ Layout.mosaicMirror sha + (height,width) = Extent.dimensions extent + in Array.unsafeCreate + (Layout.Mosaic Layout.Packed + (Layout.mosaicMirror sha) + Layout.Upper order (height ::+ width)) $ \xPtr -> do + Call.assert (name++".stack: height shapes mismatch") $ + height == Layout.mosaicSize sha + Call.assert (name++".stack: width shapes mismatch") $ + width == Layout.mosaicSize shc + let m = Shape.size height + let n = Shape.size width + withForeignPtr a $ \aPtr -> copyTriangleA copyBlock order m n aPtr xPtr + withForeignPtr b $ \bPtr -> copyRectangle copyBlock order m n bPtr xPtr + withForeignPtr c $ \cPtr -> copyTriangleC copyBlock order m n cPtr xPtr + +takeTopRight :: + (Shape.C height, Shape.C width, Class.Floating a) => + MosaicUpper mirror (height::+width) a -> Matrix.General height width a +takeTopRight + (Array + (Layout.Mosaic _packed _mirror _upper order (height::+width)) x) = + Array.unsafeCreate (Layout.general order height width) $ \bPtr -> do + let m = Shape.size height + let n = Shape.size width + withForeignPtr x $ copyRectangle (flip . copyBlock) order m n bPtr + +takeTopLeft :: + (Shape.C height, Shape.C width, Class.Floating a) => + MosaicUpper mirror (height::+width) a -> + MosaicUpper mirror height a +takeTopLeft + (Array (Layout.Mosaic packing mirror upper order (height::+width)) x) = + Array.unsafeCreate (Layout.Mosaic packing mirror upper order height) $ + \aPtr -> do + let m = Shape.size height + let n = Shape.size width + withForeignPtr x $ copyTriangleA (flip . copyBlock) order m n aPtr + +takeBottomRight :: + (Shape.C height, Shape.C width, Class.Floating a) => + MosaicUpper mirror (height::+width) a -> + MosaicUpper mirror width a +takeBottomRight + (Array (Layout.Mosaic packing mirror upper order (height::+width)) x) = + Array.unsafeCreate (Layout.Mosaic packing mirror upper order width) $ + \cPtr -> do + let m = Shape.size height + let n = Shape.size width + withForeignPtr x $ copyTriangleC (flip . copyBlock) order m n cPtr + +{-# INLINE copyTriangleA #-} +copyTriangleA :: + (Class.Floating a) => + (Int -> Ptr a -> Ptr a -> IO ()) -> + Order -> Int -> Int -> Ptr a -> Ptr a -> IO () +copyTriangleA copy order m n aPtr xPtr = + case order of + ColumnMajor -> copy (Shape.triangleSize m) aPtr xPtr + RowMajor -> + forM_ (zip (iterate pred m) $ + zip (diagonalPointers order m aPtr) + (diagonalPointers order (m+n) xPtr)) $ + \(k,(aiPtr,xiPtr)) -> copy k aiPtr xiPtr + +{-# INLINE copyTriangleC #-} +copyTriangleC :: + (Class.Floating a) => + (Int -> Ptr a -> Ptr a -> IO ()) -> + Order -> Int -> Int -> Ptr a -> Ptr a -> IO () +copyTriangleC copy order m n cPtr xPtr = + case order of + RowMajor -> + let triSize = Shape.triangleSize n + in copy triSize cPtr + (advancePtr xPtr $ Shape.triangleSize (m+n) - triSize) + ColumnMajor -> + forM_ (zip (iterate succ 0) $ + zip (diagonalPointers order n cPtr) + (drop m $ diagonalPointers order (m+n) xPtr)) $ + \(k,(aiPtr,xiPtr)) -> + copy (k+1) (advancePtr aiPtr (-k)) (advancePtr xiPtr (-k)) + +{-# INLINE copyRectangle #-} +copyRectangle :: + (Class.Floating a) => + (Int -> Ptr a -> Ptr a -> IO ()) -> + Order -> Int -> Int -> Ptr a -> Ptr a -> IO () +copyRectangle copy order m n bPtr xPtr = + case order of + RowMajor -> + forM_ (take m $ zip (iterate pred m) $ + zip (pointerSeq n bPtr) (diagonalPointers order (m+n) xPtr)) $ + \(k,(biPtr,xiPtr)) -> copy n biPtr (advancePtr xiPtr k) + ColumnMajor -> + forM_ (take n $ zip (iterate succ m) $ + zip (pointerSeq m bPtr) + (drop m $ diagonalPointers order (m+n) xPtr)) $ + \(k,(biPtr,xiPtr)) -> copy m biPtr (advancePtr xiPtr (-k)) + + + +type Triangular uplo sh = Array (Layout.Triangular uplo sh) +type Lower sh = Triangular Shape.Lower sh +type Upper sh = Triangular Shape.Upper sh + + +newtype MultiplyRight sh a b uplo = + MultiplyRight {getMultiplyRight :: Triangular uplo sh a -> b} + +newtype Map pack mirror sh0 sh1 a uplo = + Map { + getMap :: Mosaic pack mirror uplo sh0 a -> Mosaic pack mirror uplo sh1 a + } + + +fromBanded :: + (Class.Floating a) => + Int -> Order -> Int -> ForeignPtr a -> Int -> Ptr a -> IO () +fromBanded k order n a bSize bPtr = + withForeignPtr a $ \aPtr -> do + fill zero bSize bPtr + let lda = k+1 + let pointers = + zip [0..] $ zip (pointerSeq lda aPtr) $ + diagonalPointers order n bPtr + case order of + ColumnMajor -> + forM_ pointers $ \(i,(xPtr,yPtr)) -> + let j = min i k + in copyBlock (j+1) (advancePtr xPtr (k-j)) (advancePtr yPtr (-j)) + RowMajor -> + forM_ pointers $ \(i,(xPtr,yPtr)) -> + copyBlock (min lda (n-i)) xPtr yPtr + + +{- +Naming is inconsistent to Triangular.takeUpper, +because here Hermitian is the input +and in Triangular.takeUpper, Triangular is the output. +-} +takeUpper :: MosaicUpper mirror sh a -> Upper sh a +takeUpper = + Array.mapShape + (\(Layout.Mosaic packing _mirror upper order sh) -> + Layout.Mosaic packing Layout.NoMirror upper order sh) + +fromUpper :: + (Layout.Mirror mirror) => Upper sh a -> MosaicUpper mirror sh a +fromUpper = + Array.mapShape + (\(Layout.Mosaic packing Layout.NoMirror upper order sh) -> + Layout.Mosaic packing Layout.autoMirror upper order sh) + + + +fromLowerPart :: + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + (Order -> Int -> Ptr a -> IO ()) -> + Layout.MirrorSingleton mirror -> + Full meas Extent.Small horiz height width a -> MosaicLower mirror height a +fromLowerPart fillDiag mirror (Array (Layout.Full order extent) a) = + let (height,width) = Extent.dimensions extent + m = Shape.size height + n = Shape.size width + k = case order of RowMajor -> n; ColumnMajor -> m + in Array.unsafeCreate + (Layout.Mosaic Layout.Packed + mirror Layout.Lower order height) $ \lPtr -> + withForeignPtr a $ \aPtr -> do + let dstOrder = flipOrder order + packRect dstOrder m k aPtr lPtr + fillDiag dstOrder m lPtr + +leaveDiagonal :: Order -> Int -> Ptr a -> IO () +leaveDiagonal _order _m _ptr = return () + + + +data Labelled r label a = Labelled label (ContT r IO a) + +label :: label -> a -> Labelled r label a +label lab a = Labelled lab (pure a) + +noLabel :: a -> Labelled r () a +noLabel a = Labelled () (pure a) + +instance Functor (Labelled r label) where + fmap f (Labelled lab a) = Labelled lab $ fmap f a + +runUnlabelled :: Labelled r () (IO ()) -> ContT r IO () +runUnlabelled (Labelled () m) = liftIO =<< m + +runLabelledLinear :: + String -> Labelled r String (Ptr CInt -> IO ()) -> ContT r IO () +runLabelledLinear msg (Labelled name m) = liftIO . withInfo msg name =<< m + +runLabelledWorkspace :: + (Class.Floating a) => + String -> + Labelled r String (Ptr a -> Ptr CInt -> Ptr CInt -> IO ()) -> + ContT r IO () +runLabelledWorkspace msg (Labelled name m) = + liftIO . withAutoWorkspaceInfo msg name =<< m + + +data Labelled2 r label a b = Labelled2 (Labelled r label a) (Labelled r label b) + +instance Functor (Labelled2 r label a) where + fmap f (Labelled2 a b) = Labelled2 a (fmap f b) + + +infixl 9 $*, $** + +($*) :: Labelled2 r label (a -> f) (a -> g) -> a -> Labelled2 r label f g +Labelled2 f g $* a = Labelled2 (fmap ($a) f) (fmap ($a) g) + +($**) :: + Labelled2 r label (a -> f) (a -> Ptr CInt -> g) -> + (a,Int) -> Labelled2 r label f g +Labelled2 f (Labelled lab g) $** (a,n) = + Labelled2 (fmap ($a) f) (Labelled lab $ fmap ($a) g <*> Call.leadingDim n) + + +runPacking :: + Layout.PackingSingleton pack -> + Labelled2 r label func func -> Labelled r label func +runPacking pck (Labelled2 lp lu) = + case pck of + Layout.Packed -> lp + Layout.Unpacked -> lu + +withPacking :: + Layout.PackingSingleton pack -> + Labelled2 r () (IO ()) (IO ()) -> ContT r IO () +withPacking pck = runUnlabelled . runPacking pck + +withPackingLinear :: + (func ~ (Ptr CInt -> IO ())) => + String -> Layout.PackingSingleton pack -> + Labelled2 r String func func -> ContT r IO () +withPackingLinear msg pck = runLabelledLinear msg . runPacking pck + + +data TriArg a = TriArg (Ptr a) Int + +triArg :: Ptr a -> Int -> TriArg a +triArg = TriArg + +applyFuncPair :: + (m ~ Labelled (FuncCont f) (FuncLabel f), FunctionPair f) => + m (FuncPacked f) -> m (FuncUnpacked f) -> f +applyFuncPair f g = apply (Labelled2 f g) + +class FunctionPair f where + type FuncCont f + type FuncLabel f + type FuncPacked f + type FuncUnpacked f + apply :: + Labelled2 (FuncCont f) (FuncLabel f) (FuncPacked f) (FuncUnpacked f) -> f + +type family LabelResult a +type instance LabelResult (Labelled r label a) = a + +instance FunctionPair (Labelled2 r label a b) where + type FuncCont (Labelled2 r label a b) = r + type FuncLabel (Labelled2 r label a b) = label + type FuncPacked (Labelled2 r label a b) = a + type FuncUnpacked (Labelled2 r label a b) = b + apply = id + +instance (FunctionArg a, FunctionPair f) => FunctionPair (a -> f) where + type FuncCont (a -> f) = FuncCont f + type FuncLabel (a -> f) = FuncLabel f + type FuncPacked (a -> f) = FuncArgPacked a f + type FuncUnpacked (a -> f) = FuncArgUnpacked a f + apply = applyArg + + +class FunctionArg a where + type FuncArgPacked a f + type FuncArgUnpacked a f + applyArg :: + (FunctionPair f) => + Labelled2 (FuncCont f) + (FuncLabel f) (FuncArgPacked a f) (FuncArgUnpacked a f) -> + a -> f + +instance FunctionArg (Ptr a) where + type FuncArgPacked (Ptr a) f = Ptr a -> FuncPacked f + type FuncArgUnpacked (Ptr a) f = Ptr a -> FuncUnpacked f + applyArg fg a = apply (fg$*a) + +instance FunctionArg (TriArg a) where + type FuncArgPacked (TriArg a) f = Ptr a -> FuncPacked f + type FuncArgUnpacked (TriArg a) f = Ptr a -> Ptr CInt -> FuncUnpacked f + applyArg fg (TriArg a n) = apply (fg$**(a,n)) diff --git a/src/Numeric/LAPACK/Matrix/Mosaic/Unpacked.hs b/src/Numeric/LAPACK/Matrix/Mosaic/Unpacked.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Mosaic/Unpacked.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Mosaic.Unpacked where + +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Mosaic.Private (uncheck, recheck) +import Numeric.LAPACK.Matrix.Private (Square, Full) +import Numeric.LAPACK.Matrix.Shape.Omni + (TriDiag, DiagSingleton, charFromTriDiag) +import Numeric.LAPACK.Matrix.Layout.Private + (PackingSingleton(Unpacked), MirrorSingleton, + Order(RowMajor,ColumnMajor), + flipOrder, transposeFromOrder, + sideSwapFromOrder, uploFromOrder, uploOrder) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) +import Numeric.LAPACK.Scalar (one, zero) +import Numeric.LAPACK.Private (copyBlock, conjugateToTemp) + +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import Foreign.ForeignPtr (withForeignPtr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import qualified Data.Stream as Stream +import Data.Stream (Stream) +import Data.Function.HT (powerAssociative) +import Data.Tuple.HT (double) + + + +type Mosaic mirror uplo sh = + Array (Layout.Mosaic Layout.Unpacked mirror uplo sh) +type Triangular uplo sh = + Array (Layout.TriangularP Layout.Unpacked uplo sh) + + +fromSquare :: + (Layout.UpLo uplo) => + MirrorSingleton mirror -> Square sh a -> Mosaic mirror uplo sh a +fromSquare mirror = + Array.mapShape + (\(Layout.Full order extent) -> + Layout.Mosaic Unpacked mirror Layout.autoUplo order $ + Extent.squareSize extent) + +toSquare :: Mosaic mirror uplo sh a -> Square sh a +toSquare = + Array.mapShape + (\(Layout.Mosaic Unpacked _mirror _uplo order size) -> + Layout.square order size) + +forceOrder :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Order -> Mosaic mirror uplo sh a -> Mosaic mirror uplo sh a +forceOrder newOrder a = + fromSquare (Layout.mosaicMirror $ Array.shape a) . + Basic.forceOrder newOrder . toSquare $ a + + + +square :: + (TriDiag diag, Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + DiagSingleton diag -> Mosaic mirror uplo sh a -> Mosaic mirror uplo sh a +square diag = recheck . uncurry (multiplyCompatible diag) . double . uncheck + +power :: + (Layout.UpLo uplo, TriDiag diag, Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Integer -> Mosaic mirror uplo sh a -> Mosaic mirror uplo sh a +power diag n + a@(Array (Layout.Mosaic Layout.Unpacked mirror _uplo order sh) _) = + + recheck $ + powerAssociative (multiplyCompatible diag) + (fromSquare mirror $ Square.identityOrder order $ Unchecked sh) + (uncheck a) + n + +powers1 :: + (Layout.UpLo uplo, TriDiag diag, Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Mosaic mirror uplo sh a -> Stream (Mosaic mirror uplo sh a) +powers1 diag a = + fmap recheck $ + let au = uncheck a + in Stream.iterate (flip (multiplyCompatible diag) au) au + + +multiplyCompatible :: + (Layout.UpLo uplo, TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => + DiagSingleton diag -> + Mosaic mirror uplo sh a -> + Mosaic mirror uplo sh a -> Mosaic mirror uplo sh a +multiplyCompatible diag a b = + fromSquare (Layout.mosaicMirror $ Array.shape b) $ + multiplyFull diag a $ toSquare b + +multiplyFull :: + (Layout.UpLo uplo, TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + DiagSingleton diag -> + Mosaic mirror uplo height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull diag + (Array (Layout.Mosaic Layout.Unpacked mirror uploA orderA shA) a) + (Array shapeB@(Layout.Full orderB extentB) b) = + Array.unsafeCreateWithSize shapeB $ \size cPtr -> do + let (height,width) = Extent.dimensions extentB + Call.assert (show mirror ++ ".multiplyFull: shapes mismatch") (shA == height) + let m0 = Shape.size height + let n0 = Shape.size width + let realOrderA = uploOrder uploA orderA + evalContT $ do + let (side,(m,n)) = sideSwapFromOrder orderB (m0,n0) + sidePtr <- Call.char side + uploPtr <- Call.char $ uploFromOrder realOrderA + mPtr <- Call.cint m + nPtr <- Call.cint n + alphaPtr <- Call.number one + ldaPtr <- Call.leadingDim m0 + bPtr <- ContT (withForeignPtr b) `asTypeOf` return alphaPtr + ldbPtr <- Call.leadingDim m + case mirror of + Layout.NoMirror -> do + transPtr <- + Call.char $ transposeFromOrder $ + case orderB of + ColumnMajor -> orderA + RowMajor -> flipOrder orderA + diagPtr <- Call.char $ charFromTriDiag diag + aPtr <- ContT $ withForeignPtr a + liftIO $ do + copyBlock size bPtr cPtr + BlasGen.trmm sidePtr uploPtr transPtr diagPtr + mPtr nPtr alphaPtr aPtr ldaPtr cPtr ldbPtr + Layout.SimpleMirror -> do + betaPtr <- Call.number zero + aPtr <- ContT $ withForeignPtr a + liftIO $ + BlasGen.symm sidePtr uploPtr mPtr nPtr + alphaPtr aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldbPtr + Layout.ConjugateMirror -> do + aPtr <- + if orderA == orderB + then ContT $ withForeignPtr a + else conjugateToTemp (m0*m0) a + betaPtr <- Call.number zero + liftIO $ + BlasGen.hemm sidePtr uploPtr mPtr nPtr + alphaPtr aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldbPtr diff --git a/src/Numeric/LAPACK/Matrix/Multiply.hs b/src/Numeric/LAPACK/Matrix/Multiply.hs --- a/src/Numeric/LAPACK/Matrix/Multiply.hs +++ b/src/Numeric/LAPACK/Matrix/Multiply.hs @@ -1,14 +1,22 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Multiply where -import qualified Numeric.LAPACK.Matrix.Plain.Multiply as ArrMultiply -import qualified Numeric.LAPACK.Matrix.Array.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Array.Multiply as Multiply +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Permutation as PermMatrix -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Class as MatrixClass +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic import qualified Numeric.LAPACK.Matrix.Modifier as Mod -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Permutation.Private as Perm import qualified Numeric.LAPACK.Vector as Vector @@ -22,185 +30,420 @@ import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape +import qualified Data.Stream as Stream +import Data.Stream (Stream) +import Data.Maybe (fromMaybe) + infixl 7 -*# infixr 7 #*| (#*|) :: - (MultiplyVector typ, Type.WidthOf typ ~ width, Eq width, - Class.Floating a) => - Matrix typ a -> Vector width a -> Vector (Type.HeightOf typ) a + (MultiplyVector typ xl xu, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + Vector width a -> Vector height a (#*|) = matrixVector (-*#) :: - (MultiplyVector typ, Type.HeightOf typ ~ height, Eq height, - Class.Floating a) => - Vector height a -> Matrix typ a -> Vector (Type.WidthOf typ) a + (MultiplyVector typ xl xu, Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq height, Class.Floating a) => + Vector height a -> + Matrix typ xl xu lower upper meas vert horiz height width a -> + Vector width a (-*#) = vectorMatrix -class (Type.Box typ) => MultiplyVector typ where +class (Matrix.Box typ) => MultiplyVector typ xl xu where matrixVector :: - (Type.WidthOf typ ~ width, Eq width, Class.Floating a) => - Matrix typ a -> Vector width a -> Vector (Type.HeightOf typ) a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + (Eq width, Class.Floating a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + Vector width a -> Vector height a vectorMatrix :: - (Type.HeightOf typ ~ height, Eq height, Class.Floating a) => - Vector height a -> Matrix typ a -> Vector (Type.WidthOf typ) a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + (Eq height, Class.Floating a) => + Vector height a -> + Matrix typ xl xu lower upper meas vert horiz height width a -> + Vector width a -instance (Shape.C shape) => MultiplyVector (Type.Scale shape) where - matrixVector = +instance (xl ~ (), xu ~ ()) => MultiplyVector Matrix.Scale xl xu where + matrixVector a@(Matrix.Scale _ _) = scaleWithCheck "Matrix.Multiply.matrixVector Scale" - Array.shape Vector.scale - vectorMatrix = - flip $ + Array.shape Vector.scale a + vectorMatrix v a@(Matrix.Scale _ _) = scaleWithCheck "Matrix.Multiply.vectorMatrix Scale" - Array.shape Vector.scale + Array.shape Vector.scale a v -instance (Shape.C shape) => MultiplyVector (PermMatrix.Permutation shape) where - matrixVector = PermMatrix.multiplyVector Mod.NonInverted - vectorMatrix = flip $ PermMatrix.multiplyVector Mod.Inverted +instance (xl ~ (), xu ~ ()) => MultiplyVector Matrix.Permutation xl xu where + matrixVector a@(Matrix.Permutation _) = + PermMatrix.multiplyVector Mod.NonInverted a + vectorMatrix v a@(Matrix.Permutation _) = + PermMatrix.multiplyVector Mod.Inverted a v instance - (ArrMultiply.MultiplyVector shape) => - MultiplyVector (ArrMatrix.Array shape) where - matrixVector (ArrMatrix.Array a) x = ArrMultiply.matrixVector a x - vectorMatrix x (ArrMatrix.Array a) = ArrMultiply.vectorMatrix x a + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + MultiplyVector (ArrMatrix.Array pack property) xl xu where + matrixVector = Multiply.matrixVector + vectorMatrix = Multiply.vectorMatrix -class - (Type.Box typ, Type.HeightOf typ ~ Type.WidthOf typ) => - MultiplySquare typ where +class (Matrix.Box typ) => MultiplySquare typ xl xu where {-# MINIMAL transposableSquare | fullSquare,squareFull #-} transposableSquare :: - (Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Transposition -> Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Transposition -> + Matrix.Quadratic typ xl xu lower upper height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a transposableSquare NonTransposed a b = squareFull a b transposableSquare Transposed a b = - Basic.transpose $ fullSquare (Basic.transpose b) a + Unpacked.transpose $ fullSquare (Unpacked.transpose b) a squareFull :: - (Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a squareFull = transposableSquare NonTransposed fullSquare :: - (Type.WidthOf typ ~ width, Eq width, Shape.C height, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Full vert horiz height width a -> - Matrix typ a -> Full vert horiz height width a + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full meas vert horiz height width a -> + Matrix.Quadratic typ xl xu lower upper width a -> + Full meas vert horiz height width a fullSquare b a = - Basic.transpose $ transposableSquare Transposed a $ Basic.transpose b + Unpacked.transpose $ + transposableSquare Transposed a $ Unpacked.transpose b + +type Unpacked lower upper meas vert horiz height width = + Unpacked.Unpacked MatrixShape.Arbitrary + lower upper meas vert horiz height width + infixl 7 ##*#, #*# infixr 7 #*## (#*##) :: - (MultiplySquare typ, Type.HeightOf typ ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Matrix typ a -> - Full vert horiz height width a -> Full vert horiz height width a -(#*##) = squareFull + (MultiplySquare typ xl xu, Matrix.ToQuadratic typ) => + (Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Strip lowerC, Omni.Strip upperC) => + (Omni.MultipliedBands lowerA lowerB ~ lowerC) => + (Omni.MultipliedBands lowerB lowerA ~ lowerC) => + (Omni.MultipliedBands upperA upperB ~ upperC) => + (Omni.MultipliedBands upperB upperA ~ upperC) => + (Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC) => + (Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Matrix.QuadraticMeas typ xl xu lowerA upperA measA height fuse a -> + Unpacked lowerB upperB measB vert horiz fuse width a -> + Unpacked lowerC upperC measC vert horiz height width a +a#*##b = + case factorIdentityLeft a of + (ident, q) -> + ArrMatrix.liftUnpacked1 id $ + reshapeHeight ident (squareFull q (ArrMatrix.liftUnpacked1 id b)) (##*#) :: - (MultiplySquare typ, Type.WidthOf typ ~ width, Eq width, Shape.C height, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Full vert horiz height width a -> - Matrix typ a -> Full vert horiz height width a -(##*#) = fullSquare + (MultiplySquare typ xl xu, Matrix.ToQuadratic typ) => + (Omni.Strip lowerA, Omni.Strip upperA) => + (Omni.Strip lowerB, Omni.Strip upperB) => + (Omni.Strip lowerC, Omni.Strip upperC) => + (Omni.MultipliedBands lowerA lowerB ~ lowerC) => + (Omni.MultipliedBands lowerB lowerA ~ lowerC) => + (Omni.MultipliedBands upperA upperB ~ upperC) => + (Omni.MultipliedBands upperB upperA ~ upperC) => + (Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC) => + (Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width, Class.Floating a) => + Unpacked lowerB upperB measB vert horiz height fuse a -> + Matrix.QuadraticMeas typ xl xu lowerA upperA measA fuse width a -> + Unpacked lowerC upperC measC vert horiz height width a +b##*#a = + case factorIdentityRight a of + (q, ident) -> + ArrMatrix.liftUnpacked1 id $ + reshapeWidth (fullSquare (ArrMatrix.liftUnpacked1 id b) q) ident -instance (Shape.C shape) => MultiplySquare (Type.Scale shape) where + +type IdentityMaes meas = + Matrix.QuadraticMeas Matrix.Identity () () + MatrixShape.Empty MatrixShape.Empty meas + +factorIdentityLeft :: + (Matrix.ToQuadratic typ, Extent.Measure meas) => + Matrix.QuadraticMeas typ xl xu lower upper meas height width a -> + (IdentityMaes meas height width a, + Matrix.Quadratic typ xl xu lower upper width a) +factorIdentityLeft a = + (Matrix.Identity $ Matrix.extent a, Matrix.widthToQuadratic a) + +factorIdentityRight :: + (Matrix.ToQuadratic typ, Extent.Measure meas) => + Matrix.QuadraticMeas typ xl xu lower upper meas height width a -> + (Matrix.Quadratic typ xl xu lower upper height a, + IdentityMaes meas height width a) +factorIdentityRight a = + (Matrix.heightToQuadratic a, Matrix.Identity $ Matrix.extent a) + +reshapeHeight :: + (Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC, + Extent.C vert, Extent.C horiz, Eq fuse) => + IdentityMaes measA height fuse a -> + Full measB vert horiz fuse width a -> + Full measC vert horiz height width a +reshapeHeight (Matrix.Identity extentA) = + ArrMatrix.lift1 $ FullBasic.mapExtent $ \extentB -> + fromMaybe (error "Multiply.reshapeHeight: shapes mismatch") $ + Extent.fuse + (ExtentPriv.unifyLeft extentA extentB) + (ExtentPriv.relaxMeasureWith extentA extentB) + +reshapeWidth :: + (Extent.Measure measA, Extent.Measure measB, Extent.Measure measC, + Extent.MultiplyMeasure measA measB ~ measC, + Extent.C vert, Extent.C horiz, Eq fuse) => + Full measB vert horiz height fuse a -> + IdentityMaes measA fuse width a -> + Full measC vert horiz height width a +reshapeWidth = flip $ \(Matrix.Identity extentA) -> + ArrMatrix.lift1 $ FullBasic.mapExtent $ \extentB -> + fromMaybe (error "Multiply.reshapeWidth: shapes mismatch") $ + Extent.fuse + (ExtentPriv.relaxMeasureWith extentA extentB) + (Extent.transpose $ + ExtentPriv.unifyLeft + (Extent.transpose extentA) (Extent.transpose extentB)) + + +instance (xl ~ (), xu ~ ()) => MultiplySquare Matrix.Scale xl xu where transposableSquare _trans = - scaleWithCheck "Matrix.Multiply.transposableSquare" Type.height $ + scaleWithCheck "Matrix.Multiply.transposableSquare" Matrix.height $ ArrMatrix.lift1 . Vector.scale -instance (Shape.C shape) => MultiplySquare (PermMatrix.Permutation shape) where +instance (xl ~ (), xu ~ ()) => MultiplySquare Matrix.Permutation xl xu where transposableSquare = PermMatrix.multiplyFull . Perm.inversionFromTransposition instance - (ArrMultiply.MultiplySquare shape) => - MultiplySquare (ArrMatrix.Array shape) where - transposableSquare = ArrMatrix.lift2 . ArrMultiply.transposableSquare - fullSquare = ArrMatrix.lift2 ArrMultiply.fullSquare - squareFull = ArrMatrix.lift2 ArrMultiply.squareFull - + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + MultiplySquare (ArrMatrix.Array pack property) xl xu where + transposableSquare = Multiply.transposableSquare + fullSquare = Multiply.fullSquare + squareFull = Multiply.squareFull -class (Type.Box typ, Type.HeightOf typ ~ Type.WidthOf typ) => Power typ where - square :: (Class.Floating a) => Matrix typ a -> Matrix typ a - power :: (Class.Floating a) => Int -> Matrix typ a -> Matrix typ a +class (Matrix.Box typ) => Power typ xl xu where + square :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> + Matrix.Quadratic typ xl xu lower upper sh a + power :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + Integer -> + Matrix.Quadratic typ xl xu lower upper sh a -> + Matrix.Quadratic typ xl xu lower upper sh a + powers1 :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> + Stream (Matrix.Quadratic typ xl xu lower upper sh a) -instance (Shape.C shape) => Power (Type.Scale shape) where - square (Type.Scale sh a) = Type.Scale sh (a*a) - power n (Type.Scale sh a) = Type.Scale sh (a^n) +instance (xl ~ (), xu ~ ()) => Power Matrix.Scale xl xu where + square (Matrix.Scale sh a) = Matrix.Scale sh (a*a) + power n (Matrix.Scale sh a) = Matrix.Scale sh (a^n) + powers1 (Matrix.Scale sh a) = + fmap (Matrix.Scale sh) $ Stream.iterate (*a) a -instance (Shape.C shape) => Power (PermMatrix.Permutation shape) where - square (Type.Permutation p) = Type.Permutation $ Perm.square p - power n (Type.Permutation p) = - Type.Permutation $ Perm.power (fromIntegral n) p +instance (xl ~ (), xu ~ ()) => Power Matrix.Permutation xl xu where + square (Matrix.Permutation p) = Matrix.Permutation $ Perm.square p + power n (Matrix.Permutation p) = Matrix.Permutation $ Perm.power n p + powers1 (Matrix.Permutation p) = + fmap Matrix.Permutation $ Stream.iterate (flip Perm.multiplyUnchecked p) p -instance (ArrMatrix.Power shape) => Power (ArrMatrix.Array shape) where - square = ArrMatrix.lift1 ArrMultiply.square - power = ArrMatrix.lift1 . ArrMultiply.power +instance + (Layout.Packing pack, Omni.Property property, xl ~ (), xu ~ ()) => + Power (ArrMatrix.Array pack property) xl xu where + square = Multiply.square + power = Multiply.power + powers1 = Multiply.powers1 +powers :: + (Power typ xl xu, MatrixClass.SquareShape typ) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Shape.C sh, Class.Floating a) => + Matrix.Quadratic typ xl xu lower upper sh a -> + Stream (Matrix.Quadratic typ xl xu lower upper sh a) +powers a = Stream.Cons (MatrixClass.identityFrom a) (powers1 a) (#*#) :: - (Multiply typA typB, Class.Floating a) => - Matrix typA a -> Matrix typB a -> Matrix (Multiplied typA typB) a + (Matrix.Box typA, Omni.Strip lowerA, Omni.Strip upperA) => + (Matrix.Box typB, Omni.Strip lowerB, Omni.Strip upperB) => + (Matrix.Box typC, Omni.Strip lowerC, Omni.Strip upperC) => + (Multiply typA xlA xuA typB xlB xuB lowerC upperC measC) => + (Multiplied typA xlA xuA typB xlB xuB lowerC upperC measC ~ typC) => + (MultipliedExtra typA xlA xuA typB xlB xuB ~ xlC) => + (MultipliedExtra typA xuA xlA typB xuB xlB ~ xuC) => + (Omni.MultipliedStrip lowerA lowerB ~ lowerC) => + (Omni.MultipliedStrip lowerB lowerA ~ lowerC) => + (Omni.MultipliedStrip upperA upperB ~ upperC) => + (Omni.MultipliedStrip upperB upperA ~ upperC) => + (Omni.MultipliedBands lowerA lowerB ~ lowerC) => + (Omni.MultipliedBands lowerB lowerA ~ lowerC) => + (Omni.MultipliedBands upperA upperB ~ upperC) => + (Omni.MultipliedBands upperB upperA ~ upperC) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (ExtentPriv.MultiplyMeasure measA measB ~ measC) => + (ExtentPriv.MultiplyMeasure measB measA ~ measC) => + (ExtentPriv.Multiply vertA vertB ~ vertC) => + (ExtentPriv.Multiply vertB vertA ~ vertC) => + (ExtentPriv.Multiply horizA horizB ~ horizC) => + (ExtentPriv.Multiply horizB horizA ~ horizC) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width) => + (Class.Floating a) => + Matrix typA xlA xuA lowerA upperA measA vertA horizA height fuse a -> + Matrix typB xlB xuB lowerB upperB measB vertB horizB fuse width a -> + Matrix typC xlC xuC lowerC upperC measC vertC horizC height width a (#*#) = matrixMatrix -class (Type.Box typA, Type.Box typB) => Multiply typA typB where - type Multiplied typA typB +class + (Matrix.Box typA, Matrix.Box typB) => + Multiply typA xlA xuA typB xlB xuB lowerC upperC measC where + type Multiplied typA xlA xuA typB xlB xuB lowerC upperC measC + type MultipliedExtra typA xlA xuA typB xlB xuB matrixMatrix :: + (Matrix.Box typA, Omni.Strip lowerA, Omni.Strip upperA) => + (Matrix.Box typB, Omni.Strip lowerB, Omni.Strip upperB) => + (Matrix.Box typC, Omni.Strip lowerC, Omni.Strip upperC) => + (Multiplied typA xlA xuA typB xlB xuB lowerC upperC measC ~ typC) => + (MultipliedExtra typA xlA xuA typB xlB xuB ~ xlC) => + (MultipliedExtra typA xuA xlA typB xuB xlB ~ xuC) => + (Omni.MultipliedStrip lowerA lowerB ~ lowerC) => + (Omni.MultipliedStrip lowerB lowerA ~ lowerC) => + (Omni.MultipliedStrip upperA upperB ~ upperC) => + (Omni.MultipliedStrip upperB upperA ~ upperC) => + (Omni.MultipliedBands lowerA lowerB ~ lowerC) => + (Omni.MultipliedBands lowerB lowerA ~ lowerC) => + (Omni.MultipliedBands upperA upperB ~ upperC) => + (Omni.MultipliedBands upperB upperA ~ upperC) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (ExtentPriv.MultiplyMeasure measA measB ~ measC) => + (ExtentPriv.MultiplyMeasure measB measA ~ measC) => + (ExtentPriv.Multiply vertA vertB ~ vertC) => + (ExtentPriv.Multiply vertB vertA ~ vertC) => + (ExtentPriv.Multiply horizA horizB ~ horizC) => + (ExtentPriv.Multiply horizB horizA ~ horizC) => + (Shape.C height, Shape.C fuse, Eq fuse, Shape.C width) => (Class.Floating a) => - Matrix typA a -> Matrix typB a -> Matrix (Multiplied typA typB) a + Matrix typA xlA xuA lowerA upperA measA vertA horizA height fuse a -> + Matrix typB xlB xuB lowerB upperB measB vertB horizB fuse width a -> + Matrix typC xlC xuC lowerC upperC measC vertC horizC height width a instance - (Box.Box shapeA, Box.Box shapeB, ArrMultiply.Multiply shapeA shapeB) => - Multiply (ArrMatrix.Array shapeA) (ArrMatrix.Array shapeB) where - type Multiplied (ArrMatrix.Array shapeA) (ArrMatrix.Array shapeB) = - ArrMatrix.Array (ArrMultiply.Multiplied shapeA shapeB) - matrixMatrix (ArrMatrix.Array a) (ArrMatrix.Array b) = - ArrMatrix.Array $ ArrMultiply.matrixMatrix a b + (Layout.Packing packA, Omni.Property propertyA, xlA ~ (), xuA ~ (), + Layout.Packing packB, Omni.Property propertyB, xlB ~ (), xuB ~ (), + Layout.Packing packC, Omni.Property propertyC, + Multiply.MultipliedPacking packA packB ~ pack, + Multiply.MultipliedPacking packB packA ~ pack, + Omni.MultipliedProperty propertyA propertyB ~ propertyAB, + Omni.MultipliedProperty propertyB propertyA ~ propertyAB, + Omni.UnitIfTriangular lowerC upperC ~ diag, + Omni.UnitIfTriangular upperC lowerC ~ diag, + Multiply.PackingByStrip lowerC upperC measC pack ~ packC, + Multiply.PackingByStrip upperC lowerC measC pack ~ packC, + Omni.MergeUnit propertyAB diag ~ propertyC, + Omni.MergeUnit diag propertyAB ~ propertyC) => + Multiply + (ArrMatrix.Array packA propertyA) xlA xuA + (ArrMatrix.Array packB propertyB) xlB xuB + lowerC upperC measC where + type Multiplied + (ArrMatrix.Array packA propertyA) xlA xuA + (ArrMatrix.Array packB propertyB) xlB xuB + lowerC upperC measC = + ArrMatrix.Array + (Multiply.PackingByStrip lowerC upperC measC + (Multiply.MultipliedPacking packA packB)) + (Omni.MergeUnit + (Omni.MultipliedProperty propertyA propertyB) + (Omni.UnitIfTriangular lowerC upperC)) + type MultipliedExtra + (ArrMatrix.Array packA propertyA) xlA xuA + (ArrMatrix.Array packB propertyB) xlB xuB = () + matrixMatrix = Multiply.matrixMatrix instance - (Shape.C shapeA, Eq shapeA, shapeA ~ shapeB, Shape.C shapeB) => - Multiply (Type.Scale shapeA) (Type.Scale shapeB) where - type Multiplied (Type.Scale shapeA) (Type.Scale shapeB) = Type.Scale shapeB - matrixMatrix = Type.multiplySame + (xlA ~ (), xuA ~ (), xlB ~ (), xuB ~ (), + lowerC ~ MatrixShape.Empty, upperC ~ MatrixShape.Empty) => + Multiply Matrix.Scale xlA xuA Matrix.Scale xlB xuB lowerC upperC measC + where + type Multiplied + Matrix.Scale xlA xuA Matrix.Scale xlB xuB lowerC upperC measC = + Matrix.Scale + type MultipliedExtra Matrix.Scale xlA xuA Matrix.Scale xlB xuB = () + matrixMatrix a@(Matrix.Scale _ _) b@(Matrix.Scale _ _) = + Matrix.multiplySame a b instance - (Shape.C shapeA, Eq shapeA, shapeA ~ Box.HeightOf shapeB, - Box.Box shapeB, ArrMultiply.Scale shapeB) => - Multiply (Type.Scale shapeA) (ArrMatrix.Array shapeB) where - type Multiplied (Type.Scale shapeA) (ArrMatrix.Array shapeB) = - ArrMatrix.Array shapeB - matrixMatrix = - scaleWithCheck "Matrix.Multiply.multiply Scale" Type.height - ArrMatrix.scale + (ArrMatrix.Scale property, xlA ~ (), xuA ~ (), xlB ~ (), xuB ~ ()) => + Multiply Matrix.Scale xlA xuA (ArrMatrix.Array pack property) xlB xuB + lowerC upperC measC + where + type Multiplied Matrix.Scale xlA xuA (ArrMatrix.Array pack property) xlB xuB + lowerC upperC measC + = ArrMatrix.Array pack property + type MultipliedExtra + Matrix.Scale xlA xuA (ArrMatrix.Array pack property) xlB xuB = () + matrixMatrix a@(Matrix.Scale _ _) = + scaleWithCheck "Matrix.Multiply.multiply Scale" Matrix.height + ArrMatrix.scale a instance - (Box.Box shapeA, ArrMultiply.Scale shapeA, Box.WidthOf shapeA ~ shapeB, - Shape.C shapeB, Eq shapeB) => - Multiply (ArrMatrix.Array shapeA) (Type.Scale shapeB) where - type Multiplied (ArrMatrix.Array shapeA) (Type.Scale shapeB) = - ArrMatrix.Array shapeA - matrixMatrix = flip $ - scaleWithCheck "Matrix.Multiply.multiply Scale" Type.width - ArrMatrix.scale + (ArrMatrix.Scale property, xlA ~ (), xuA ~ (), xlB ~ (), xuB ~ ()) => + Multiply (ArrMatrix.Array pack property) xlA xuA Matrix.Scale xlB xuB + lowerC upperC measC + where + type Multiplied (ArrMatrix.Array pack property) xlA xuA Matrix.Scale xlB xuB + lowerC upperC measC + = ArrMatrix.Array pack property + type MultipliedExtra + (ArrMatrix.Array pack property) xlA xuA Matrix.Scale xlB xuB = () + matrixMatrix = flip $ \b@(Matrix.Scale _ _) a@(ArrMatrix.Array _) -> + scaleWithCheck "Matrix.Multiply.multiply Scale" Matrix.width + ArrMatrix.scale b a instance - (Shape.C shapeA, Eq shapeA, shapeA ~ shapeB, Shape.C shapeB) => - Multiply (Perm.Permutation shapeA) (Perm.Permutation shapeB) where - type Multiplied (Perm.Permutation shapeA) (Perm.Permutation shapeB) = - Perm.Permutation shapeB - matrixMatrix = Type.multiplySame + (xlA ~ (), xuA ~ (), xlB ~ (), xuB ~ ()) => + Multiply Matrix.Permutation xlA xuA Matrix.Permutation xlB xuB + lowerC upperC measC where + type Multiplied Matrix.Permutation xlA xuA Matrix.Permutation xlB xuB + lowerC upperC measC = Matrix.Permutation + type MultipliedExtra + Matrix.Permutation xlA xuA Matrix.Permutation xlB xuB = () + matrixMatrix (Matrix.Permutation a) (Matrix.Permutation b) = + Matrix.Permutation $ Perm.multiply b a diff --git a/src/Numeric/LAPACK/Matrix/Permutation.hs b/src/Numeric/LAPACK/Matrix/Permutation.hs --- a/src/Numeric/LAPACK/Matrix/Permutation.hs +++ b/src/Numeric/LAPACK/Matrix/Permutation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Permutation ( Permutation, size, @@ -7,7 +8,7 @@ Perm.inversionFromTransposition, fromPermutation, toPermutation, - toMatrix, + toSquare, determinant, transpose, multiplyVector, @@ -15,11 +16,13 @@ ) where import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Modifier as Mod +import qualified Numeric.LAPACK.Permutation.Private as Plain import qualified Numeric.LAPACK.Permutation as Perm -import Numeric.LAPACK.Permutation (Permutation) import Numeric.LAPACK.Matrix.Type (Matrix(Permutation)) import Numeric.LAPACK.Vector (Vector) @@ -28,44 +31,52 @@ import qualified Data.Array.Comfort.Shape as Shape -size :: Matrix (Permutation sh) a -> sh +type Permutation sh = + FlexPermutation Layout.Filled Layout.Filled sh +type FlexPermutation lower upper sh = + Matrix.Quadratic Matrix.Permutation () () lower upper sh + +size :: FlexPermutation lower upper sh a -> sh size (Permutation perm) = Perm.size perm -identity :: (Shape.C sh) => sh -> Matrix (Permutation sh) a +identity :: (Shape.C sh) => sh -> FlexPermutation lower upper sh a identity = Permutation . Perm.identity fromPermutation :: - (Shape.C sh) => Perm.Permutation sh -> Matrix (Permutation sh) a + (Shape.C sh) => Perm.Permutation sh -> Permutation sh a fromPermutation = Permutation toPermutation :: - (Shape.C sh) => Matrix (Permutation sh) a -> Perm.Permutation sh + (Shape.C sh) => FlexPermutation lower upper sh a -> Perm.Permutation sh toPermutation (Permutation perm) = perm -determinant :: (Shape.C sh, Class.Floating a) => Matrix (Permutation sh) a -> a +determinant :: + (Shape.C sh, Class.Floating a) => FlexPermutation lower upper sh a -> a determinant (Permutation perm) = Perm.numberFromSign $ Perm.determinant perm transpose :: - (Shape.C sh) => Matrix (Permutation sh) a -> Matrix (Permutation sh) a + (Shape.C sh) => + FlexPermutation lower upper sh a -> FlexPermutation upper lower sh a transpose (Permutation perm) = Permutation $ Perm.transpose perm -toMatrix :: - (Shape.C sh, Class.Floating a) => - Matrix (Permutation sh) a -> ArrMatrix.Square sh a -toMatrix (Permutation perm) = Perm.toMatrix perm +toSquare :: + (Omni.Strip lower, Omni.Strip upper, Shape.C sh, Class.Floating a) => + FlexPermutation lower upper sh a -> + ArrMatrix.Quadratic Layout.Unpacked Omni.Arbitrary lower upper sh a +toSquare (Permutation perm) = ArrMatrix.liftUnpacked0 $ Plain.toMatrix perm multiplyVector :: (Shape.C size, Eq size, Class.Floating a) => - Mod.Inversion -> Matrix (Permutation size) a -> + Mod.Inversion -> FlexPermutation lower upper size a -> Vector size a -> Vector size a multiplyVector inverted (Permutation perm) = - ArrMatrix.unliftColumn MatrixShape.ColumnMajor (Perm.apply inverted perm) + ArrMatrix.unliftColumn Layout.ColumnMajor (Perm.apply inverted perm) multiplyFull :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Mod.Inversion -> Matrix (Permutation height) a -> - ArrMatrix.Full vert horiz height width a -> - ArrMatrix.Full vert horiz height width a + Mod.Inversion -> FlexPermutation lower upper height a -> + ArrMatrix.Full meas vert horiz height width a -> + ArrMatrix.Full meas vert horiz height width a multiplyFull inverted (Permutation perm) = Perm.apply inverted perm diff --git a/src/Numeric/LAPACK/Matrix/Plain.hs b/src/Numeric/LAPACK/Matrix/Plain.hs --- a/src/Numeric/LAPACK/Matrix/Plain.hs +++ b/src/Numeric/LAPACK/Matrix/Plain.hs @@ -50,7 +50,7 @@ Basic.scaleRowsReal, Basic.scaleColumnsReal, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Square.Basic as Square import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Basic as Basic @@ -58,7 +58,8 @@ import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector.Private as VectorPriv import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Shape.Private +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), transposeFromOrder) import Numeric.LAPACK.Matrix.Basic (transpose, adjoint, forceOrder, forceRowMajor) @@ -104,51 +105,49 @@ (Shape.C height, Shape.C width, Storable a) => height -> width -> [a] -> General height width a fromList height width = - CheckedArray.fromList (MatrixShape.general RowMajor height width) + CheckedArray.fromList (Layout.general RowMajor height width) tallFromGeneral :: (Shape.C height, Shape.C width, Storable a) => General height width a -> Tall height width a tallFromGeneral = - Array.mapShape $ \(MatrixShape.Full order extent) -> - uncurry (MatrixShape.tall order) (Extent.dimensions extent) + Array.mapShape $ \(Layout.Full order extent) -> + uncurry (Layout.tall order) (Extent.dimensions extent) wideFromGeneral :: (Shape.C height, Shape.C width, Storable a) => General height width a -> Wide height width a wideFromGeneral = - Array.mapShape $ \(MatrixShape.Full order extent) -> - uncurry (MatrixShape.wide order) (Extent.dimensions extent) + Array.mapShape $ \(Layout.Full order extent) -> + uncurry (Layout.wide order) (Extent.dimensions extent) identity :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C sh, Class.Floating a) => - sh -> General sh sh a + sh -> Full meas vert horiz sh sh a identity = Square.toFull . Square.identity diagonal :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C sh, Class.Floating a) => - Vector sh a -> General sh sh a + Vector sh a -> Full meas vert horiz sh sh a diagonal = Square.toFull . Square.diagonal mapHeight :: - (Shape.C heightA, Shape.C heightB, - Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Shape.C heightA, Shape.C heightB, Extent.C vert, Extent.C horiz) => (heightA -> heightB) -> - Full vert horiz heightA width a -> - Full vert horiz heightB width a -mapHeight f = Basic.mapHeight $ MatrixShape.mapChecked "mapHeight" f + Full Extent.Size vert horiz heightA width a -> + Full Extent.Size vert horiz heightB width a +mapHeight f = Basic.mapHeight $ Layout.mapChecked "mapHeight" f mapWidth :: - (Shape.C widthA, Shape.C widthB, - Extent.GeneralTallWide vert horiz, - Extent.GeneralTallWide horiz vert) => + (Shape.C widthA, Shape.C widthB, Extent.C vert, Extent.C horiz) => (widthA -> widthB) -> - Full vert horiz height widthA a -> - Full vert horiz height widthB a -mapWidth f = Basic.mapWidth $ MatrixShape.mapChecked "mapWidth" f + Full Extent.Size vert horiz height widthA a -> + Full Extent.Size vert horiz height widthB a +mapWidth f = Basic.mapWidth $ Layout.mapChecked "mapWidth" f fromRowsNonEmpty :: @@ -218,71 +217,73 @@ toRows :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> [Vector width a] + Full meas vert horiz height width a -> [Vector width a] toRows a = let ad = Basic.mapHeight Shape.Deferred $ fromFull a in map (takeRow ad) $ Shape.indices $ Matrix.height ad toColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> [Vector height a] + Full meas vert horiz height width a -> [Vector height a] toColumns a = let ad = Basic.mapWidth Shape.Deferred $ fromFull a in map (takeColumn ad) $ Shape.indices $ Matrix.width ad toRowArray :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> BoxedArray.Array height (Vector width a) + Full meas vert horiz height width a -> + BoxedArray.Array height (Vector width a) toRowArray a = BoxedArray.fromList (Matrix.height a) (toRows a) toColumnArray :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> BoxedArray.Array width (Vector height a) + Full meas vert horiz height width a -> + BoxedArray.Array width (Vector height a) toColumnArray a = BoxedArray.fromList (Matrix.width a) (toColumns a) toRowContainer :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Container.C f, Shape.C width, Class.Floating a) => - Full vert horiz (Container.Shape f) width a -> f (Vector width a) + Full meas vert horiz (Container.Shape f) width a -> f (Vector width a) toRowContainer a = Container.fromList (Matrix.height a) (toRows a) toColumnContainer :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Container.C f, Class.Floating a) => - Full vert horiz height (Container.Shape f) a -> f (Vector height a) + Full meas vert horiz height (Container.Shape f) a -> f (Vector height a) toColumnContainer a = Container.fromList (Matrix.width a) (toColumns a) takeRow :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.C width, Shape.Index height ~ ix, Class.Floating a) => - Full vert horiz height width a -> ix -> Vector width a + Full meas vert horiz height width a -> ix -> Vector width a takeRow x ix = either (RowMajor.takeRow ix) (RowMajor.takeColumn ix) $ Matrix.revealOrder x takeColumn :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.Indexed width, Shape.Index width ~ ix, Class.Floating a) => - Full vert horiz height width a -> ix -> Vector height a + Full meas vert horiz height width a -> ix -> Vector height a takeColumn x ix = either (RowMajor.takeColumn ix) (RowMajor.takeRow ix) $ Matrix.revealOrder x takeEqually :: - (Extent.C vert, Extent.C horiz, Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Class.Floating a) => Int -> - Full vert horiz ShapeInt ShapeInt a -> - Full vert horiz ShapeInt ShapeInt a -takeEqually k (Array (MatrixShape.Full order extentA) a) = + Full meas vert horiz ShapeInt ShapeInt a -> + Full meas vert horiz ShapeInt ShapeInt a +takeEqually k (Array (Layout.Full order extentA) a) = let (Shape.ZeroBased heightA, Shape.ZeroBased widthA) = Extent.dimensions extentA heightB = min k heightA @@ -291,18 +292,18 @@ Extent.reduceConsistent (Shape.ZeroBased heightB) (Shape.ZeroBased widthB) extentA in if' (k<0) (error "take: negative number") $ - Array.unsafeCreate (MatrixShape.Full order extentB) $ \bPtr -> + Array.unsafeCreate (Layout.Full order extentB) $ \bPtr -> withForeignPtr a $ \aPtr -> case order of RowMajor -> copySubMatrix widthB heightB widthA aPtr widthB bPtr ColumnMajor -> copySubMatrix heightB widthB heightA aPtr heightB bPtr dropEqually :: - (Extent.C vert, Extent.C horiz, Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Class.Floating a) => Int -> - Full vert horiz ShapeInt ShapeInt a -> - Full vert horiz ShapeInt ShapeInt a -dropEqually k (Array (MatrixShape.Full order extentA) a) = + Full meas vert horiz ShapeInt ShapeInt a -> + Full meas vert horiz ShapeInt ShapeInt a +dropEqually k (Array (Layout.Full order extentA) a) = let (Shape.ZeroBased heightA, Shape.ZeroBased widthA) = Extent.dimensions extentA heightB = heightA - top; top = min k heightA @@ -311,7 +312,7 @@ Extent.reduceConsistent (Shape.ZeroBased heightB) (Shape.ZeroBased widthB) extentA in if' (k<0) (error "drop: negative number") $ - Array.unsafeCreate (MatrixShape.Full order extentB) $ \bPtr -> + Array.unsafeCreate (Layout.Full order extentB) $ \bPtr -> withForeignPtr a $ \aPtr -> case order of RowMajor -> @@ -323,11 +324,11 @@ swapRows :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.C width, Class.Floating a) => Shape.Index height -> Shape.Index height -> - Full vert horiz height width a -> Full vert horiz height width a -swapRows i j (Array shape@(MatrixShape.Full order extent) a) = + Full meas vert horiz height width a -> Full meas vert horiz height width a +swapRows i j (Array shape@(Layout.Full order extent) a) = Array.unsafeCreateWithSize shape $ \blockSize bPtr -> evalContT $ do let (height,width) = Extent.dimensions extent let m = Shape.size height @@ -349,18 +350,20 @@ (advancePtr bPtr (incVert*offsetJ)) incPtr swapColumns :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.Indexed width, Class.Floating a) => Shape.Index width -> Shape.Index width -> - Full vert horiz height width a -> Full vert horiz height width a + Full meas vert horiz height width a -> Full meas vert horiz height width a swapColumns i j = transpose . swapRows i j . transpose -- alternative: laswp reverseRows :: - (Extent.C vert, Extent.C horiz, Shape.C width, Class.Floating a) => - Full vert horiz ShapeInt width a -> Full vert horiz ShapeInt width a -reverseRows (Array shape@(MatrixShape.Full order extent) a) = + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + Full meas vert horiz height width a +reverseRows (Array shape@(Layout.Full order extent) a) = Array.unsafeCreateWithSize shape $ \blockSize bPtr -> evalContT $ do let (height,width) = Extent.dimensions extent let n = Shape.size height @@ -378,8 +381,10 @@ ColumnMajor -> LapackGen.lapmr fwdPtr nPtr mPtr bPtr nPtr kPtr reverseColumns :: - (Extent.C vert, Extent.C horiz, Shape.C height, Class.Floating a) => - Full vert horiz height ShapeInt a -> Full vert horiz height ShapeInt a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + Full meas vert horiz height width a -> + Full meas vert horiz height width a reverseColumns = transpose . reverseRows . transpose @@ -392,7 +397,7 @@ (Shape.Indexed height, Shape.C width, Shape.C sh, Class.Floating a) => BoxedArray.Array sh (Shape.Index height) -> General height width a -> General sh width a -takeRowArray ixs (Array (MatrixShape.Full order extent) a) = +takeRowArray ixs (Array (Layout.Full order extent) a) = let (heightA, width) = Extent.dimensions extent heightB = BoxedArray.shape ixs offsets = map (Shape.offset heightA) $ BoxedArray.toList ixs @@ -400,7 +405,7 @@ ma = Shape.size heightA mb = Shape.size heightB n = Shape.size width - in Array.unsafeCreate (MatrixShape.general order heightB width) $ \bPtr -> + in Array.unsafeCreate (Layout.general order heightB width) $ \bPtr -> withForeignPtr a $ \aPtr -> case order of RowMajor -> do @@ -445,51 +450,51 @@ fromRowMajor :: (Shape.C height, Shape.C width, Storable a) => Array (height,width) a -> General height width a -fromRowMajor = Array.mapShape (uncurry $ MatrixShape.general RowMajor) +fromRowMajor = Array.mapShape (uncurry $ Layout.general RowMajor) toRowMajor :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Array (height,width) a + Full meas vert horiz height width a -> Array (height,width) a toRowMajor = Array.mapShape - (\shape -> (MatrixShape.fullHeight shape, MatrixShape.fullWidth shape)) . + (\shape -> (Layout.fullHeight shape, Layout.fullWidth shape)) . forceRowMajor adaptOrder :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> - Full vert horiz height width a -adaptOrder x = forceOrder (MatrixShape.fullOrder $ Array.shape x) + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +adaptOrder x = forceOrder (Layout.fullOrder $ Array.shape x) add, sub :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq height, Eq width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a add x y = Vector.add (adaptOrder y x) y sub x y = Vector.sub (adaptOrder y x) y rowSums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Vector height a + Full meas vert horiz height width a -> Vector height a rowSums m = Basic.multiplyVectorUnchecked m $ Vector.one $ Matrix.width m -- Does not work because incx must not be zero _rowSums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Vector height a -_rowSums (Array shape@(MatrixShape.Full order extent) a) = + Full meas vert horiz height width a -> Vector height a +_rowSums (Array shape@(Layout.Full order extent) a) = Array.unsafeCreate (Extent.height extent) $ \yPtr -> do - let (m,n) = MatrixShape.dimensions shape + let (m,n) = Layout.dimensions shape let lda = m evalContT $ do transPtr <- Call.char $ transposeFromOrder order @@ -508,19 +513,19 @@ xPtr incxPtr betaPtr yPtr incyPtr columnSums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full vert horiz height width a -> Vector width a + Full meas vert horiz height width a -> Vector width a columnSums m = Basic.multiplyVectorUnchecked (transpose m) $ Vector.one $ Matrix.height m rowArgAbsMaximums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.InvIndexed width, Shape.Index width ~ ix, Storable ix, Class.Floating a) => - Full vert horiz height width a -> (Vector height ix, Vector height a) -rowArgAbsMaximums (Array (MatrixShape.Full order extent) a) = + Full meas vert horiz height width a -> (Vector height ix, Vector height a) +rowArgAbsMaximums (Array (Layout.Full order extent) a) = let (height,width) = Extent.dimensions extent in Array.unsafeCreateWithSizeAndResult height $ \m ixPtr -> ArrayIO.unsafeCreate height $ \bPtr -> evalContT $ do @@ -546,11 +551,11 @@ poke biPtr =<< peekElemOff aiPtr (ix*incx) columnArgAbsMaximums :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.InvIndexed height, Shape.C width, Shape.Index height ~ ix, Storable ix, Class.Floating a) => - Full vert horiz height width a -> (Vector width ix, Vector width a) + Full meas vert horiz height width a -> (Vector width ix, Vector width a) columnArgAbsMaximums = rowArgAbsMaximums . transpose @@ -584,17 +589,17 @@ kronecker :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Shape.C widthA, Shape.C heightB, Shape.C widthB, Class.Floating a) => - Full vert horiz heightA widthA a -> - Full vert horiz heightB widthB a -> - Full vert horiz (heightA,heightB) (widthA,widthB) a + Full meas vert horiz heightA widthA a -> + Full meas vert horiz heightB widthB a -> + Full meas vert horiz (heightA,heightB) (widthA,widthB) a kronecker a b = - let MatrixShape.Full orderB extentB = Array.shape b + let Layout.Full orderB extentB = Array.shape b shc = - MatrixShape.Full orderB $ - Extent.kronecker (MatrixShape.fullExtent $ Array.shape a) extentB + Layout.Full orderB $ + Extent.kronecker (Layout.fullExtent $ Array.shape a) extentB in either (Array.reshape shc . RowMajor.kronecker a) (Array.reshape shc . RowMajor.kronecker (transpose a)) $ @@ -606,7 +611,7 @@ (height,width) -> [(a, (Vector height a, Vector width a))] -> General height width a sumRank1 (height,width) xys = - Array.unsafeCreateWithSize (MatrixShape.general ColumnMajor height width) $ + Array.unsafeCreateWithSize (Layout.general ColumnMajor height width) $ \size aPtr -> evalContT $ do let m = Shape.size height diff --git a/src/Numeric/LAPACK/Matrix/Plain/Class.hs b/src/Numeric/LAPACK/Matrix/Plain/Class.hs --- a/src/Numeric/LAPACK/Matrix/Plain/Class.hs +++ b/src/Numeric/LAPACK/Matrix/Plain/Class.hs @@ -1,108 +1,184 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Plain.Class ( - Admissible(check), - Homogeneous(zero, negate, scaleReal), - ShapeOrder(forceOrder, shapeOrder), adaptOrder, - Additive(add, sub), - Complex(conjugate, fromReal, toComplex), - SquareShape(toSquare, identityOrder, takeDiagonal), + check, + -- for testing + fromList, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular -import qualified Numeric.LAPACK.Matrix.Hermitian.Basic as Hermitian -import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Scalar as Scalar -import Numeric.LAPACK.Matrix.Private (Square) +import Numeric.LAPACK.Matrix.Shape.Omni (Omni) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (RealOf, ComplexOf) import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) import qualified Numeric.Netlib.Class as Class import qualified Type.Data.Num.Unary as Unary +import Type.Base.Proxy (Proxy(Proxy)) import Control.Applicative ((<|>)) import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array, (!)) import qualified Data.Complex as Complex import Data.Functor.Compose (Compose(Compose, getCompose)) +import Data.Tuple.HT (mapPair) import Data.Maybe.HT (toMaybe) +import Data.Bool.HT (implies) -import Prelude hiding (negate) +check :: + (Omni.Plain pack property lower upper meas vert horiz height width ~ shape, + Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> + Array shape a -> Maybe String +check omni = + case omni of + Omni.Full shape -> \arr0 -> + let arr = + Basic.mapHeight Shape.Deferred $ + Basic.mapWidth Shape.Deferred $ + Matrix.fromFull $ Array.reshape shape arr0 + in checkStrips omni arr <|> checkProperty omni arr + Omni.LowerTriangular _ -> checkTriangular (diagTag omni) + Omni.UpperTriangular _ -> checkTriangular (diagTag omni) + Omni.Hermitian _ -> assertReal "Hermitian" . Mosaic.takeDiagonal + Omni.Banded _ -> checkBanded + Omni.UnitBandedTriangular _ -> \arr -> + checkBanded arr <|> + assertOnes "BandedTriangular" (Banded.takeDiagonal arr) + Omni.BandedHermitian _ -> \arr -> + let u = BandedHermitian.takeUpper arr + in checkBanded u <|> + assertReal "BandedHermitian" (Banded.takeDiagonal u) + _ -> const Nothing -class (Shape.C shape) => Admissible shape where - check :: (Class.Floating a) => Array shape a -> Maybe String +fromList :: + (Omni.ToPlain pack property lower upper meas vert horiz height width, + Omni pack property lower upper meas vert horiz height width ~ shape, + Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + shape -> [a] -> Array shape a +fromList omni = + (\arr -> maybe arr error $ check omni $ Array.mapShape Omni.toPlain arr) . + CheckedArray.fromList omni + assert :: msg -> Bool -> Maybe msg assert msg = flip toMaybe msg . not -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Admissible (MatrixShape.Full vert horiz height width) where - check _ = Nothing - -instance (Shape.C size) => Admissible (MatrixShape.Hermitian size) where - check = - assert "Hermitian with non-real diagonal" . - isReal . Triangular.takeDiagonal . Hermitian.takeUpper - -instance - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C size) => - Admissible (MatrixShape.Triangular lo diag up size) where - check = - getCheckDiag $ - MatrixShape.switchTriDiag - (CheckDiag $ const Nothing) - (CheckDiag checkUnitDiagonal) - -newtype CheckDiag lo up sh a b diag = - CheckDiag {getCheckDiag :: Triangular.Triangular lo diag up sh a -> b} +proxyFromBands :: f n -> Proxy n +proxyFromBands _ = Proxy -checkUnitDiagonal :: - (Shape.C size, Class.Floating a, - MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up) => - Triangular.Triangular lo diag up size a -> Maybe String -checkUnitDiagonal = - assert "Triangular.Unit with non-unit diagonal elements" . - all (Scalar.equal Scalar.one) . Vector.toList . Triangular.takeDiagonal +outsideBands :: Omni.StripSingleton offDiag -> Int -> Bool +outsideBands strip = + case strip of + Omni.StripFilled -> const False + Omni.StripBands k -> (> Unary.integralFromProxy (proxyFromBands k)) -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width) => - Admissible (MatrixShape.Banded sub super vert horiz height width) where - check arr0 = - let arr = - Banded.mapHeight Shape.Deferred $ - Banded.mapWidth Shape.Deferred $ - Banded.mapExtent Extent.toGeneral arr0 - in assert "Banded with non-zero unused elements" $ +checkStrips :: + (Omni.Strip lower, Omni.Strip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> + Matrix.General (Shape.Deferred height) (Shape.Deferred width) a -> + Maybe String +checkStrips omni arr = + case mapPair (outsideBands, outsideBands) $ Omni.strips omni of + (outsideLower,outsideUpper) -> + assert "non-zero elements outside of declared bands" $ all (Scalar.isZero . (arr!)) $ filter - (\ix -> case ix of MatrixShape.InsideBox _ _ -> False; _ -> True) $ + (\(Shape.DeferredIndex r, Shape.DeferredIndex c) -> + outsideLower (r-c) || outsideUpper (c-r)) $ Shape.indices $ Array.shape arr -instance - (Unary.Natural off, Shape.C size) => - Admissible (MatrixShape.BandedHermitian off size) where - check arr = - let u = BandedHermitian.takeUpper arr - in check u <|> - (assert "BandedHermitian with non-real diagonal" . - isReal . Banded.takeDiagonal $ u) +checkProperty :: + (Omni.Property property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> + Matrix.General (Shape.Deferred height) (Shape.Deferred width) a -> + Maybe String +checkProperty omni arr = + let shape = Array.shape arr + in case Omni.property omni of + Omni.PropArbitrary -> Nothing + Omni.PropUnit -> + assert "non-unit diagonal in unpacked matrix" $ + all (Scalar.equal Scalar.one . (arr!)) $ + zip + (Shape.indices $ Matrix.height arr) + (Shape.indices $ Matrix.width arr) + Omni.PropSymmetric -> + assert "symmetry violated in unpacked matrix" $ + all + (\ix@(Shape.DeferredIndex r, Shape.DeferredIndex c) -> + let tix = (Shape.DeferredIndex c, Shape.DeferredIndex r) + in Shape.inBounds shape tix `implies` + Scalar.equal (arr!ix) (arr!tix)) $ + Shape.indices shape + Omni.PropHermitian -> + assert "conjugated symmetry violated in unpacked matrix" $ + all + (\ix@(Shape.DeferredIndex r, Shape.DeferredIndex c) -> + let tix = (Shape.DeferredIndex c, Shape.DeferredIndex r) + in Shape.inBounds shape tix `implies` + Scalar.equal (arr!ix) (Scalar.conjugate $ arr!tix)) $ + Shape.indices shape + +diagTag :: + (Omni.TriDiag diag) => + MatrixShape.Triangular lo diag up sh -> Omni.DiagSingleton diag +diagTag _ = Omni.autoDiag + +checkTriangular :: + (Layout.UpLo uplo, Omni.TriDiag diag, + Shape.C size, Class.Floating a) => + Omni.DiagSingleton diag -> + Triangular.Triangular uplo size a -> Maybe String +checkTriangular diag = + case diag of + Omni.Arbitrary -> const Nothing + Omni.Unit -> assertOnes "Triangular" . Mosaic.takeDiagonal + +checkBanded :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Banded.Banded sub super meas vert horiz height width a -> Maybe String +checkBanded arr0 = + let arr = + Banded.mapHeight Shape.Deferred $ + Banded.mapWidth Shape.Deferred $ + Banded.mapExtent ExtentPriv.toGeneral arr0 + in assert "Banded with non-zero unused elements" $ + all (Scalar.isZero . (arr!)) $ + filter + (\ix -> case ix of Layout.InsideBox _ _ -> False; _ -> True) $ + Shape.indices $ Array.shape arr + +assertReal :: + (Shape.C sh, Class.Floating a) => String -> Vector sh a -> Maybe String +assertReal name = assert (name ++ " with non-real diagonal") . isReal + isReal :: (Shape.C sh, Class.Floating a) => Vector sh a -> Bool isReal = getFlip $ getCompose $ @@ -116,186 +192,8 @@ (Shape.C sh, Class.Real a) => Vector sh (Complex.Complex a) -> Bool isComplexReal = all Scalar.isZero . Vector.toList . Vector.imaginaryPart - -class (Shape.C shape) => Complex shape where - conjugate :: - (Class.Floating a) => Array shape a -> Array shape a - conjugate = Vector.conjugate - fromReal :: - (Class.Floating a) => - Array shape (RealOf a) -> Array shape a - fromReal = Vector.fromReal - toComplex :: - (Class.Floating a) => - Array shape a -> Array shape (ComplexOf a) - toComplex = Vector.toComplex - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Complex (MatrixShape.Full vert horiz height width) where - -instance (Shape.C size) => Complex (MatrixShape.Hermitian size) where - -instance - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C size) => - Complex (MatrixShape.Triangular lo diag up size) where - -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width) => - Complex (MatrixShape.Banded sub super vert horiz height width) where - -instance - (Unary.Natural off, Shape.C size) => - Complex (MatrixShape.BandedHermitian off size) where - - -class (Shape.C shape) => Homogeneous shape where - zero :: (Class.Floating a) => shape -> Array shape a - zero = Vector.zero - negate :: (Class.Floating a) => Array shape a -> Array shape a - negate = Vector.negate - scaleReal :: (Class.Floating a) => - RealOf a -> Array shape a -> Array shape a - scaleReal = Vector.scaleReal - - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Homogeneous (MatrixShape.Full vert horiz height width) where - -instance (Shape.C size) => Homogeneous (MatrixShape.Hermitian size) where - -instance - (MatrixShape.Content lo, MatrixShape.NonUnit ~ diag, MatrixShape.Content up, - Shape.C size) => - Homogeneous (MatrixShape.Triangular lo diag up size) where - -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width) => - Homogeneous (MatrixShape.Banded sub super vert horiz height width) where - -instance - (Unary.Natural off, Shape.C size) => - Homogeneous (MatrixShape.BandedHermitian off size) where - - -class (Shape.C shape) => ShapeOrder shape where - forceOrder :: - (Class.Floating a) => - MatrixShape.Order -> Array shape a -> Array shape a - shapeOrder :: shape -> MatrixShape.Order - -{- | -@adaptOrder x y@ contains the data of @y@ with the layout of @x@. --} -adaptOrder :: - (ShapeOrder shape, Class.Floating a) => - Array shape a -> Array shape a -> Array shape a -adaptOrder = forceOrder . shapeOrder . Array.shape - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - ShapeOrder (MatrixShape.Full vert horiz height width) where - forceOrder = Basic.forceOrder - shapeOrder = MatrixShape.fullOrder - -instance (Shape.C size) => ShapeOrder (MatrixShape.Hermitian size) where - forceOrder = Hermitian.forceOrder - shapeOrder = MatrixShape.hermitianOrder - -instance - (MatrixShape.Content lo, - MatrixShape.TriDiag diag, - MatrixShape.Content up, Shape.C size) => - ShapeOrder (MatrixShape.Triangular lo diag up size) where - forceOrder = Triangular.forceOrder - shapeOrder = MatrixShape.triangularOrder - - -class (Homogeneous shape, Eq shape) => Additive shape where - add, sub :: - (Class.Floating a) => - Array shape a -> Array shape a -> Array shape a - sub a = add a . negate - -instance - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width) => - Additive (MatrixShape.Full vert horiz height width) where - add = addGen - sub = subGen - -instance (Shape.C size, Eq size) => Additive (MatrixShape.Hermitian size) where - add = addGen - sub = subGen - -instance - (MatrixShape.Content lo, Eq lo, - MatrixShape.NonUnit ~ diag, - MatrixShape.Content up, Eq up, - Shape.C size, Eq size) => - Additive (MatrixShape.Triangular lo diag up size) where - add = addGen - sub = subGen - -addGen, subGen :: - (ShapeOrder shape, Eq shape, Class.Floating a) => - Array shape a -> Array shape a -> Array shape a -addGen a b = Vector.add (adaptOrder b a) b -subGen a b = Vector.sub (adaptOrder b a) b - - -class - (Box.Box shape, Box.HeightOf shape ~ Box.WidthOf shape) => - SquareShape shape where - toSquare :: - (Box.HeightOf shape ~ sh, Class.Floating a) => - Array shape a -> Square sh a - identityOrder :: - (Box.HeightOf shape ~ sh, Class.Floating a) => - MatrixShape.Order -> sh -> Array shape a - takeDiagonal :: - (Box.HeightOf shape ~ sh, Class.Floating a) => - Array shape a -> Vector sh a - -instance - (Extent.Small ~ vert, Extent.Small ~ horiz, - Shape.C height, height ~ width) => - SquareShape (MatrixShape.Full vert horiz height width) where - toSquare = id - identityOrder = Square.identityOrder - takeDiagonal = Square.takeDiagonal - -instance (Shape.C size) => SquareShape (MatrixShape.Hermitian size) where - toSquare = Hermitian.toSquare - identityOrder = Hermitian.identity - takeDiagonal = Vector.fromReal . Hermitian.takeDiagonal - -instance - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C size) => - SquareShape (MatrixShape.Triangular lo diag up size) where - toSquare = Triangular.toSquare - identityOrder order = - Triangular.relaxUnitDiagonal . Triangular.identity order - takeDiagonal = Triangular.takeDiagonal - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.Small ~ vert, Extent.Small ~ horiz, - Shape.C height, height ~ width) => - SquareShape - (MatrixShape.Banded sub super vert horiz height width) where - toSquare = Banded.toFull - identityOrder = Banded.identityFatOrder - takeDiagonal = Banded.takeDiagonal - -instance - (Unary.Natural offDiag, Shape.C size) => - SquareShape (MatrixShape.BandedHermitian offDiag size) where - toSquare = Banded.toFull . BandedHermitian.toBanded - identityOrder = BandedHermitian.identityFatOrder - takeDiagonal = Vector.fromReal . BandedHermitian.takeDiagonal +assertOnes :: + (Shape.C sh, Class.Floating a) => String -> Vector sh a -> Maybe String +assertOnes name = + assert (name ++ ".Unit with non-unit diagonal elements") . + all (Scalar.equal Scalar.one) . Vector.toList diff --git a/src/Numeric/LAPACK/Matrix/Plain/Divide.hs b/src/Numeric/LAPACK/Matrix/Plain/Divide.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Plain/Divide.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE UndecidableInstances #-} -module Numeric.LAPACK.Matrix.Plain.Divide where - -import qualified Numeric.LAPACK.Matrix.Plain.Multiply as Multiply - -import qualified Numeric.LAPACK.Matrix.Square.Linear - as Square -import qualified Numeric.LAPACK.Matrix.Square.Basic - as Square -import qualified Numeric.LAPACK.Matrix.Triangular.Linear - as Triangular -import qualified Numeric.LAPACK.Matrix.Triangular.Basic - as Triangular -import qualified Numeric.LAPACK.Matrix.Hermitian.Linear - as Hermitian -import qualified Numeric.LAPACK.Matrix.Banded.Linear - as Banded -import qualified Numeric.LAPACK.Matrix.Banded.Basic - as Banded -import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite.Linear - as BandedHermitianPositiveDefinite - -import qualified Numeric.LAPACK.Matrix.Plain.Class as Plain -import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Vector as Vector -import qualified Numeric.LAPACK.Scalar as Scalar -import Numeric.LAPACK.Matrix.Extent.Private (Small) -import Numeric.LAPACK.Matrix.Basic (swapMultiply) -import Numeric.LAPACK.Matrix.Modifier (Transposition(Transposed, NonTransposed)) -import Numeric.LAPACK.Matrix.Private (Full) -import Numeric.LAPACK.Vector (Vector) - -import qualified Numeric.Netlib.Class as Class - -import qualified Type.Data.Num.Unary as Unary - -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable (Array) - - -class (Plain.SquareShape shape) => Determinant shape where - determinant :: (Class.Floating a) => Array shape a -> a - -class (Plain.SquareShape shape) => Solve shape where - {-# MINIMAL solve | solveLeft,solveRight #-} - solve :: - (Class.Floating a, Box.HeightOf shape ~ height, Eq height, - Extent.C vert, Extent.C horiz, Shape.C width) => - Transposition -> Array shape a -> - Full vert horiz height width a -> Full vert horiz height width a - solve NonTransposed a b = solveRight a b - solve Transposed a b = Basic.transpose $ solveLeft (Basic.transpose b) a - - solveRight :: - (Class.Floating a, Box.HeightOf shape ~ height, Eq height, - Extent.C vert, Extent.C horiz, Shape.C width) => - Array shape a -> - Full vert horiz height width a -> Full vert horiz height width a - solveRight = solve NonTransposed - - solveLeft :: - (Class.Floating a, Box.HeightOf shape ~ width, Eq width, - Extent.C vert, Extent.C horiz, Shape.C height) => - Full vert horiz height width a -> - Array shape a -> - Full vert horiz height width a - solveLeft = swapMultiply $ solve Transposed - -class (Solve shape, Multiply.Power shape) => Inverse shape where - inverse :: (Class.Floating a) => Array shape a -> Array shape a - -solveVector :: - (Solve shape, Box.HeightOf shape ~ height, Eq height, Class.Floating a) => - Transposition -> Array shape a -> Vector height a -> Vector height a -solveVector trans = Basic.unliftColumn MatrixShape.ColumnMajor . solve trans - - -instance - (vert ~ Small, horiz ~ Small, Shape.C height, height ~ width) => - Determinant (MatrixShape.Full vert horiz height width) where - determinant = Square.determinant - -instance - (vert ~ Small, horiz ~ Small, Shape.C height, height ~ width) => - Solve (MatrixShape.Full vert horiz height width) where - solveRight = Square.solve - solveLeft = swapMultiply $ Square.solve . Square.transpose - -instance - (vert ~ Small, horiz ~ Small, Shape.C height, height ~ width) => - Inverse (MatrixShape.Full vert horiz height width) where - inverse = Square.inverse - - -instance (Shape.C shape) => Determinant (MatrixShape.Hermitian shape) where - determinant = Scalar.fromReal . Hermitian.determinant - -instance (Shape.C shape) => Solve (MatrixShape.Hermitian shape) where - solveRight = Hermitian.solve - solveLeft = swapMultiply $ Hermitian.solve . Vector.conjugate - -instance (Shape.C shape) => Inverse (MatrixShape.Hermitian shape) where - inverse = Hermitian.inverse - - -instance - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C shape) => - Determinant (MatrixShape.Triangular lo diag up shape) where - determinant = Triangular.determinant - -instance - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C shape) => - Solve (MatrixShape.Triangular lo diag up shape) where - solveRight = Triangular.solve - solveLeft = swapMultiply $ Triangular.solve . Triangular.transpose - -instance - (Triangular.PowerContentDiag lo diag up, Shape.C shape) => - Inverse (MatrixShape.Triangular lo diag up shape) where - inverse = Triangular.inverse - - -instance - (Unary.Natural sub, Unary.Natural super, vert ~ Small, horiz ~ Small, - Shape.C width, Shape.C height, width ~ height) => - Determinant (MatrixShape.Banded sub super vert horiz height width) where - determinant = Banded.determinant - -instance - (Unary.Natural sub, Unary.Natural super, vert ~ Small, horiz ~ Small, - Shape.C width, Shape.C height, width ~ height) => - Solve (MatrixShape.Banded sub super vert horiz height width) where - solveRight = Banded.solve - solveLeft = swapMultiply $ Banded.solve . Banded.transpose - - -{- | -There is no solver for general banded Hermitian matrices. -Thus the instance will fail for an indefinite matrix. --} -instance - (Unary.Natural offDiag, Shape.C size) => - Determinant (MatrixShape.BandedHermitian offDiag size) where - determinant = Scalar.fromReal . BandedHermitianPositiveDefinite.determinant - -{- | -There is no solver for indefinite matrices. -Thus the instance will fail for indefinite but solvable systems. --} -instance - (Unary.Natural offDiag, Shape.C size) => - Solve (MatrixShape.BandedHermitian offDiag size) where - solveRight = BandedHermitianPositiveDefinite.solve - solveLeft = - swapMultiply $ BandedHermitianPositiveDefinite.solve . Vector.conjugate diff --git a/src/Numeric/LAPACK/Matrix/Plain/Format.hs b/src/Numeric/LAPACK/Matrix/Plain/Format.hs --- a/src/Numeric/LAPACK/Matrix/Plain/Format.hs +++ b/src/Numeric/LAPACK/Matrix/Plain/Format.hs @@ -1,15 +1,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleInstances #-} module Numeric.LAPACK.Matrix.Plain.Format where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Output as Output import Numeric.LAPACK.Output (Output, formatRow, (<+>)) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor, ColumnMajor), Filled(Filled), UnaryProxy) +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor, ColumnMajor), UnaryProxy) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Scalar (conjugate) import Numeric.LAPACK.Private (caseRealComplexFunc) @@ -24,7 +25,7 @@ import qualified Data.Array.Comfort.Boxed as BoxedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable (Array) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Text.Printf (PrintfArg, printf) @@ -67,7 +68,7 @@ formatArray fmt = formatArray fmt . Array.mapShape (\(Shape.Deferred sh) -> sh) -instance (FormatArray sh0, FormatArray sh1) => FormatArray (sh0:+:sh1) where +instance (FormatArray sh0, FormatArray sh1) => FormatArray (sh0::+sh1) where formatArray fmt v = formatArray fmt (Vector.takeLeft v) <+> @@ -79,51 +80,53 @@ formatRow . map (Output.text . fold . printfFloating fmt) . Array.toList instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - FormatArray (MatrixShape.Full vert horiz height width) where + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + FormatArray (Layout.Full meas vert horiz height width) where formatArray = formatFull formatFull :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Output out, Class.Floating a) => - String -> Full vert horiz height width a -> out + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Output out, Class.Floating a) => + String -> Full meas vert horiz height width a -> out formatFull fmt m = - let MatrixShape.Full order extent = Array.shape m + let Layout.Full order extent = Array.shape m in formatAligned (printfFloating fmt) $ splitRows order (Extent.dimensions extent) $ Array.toList m instance - (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - FormatArray (MatrixShape.Split lower vert horiz height width) where + (Eq lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + FormatArray (Layout.Split lower meas vert horiz height width) where formatArray = formatHouseholder formatHouseholder :: - (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a, Output out) => - String -> Array (MatrixShape.Split lower vert horiz height width) a -> out + (Eq lower, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a, Output out) => + String -> Array (Layout.Split lower meas vert horiz height width) a -> out formatHouseholder fmt m = - let MatrixShape.Split _ order extent = Array.shape m + let Layout.Split _ order extent = Array.shape m in formatSeparateTriangle (printfFloating fmt) $ splitRows order (Extent.dimensions extent) $ Array.toList m -instance (Shape.C size) => FormatArray (MatrixShape.Hermitian size) where - formatArray = formatHermitian +instance (Shape.C size) => FormatArray (Layout.Hermitian size) where + formatArray = formatMirrored conjugate -formatHermitian :: - (Shape.C size, Class.Floating a, Output out) => - String -> Array (MatrixShape.Hermitian size) a -> out -formatHermitian fmt m = - let MatrixShape.Hermitian order size = Array.shape m - in formatSeparateTriangle (printfFloating fmt) $ - complementTriangle conjugate order (Shape.size size) $ Array.toList m +instance (Shape.C size) => FormatArray (Layout.Symmetric size) where + formatArray = formatMirrored id -formatSymmetric :: +formatMirrored :: (Shape.C size, Class.Floating a, Output out) => - String -> Array (MatrixShape.Symmetric size) a -> out -formatSymmetric fmt m = - let MatrixShape.Triangular _diag (Filled, Filled) order size = Array.shape m + (a -> a) -> + String -> + Array (Layout.Mosaic Layout.Packed mirror Shape.Upper size) a -> + out +formatMirrored adapt fmt m = + let Layout.Mosaic Layout.Packed _mirror Layout.Upper + order size + = Array.shape m in formatSeparateTriangle (printfFloating fmt) $ - complementTriangle id order (Shape.size size) $ Array.toList m + complementTriangle adapt order (Shape.size size) $ Array.toList m complementTriangle :: (Class.Floating a) => (a -> a) -> Order -> Int -> [a] -> [[a]] @@ -139,21 +142,6 @@ let tri = slice (take n [1..]) xs in mergeTriangles tri (transpose tri) -instance - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C size) => - FormatArray (MatrixShape.Triangular lo diag up size) where - formatArray fmt = - getFormatTriangular $ - MatrixShape.switchDiagUpLoSym - (FormatTriangular $ \m -> - let MatrixShape.Triangular _diag _uplo order size = Array.shape m - in formatDiagonal fmt order size $ Array.toList m) - (FormatTriangular $ formatTriangular fmt) - (FormatTriangular $ formatTriangular fmt) - (FormatTriangular $ - formatSymmetric fmt . - Array.mapShape MatrixShape.strictNonUnitDiagonal) formatDiagonal :: (Shape.C size, Class.Floating a, Output out) => @@ -164,23 +152,28 @@ padBanded (n0,n0) order (size,size) xs -newtype FormatTriangular diag size a b lo up = - FormatTriangular { - getFormatTriangular :: - Array (MatrixShape.Triangular lo diag up size) a -> b - } +instance + (Layout.UpLo uplo, Shape.C size) => + FormatArray (Layout.Triangular uplo size) where + formatArray = formatTriangular formatTriangular :: - (MatrixShape.TriDiag diag, MatrixShape.UpLo lo up, - Shape.C size, Class.Floating a, Output out) => - String -> Array (MatrixShape.Triangular lo diag up size) a -> out + (Layout.UpLo uplo, Shape.C size, Class.Floating a, Output out) => + String -> Array (Layout.Triangular uplo size) a -> out formatTriangular fmt m = - let MatrixShape.Triangular _diag uplo order size = Array.shape m - in formatAligned (printfFloatingMaybe fmt) $ - MatrixShape.caseLoUp uplo - padLowerTriangle padUpperTriangle order (Shape.size size) $ - Array.toList m + let Layout.Mosaic Layout.Packed Layout.NoMirror + uplo order size + = Array.shape m + in formatAligned (printfFloatingMaybe fmt) $ + padTriangle uplo order (Shape.size size) $ Array.toList m +padTriangle :: + Layout.UpLoSingleton uplo -> Order -> Int -> [a] -> [[Maybe a]] +padTriangle uplo = + case uplo of + Layout.Lower -> padLowerTriangle + Layout.Upper -> padUpperTriangle + padUpperTriangle :: Order -> Int -> [a] -> [[Maybe a]] padUpperTriangle order n xs = let mxs = map Just xs @@ -210,10 +203,11 @@ instance (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - FormatArray (MatrixShape.Banded sub super vert horiz height width) where + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + FormatArray (Layout.Banded sub super meas vert horiz height width) where formatArray fmt m = - let MatrixShape.Banded offDiag order extent = Array.shape m + let Layout.Banded offDiag order extent = Array.shape m in formatAligned (printfFloatingMaybe fmt) $ padBanded offDiag order (Extent.dimensions extent) $ Array.toList m @@ -224,7 +218,7 @@ (height, width) -> [a] -> [[Maybe a]] padBanded (sub,super) order (height,width) xs = let slices = - ListHT.sliceVertical (MatrixShape.bandedBreadth (sub,super)) xs + ListHT.sliceVertical (Layout.bandedBreadth (sub,super)) xs m = Shape.size height n = Shape.size width in case order of @@ -245,9 +239,9 @@ instance (Unary.Natural offDiag, Shape.C size) => - FormatArray (MatrixShape.BandedHermitian offDiag size) where + FormatArray (Layout.BandedHermitian offDiag size) where formatArray fmt m = - let MatrixShape.BandedHermitian offDiag order size = Array.shape m + let Layout.BandedHermitian offDiag order size = Array.shape m in formatSeparateTriangle (printfFloatingMaybe fmt) $ padBandedHermitian offDiag order size $ Array.toList m diff --git a/src/Numeric/LAPACK/Matrix/Plain/Indexed.hs b/src/Numeric/LAPACK/Matrix/Plain/Indexed.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Plain/Indexed.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Matrix.Plain.Indexed where - -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Scalar (conjugate, zero) - -import qualified Numeric.Netlib.Class as Class - -import qualified Type.Data.Num.Unary as Unary - -import qualified Data.Array.Comfort.Storable.Unchecked as UArray -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable (Array, (!)) - -import Data.Tuple.HT (swap) -import Data.Bool.HT (if') - - -infixl 9 #! - -class (Box.Box sh) => Indexed sh where - (#!) :: - (Class.Floating a) => - Array sh a -> - (Shape.Index (Box.HeightOf sh), Shape.Index (Box.WidthOf sh)) -> a - -instance - (Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => - Indexed (MatrixShape.Full vert horiz height width) where - (#!) = (!) - -instance (Shape.Indexed size) => Indexed (MatrixShape.Hermitian size) where - arr#!ij = - if Shape.inBounds (UArray.shape arr) ij - then arr UArray.! ij - else conjugate $ arr ! swap ij - -instance - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.Indexed size) => - Indexed (MatrixShape.Triangular lo diag up size) where - arr#!ij = - let sh = UArray.shape arr - in if Shape.inBounds sh ij - then arr UArray.! ij - else - MatrixShape.caseDiagUpLoSym (MatrixShape.triangularUplo sh) - (checkedZero "Diagonal" sh ij) - (checkedZero "UpperTriangular" sh ij) - (checkedZero "LowerTriangular" sh ij) - (arr ! swap ij) - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => - Indexed (MatrixShape.Banded sub super vert horiz height width) where - arr#!ij = - let boxIx = uncurry MatrixShape.InsideBox - sh = UArray.shape arr - in if Shape.inBounds sh $ boxIx ij - then arr UArray.! boxIx ij - else checkedZero "Banded" sh ij - -instance - (Unary.Natural off, Shape.Indexed size) => - Indexed (MatrixShape.BandedHermitian off size) where - arr#!ij = - let boxIx = uncurry MatrixShape.InsideBox - sh = UArray.shape arr - in if' (Shape.inBounds sh $ boxIx ij) - (arr UArray.! boxIx ij) $ - if' (Shape.inBounds sh $ boxIx $ swap ij) - (conjugate $ arr UArray.! boxIx (swap ij)) - (checkedZero "BandedHermitian" sh ij) - -checkedZero :: - (Box.Box shape, Class.Floating a, - Box.HeightOf shape ~ height, Shape.Indexed height, - Box.WidthOf shape ~ width, Shape.Indexed width) => - String -> shape -> (Shape.Index height, Shape.Index width) -> a -checkedZero name sh ij = - if Shape.inBounds (Box.height sh, Box.width sh) ij - then zero - else error $ "Matrix.Indexed." ++ name ++ ": index out of range" diff --git a/src/Numeric/LAPACK/Matrix/Plain/Multiply.hs b/src/Numeric/LAPACK/Matrix/Plain/Multiply.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Plain/Multiply.hs +++ /dev/null @@ -1,608 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE UndecidableInstances #-} -module Numeric.LAPACK.Matrix.Plain.Multiply where - -import qualified Numeric.LAPACK.Matrix.Plain.Class as Plain -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv -import qualified Numeric.LAPACK.Matrix.Extent as Extent -import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian -import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded -import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular -import qualified Numeric.LAPACK.Matrix.Hermitian.Basic as Hermitian -import qualified Numeric.LAPACK.Matrix.Square.Basic as Square -import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Shape.Private (Empty, Filled, Unit, NonUnit) -import Numeric.LAPACK.Matrix.Extent.Private (Small) -import Numeric.LAPACK.Matrix.Triangular.Basic (Triangular) -import Numeric.LAPACK.Matrix.Basic (swapMultiply, transpose) -import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed, Transposed)) -import Numeric.LAPACK.Matrix.Private (Square, Full, mapExtent) -import Numeric.LAPACK.Vector (Vector) - -import qualified Numeric.Netlib.Class as Class - -import qualified Type.Data.Num.Unary as Unary -import Type.Data.Num.Unary ((:+:)) - -import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Unchecked (Array) - - - -class (Box.Box shape) => Scale shape where - scale :: (Class.Floating a) => a -> Array shape a -> Array shape a - scale = Vector.scale - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Scale (MatrixShape.Full vert horiz height width) where - -instance - (MatrixShape.Content lo, MatrixShape.Content up, - diag ~ NonUnit, Shape.C size) => - Scale (MatrixShape.Triangular lo diag up size) where - -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width) => - Scale (MatrixShape.Banded sub super vert horiz height width) where - - -class (Box.Box shape) => MultiplyVector shape where - matrixVector :: - (Box.WidthOf shape ~ width, Eq width, Class.Floating a) => - Array shape a -> Vector width a -> Vector (Box.HeightOf shape) a - vectorMatrix :: - (Box.HeightOf shape ~ height, Eq height, Class.Floating a) => - Vector height a -> Array shape a -> Vector (Box.WidthOf shape) a - - -instance - (Extent.C vert, Extent.C horiz, Shape.C width, Shape.C height) => - MultiplyVector (MatrixShape.Full vert horiz height width) where - matrixVector = Basic.multiplyVector - vectorMatrix v m = Basic.multiplyVector (transpose m) v - - -instance (Shape.C shape) => MultiplyVector (MatrixShape.Hermitian shape) where - matrixVector = Hermitian.multiplyVector NonTransposed - vectorMatrix = flip $ Hermitian.multiplyVector Transposed - - -instance - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C shape) => - MultiplyVector (MatrixShape.Triangular lo diag up shape) where - matrixVector m v = Triangular.multiplyVector m v - vectorMatrix v m = Triangular.multiplyVector (Triangular.transpose m) v - - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - MultiplyVector (MatrixShape.Banded sub super vert horiz height width) where - matrixVector m v = Banded.multiplyVector m v - vectorMatrix v m = Banded.multiplyVector (Banded.transpose m) v - - -instance - (Unary.Natural offDiag, Shape.C size) => - MultiplyVector (MatrixShape.BandedHermitian offDiag size) where - matrixVector = BandedHermitian.multiplyVector NonTransposed - vectorMatrix = flip $ BandedHermitian.multiplyVector Transposed - - - -class (Plain.SquareShape shape) => MultiplySquare shape where - {-# MINIMAL transposableSquare | fullSquare,squareFull #-} - transposableSquare :: - (Box.HeightOf shape ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Transposition -> Array shape a -> - Full vert horiz height width a -> Full vert horiz height width a - transposableSquare NonTransposed a b = squareFull a b - transposableSquare Transposed a b = transpose $ fullSquare (transpose b) a - - squareFull :: - (Box.HeightOf shape ~ height, Eq height, Shape.C width, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Array shape a -> - Full vert horiz height width a -> Full vert horiz height width a - squareFull = transposableSquare NonTransposed - - fullSquare :: - (Box.WidthOf shape ~ width, Eq width, Shape.C height, - Extent.C vert, Extent.C horiz, Class.Floating a) => - Full vert horiz height width a -> - Array shape a -> Full vert horiz height width a - fullSquare = swapMultiply $ transposableSquare Transposed - -instance - (vert ~ Small, horiz ~ Small, Shape.C height, height ~ width) => - MultiplySquare (MatrixShape.Full vert horiz height width) where - transposableSquare NonTransposed = squareFull - transposableSquare Transposed = squareFull . transpose - squareFull a b = Basic.multiply (mapExtent Extent.fromSquare a) b - -instance (Shape.C shape) => MultiplySquare (MatrixShape.Hermitian shape) where - transposableSquare = Hermitian.multiplyFull - -instance - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C shape) => - MultiplySquare (MatrixShape.Triangular lo diag up shape) where - squareFull = Triangular.multiplyFull - fullSquare = - swapMultiply $ Triangular.multiplyFull . Triangular.transpose - -instance - (Unary.Natural sub, Unary.Natural super, - vert ~ Small, horiz ~ Small, Shape.C height, height ~ width) => - MultiplySquare - (MatrixShape.Banded sub super vert horiz height width) where - squareFull = Banded.multiplyFull . bandedGenSquare - fullSquare = - swapMultiply $ Banded.multiplyFull . bandedGenSquare . Banded.transpose - -bandedGenSquare :: - (Extent.C vert, Extent.C horiz) => - Banded.Square sub super size a -> - Banded.Banded sub super vert horiz size size a -bandedGenSquare = Banded.mapExtent Extent.fromSquare - -instance - (Unary.Natural offDiag, Shape.C size) => - MultiplySquare (MatrixShape.BandedHermitian offDiag size) where - transposableSquare = BandedHermitian.multiplyFull - - -class (Plain.SquareShape shape) => Power shape where - square :: (Class.Floating a) => Array shape a -> Array shape a - power :: (Class.Floating a) => Int -> Array shape a -> Array shape a - -instance - (Extent.Small ~ vert, Extent.Small ~ horiz, - Shape.C height, height ~ width) => - Power (MatrixShape.Full vert horiz height width) where - square = Square.square - power = Square.power . fromIntegral - -instance (Shape.C size) => Power (MatrixShape.Hermitian size) where - square = Hermitian.square - power = Hermitian.power . fromIntegral - -instance - (Triangular.PowerContentDiag lo diag up, Shape.C size) => - Power (MatrixShape.Triangular lo diag up size) where - square = Triangular.square - power = Triangular.power - - -class (Box.Box shape) => MultiplySame shape where - same :: - (Class.Floating a) => Array shape a -> Array shape a -> Array shape a - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Eq height, height ~ width) => - MultiplySame (MatrixShape.Full vert horiz height width) where - same = Basic.multiply - -instance - (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, - Shape.C size, Eq size) => - MultiplySame (MatrixShape.Triangular lo diag up size) where - same = Triangular.multiply - - -{- | -This class allows to Basic.multiply two matrices of arbitrary special features -and returns the most special matrix type possible. -At the first glance, this is handy. -At the second glance, this has some problems. -First of all, we may refine the types in future -and then multiplication may return a different, more special type than before. -Second, if you write code with polymorphic matrix types, -then 'matrixMatrix' may leave you with constraints like -@ExtentPriv.Multiply vert vert ~ vert@. -That constraint is always fulfilled but the compiler cannot infer that. -Because of these problems -you may instead consider using specialised 'Basic.multiply' functions -from the various modules for production use. -Btw. 'MultiplyVector' and 'MultiplySquare' -are much less problematic, -because the input and output are always dense vectors or dense matrices. --} -class (Shape.C shapeA, Shape.C shapeB) => Multiply shapeA shapeB where - type Multiplied shapeA shapeB - matrixMatrix :: - (Class.Floating a) => - Array shapeA a -> Array shapeB a -> Array (Multiplied shapeA shapeB) a - -instance - (Shape.C heightA, Shape.C widthA, Shape.C widthB, - widthA ~ heightB, Eq heightB, - Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB) => - Multiply - (MatrixShape.Full vertA horizA heightA widthA) - (MatrixShape.Full vertB horizB heightB widthB) where - type Multiplied - (MatrixShape.Full vertA horizA heightA widthA) - (MatrixShape.Full vertB horizB heightB widthB) = - MatrixShape.Full - (ExtentPriv.Multiply vertA vertB) - (ExtentPriv.Multiply horizA horizB) - heightA widthB - matrixMatrix a b = - case unifyFactors (fullExtent a) (fullExtent b) of - ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> - Basic.multiply - (mapExtent unifyLeft a) - (mapExtent unifyRight b) - -fullExtent :: - Full vert horiz height width a -> - Extent.Extent vert horiz height width -fullExtent = MatrixShape.fullExtent . Array.shape - -unifyFactors :: - (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB) => - (ExtentPriv.Multiply vertA vertB ~ vertC) => - (ExtentPriv.Multiply horizA horizB ~ horizC) => - Extent.Extent vertA horizA height fuse -> - Extent.Extent vertB horizB fuse width -> - ((ExtentPriv.TagFact vertC, ExtentPriv.TagFact horizC), - (Extent.Map vertA horizA vertC horizC height fuse, - Extent.Map vertB horizB vertC horizC fuse width)) -unifyFactors a b = - ((ExtentPriv.multiplyTagLaw - (ExtentPriv.heightFact a) (ExtentPriv.heightFact b), - ExtentPriv.multiplyTagLaw - (ExtentPriv.widthFact a) (ExtentPriv.widthFact b)), - (ExtentPriv.Map $ flip ExtentPriv.unifyLeft b, - ExtentPriv.Map $ ExtentPriv.unifyRight a)) - - -instance - (Extent.C vert, Extent.C horiz, - Shape.C size, size ~ width, Eq width, Shape.C height) => - Multiply - (MatrixShape.Full vert horiz height width) - (MatrixShape.Hermitian size) - where - type Multiplied - (MatrixShape.Full vert horiz height width) - (MatrixShape.Hermitian size) = - MatrixShape.Full vert horiz height width - matrixMatrix = fullSquare - -instance - (Extent.C vert, Extent.C horiz, - Shape.C size, size ~ height, Eq height, Shape.C width) => - Multiply - (MatrixShape.Hermitian size) - (MatrixShape.Full vert horiz height width) - where - type Multiplied - (MatrixShape.Hermitian size) - (MatrixShape.Full vert horiz height width) = - MatrixShape.Full vert horiz height width - matrixMatrix = squareFull - -instance - (Shape.C shapeA, shapeA ~ shapeB, Eq shapeB) => - Multiply (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) - where - type Multiplied - (MatrixShape.Hermitian shapeA) (MatrixShape.Hermitian shapeB) = - MatrixShape.Square shapeA - matrixMatrix a = squareFull a . Hermitian.toSquare - - -instance - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, - Shape.C size, size ~ width, Eq width, Shape.C height) => - Multiply - (MatrixShape.Full vert horiz height width) - (MatrixShape.Triangular lo diag up size) - where - type Multiplied - (MatrixShape.Full vert horiz height width) - (MatrixShape.Triangular lo diag up size) = - MatrixShape.Full vert horiz height width - matrixMatrix = fullSquare - -instance - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, - Shape.C size, size ~ height, Eq height, Shape.C width) => - Multiply - (MatrixShape.Triangular lo diag up size) - (MatrixShape.Full vert horiz height width) - where - type Multiplied - (MatrixShape.Triangular lo diag up size) - (MatrixShape.Full vert horiz height width) = - MatrixShape.Full vert horiz height width - matrixMatrix = squareFull - -instance - (Shape.C sizeA, sizeA ~ sizeB, Eq sizeB, - MultiplyTriangular loA upA loB upB, - MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => - Multiply - (MatrixShape.Triangular loA diagA upA sizeA) - (MatrixShape.Triangular loB diagB upB sizeB) where - type Multiplied - (MatrixShape.Triangular loA diagA upA sizeA) - (MatrixShape.Triangular loB diagB upB sizeB) = - -- requires UndecidableInstances - MultipliedTriangular loA diagA upA loB diagB upB sizeB - matrixMatrix = triangularTriangular - -class - (MatrixShape.Content loA, MatrixShape.Content upA, - MatrixShape.Content loB, MatrixShape.Content upB) => - MultiplyTriangular loA upA loB upB where - triangularTriangular :: - (Class.Floating a, Shape.C size, Eq size, - MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => - Triangular loA diagA upA size a -> - Triangular loB diagB upB size a -> - Array (MultipliedTriangular loA diagA upA loB diagB upB size) a - - -type MultipliedTriangular loA diagA upA loB diagB upB size = - ComposedTriangular - (MultipliedPart loA loB) - (MultipliedDiag diagA diagB) - (MultipliedPart upA upB) - size - -type family MultipliedPart a b :: * -type instance MultipliedPart Empty b = b -type instance MultipliedPart Filled b = Filled - -type family MultipliedDiag a b :: * -type instance MultipliedDiag Unit b = b -type instance MultipliedDiag NonUnit b = NonUnit - -type family ComposedTriangular lo diag up size :: * -type instance ComposedTriangular Empty diag up size = - MatrixShape.Triangular Empty diag up size -type instance ComposedTriangular Filled diag Empty size = - MatrixShape.LowerTriangular diag size -type instance ComposedTriangular Filled diag Filled size = - MatrixShape.Square size - - -instance MultiplyTriangular Empty Empty Empty Empty where - triangularTriangular = triangularTriangularConform - -instance MultiplyTriangular Empty Empty Filled Filled where - triangularTriangular a = Triangular.multiplyFull a . Triangular.toSquare - -instance MultiplyTriangular Empty Filled Filled Filled where - triangularTriangular a = Triangular.multiplyFull a . Triangular.toSquare - -instance MultiplyTriangular Filled Empty Filled Filled where - triangularTriangular a = Triangular.multiplyFull a . Triangular.toSquare - -instance MultiplyTriangular Empty Filled Empty Filled where - triangularTriangular = triangularTriangularConform - -instance MultiplyTriangular Filled Empty Filled Empty where - triangularTriangular = triangularTriangularConform - -instance MultiplyTriangular Filled Empty Empty Filled where - triangularTriangular a = Triangular.multiplyFull a . Triangular.toSquare - -instance MultiplyTriangular Empty Filled Filled Empty where - triangularTriangular a = Triangular.multiplyFull a . Triangular.toSquare - -instance MultiplyTriangular Filled Filled Empty Empty where - triangularTriangular = triangularTriangularToSquare - -instance MultiplyTriangular Filled Filled Empty Filled where - triangularTriangular = triangularTriangularToSquare - -instance MultiplyTriangular Filled Filled Filled Empty where - triangularTriangular = triangularTriangularToSquare - -instance MultiplyTriangular Filled Filled Filled Filled where - triangularTriangular = triangularTriangularToSquare - -triangularTriangularToSquare :: - (MatrixShape.Content loA, MatrixShape.Content upA, MatrixShape.TriDiag diagA, - MatrixShape.Content loB, MatrixShape.Content upB, MatrixShape.TriDiag diagB, - Shape.C size, Eq size, Class.Floating a) => - Triangular loA diagA upA size a -> - Triangular loB diagB upB size a -> - Square size a -triangularTriangularToSquare = fullSquare . Triangular.toSquare - - -newtype TriangularTriangularConform lo up size a diagB diagA = - TriangularTriangularConform { - getTriangularTriangularConform :: - Triangular lo diagA up size a -> - Triangular lo diagB up size a -> - Triangular lo (MultipliedDiag diagA diagB) up size a - } - -triangularTriangularConform :: - (Shape.C size, Eq size, Class.Floating a, - MatrixShape.DiagUpLo lo up, - MatrixShape.TriDiag diagA, MatrixShape.TriDiag diagB) => - (MultipliedDiag diagA diagB ~ diagC) => - Triangular lo diagA up size a -> - Triangular lo diagB up size a -> - Triangular lo diagC up size a -triangularTriangularConform = - getTriangularTriangularConform $ - MatrixShape.switchTriDiag - (TriangularTriangularConform $ \a b -> - Triangular.multiply (Triangular.relaxUnitDiagonal a) b) - (TriangularTriangularConform $ \a b -> - Triangular.multiply a (Triangular.strictNonUnitDiagonal b)) - - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vertA, Extent.C horizA, - Extent.C vertB, Extent.C horizB, - Shape.C heightA, Shape.C widthA, Shape.C widthB, - widthA ~ heightB, Eq heightB) => - Multiply - (MatrixShape.Full vertA horizA heightA widthA) - (MatrixShape.Banded sub super vertB horizB heightB widthB) - where - type Multiplied - (MatrixShape.Full vertA horizA heightA widthA) - (MatrixShape.Banded sub super vertB horizB heightB widthB) = - MatrixShape.Full - (ExtentPriv.Multiply vertA vertB) - (ExtentPriv.Multiply horizA horizB) - heightA widthB - matrixMatrix a b = - case unifyFactors (fullExtent a) (bandedExtent b) of - ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> - swapMultiply (Banded.multiplyFull . Banded.transpose) - (mapExtent unifyLeft a) - (Banded.mapExtent unifyRight b) - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vertA, Extent.C horizA, - Extent.C vertB, Extent.C horizB, - Shape.C heightA, Shape.C widthA, Shape.C widthB, - widthA ~ heightB, Eq heightB) => - Multiply - (MatrixShape.Banded sub super vertA horizA heightA widthA) - (MatrixShape.Full vertB horizB heightB widthB) - where - type Multiplied - (MatrixShape.Banded sub super vertA horizA heightA widthA) - (MatrixShape.Full vertB horizB heightB widthB) = - MatrixShape.Full - (ExtentPriv.Multiply vertA vertB) - (ExtentPriv.Multiply horizA horizB) - heightA widthB - matrixMatrix a b = - case unifyFactors (bandedExtent a) (fullExtent b) of - ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> - Banded.multiplyFull - (Banded.mapExtent unifyLeft a) - (mapExtent unifyRight b) - -instance - (Unary.Natural subA, Unary.Natural superA, - Unary.Natural subB, Unary.Natural superB, - Extent.C vertA, Extent.C horizA, - Extent.C vertB, Extent.C horizB, - Shape.C heightA, Shape.C widthA, Shape.C widthB, - widthA ~ heightB, Eq heightB) => - Multiply - (MatrixShape.Banded subA superA vertA horizA heightA widthA) - (MatrixShape.Banded subB superB vertB horizB heightB widthB) where - type Multiplied - (MatrixShape.Banded subA superA vertA horizA heightA widthA) - (MatrixShape.Banded subB superB vertB horizB heightB widthB) = - MatrixShape.Banded - (subA :+: subB) (superA :+: superB) - (ExtentPriv.Multiply vertA vertB) - (ExtentPriv.Multiply horizA horizB) - heightA widthB - matrixMatrix a b = - case unifyFactors (bandedExtent a) (bandedExtent b) of - ((ExtentPriv.TagFact, ExtentPriv.TagFact), (unifyLeft, unifyRight)) -> - Banded.multiply - (Banded.mapExtent unifyLeft a) - (Banded.mapExtent unifyRight b) - -bandedExtent :: - Banded.Banded sup super vert horiz height width a -> - Extent.Extent vert horiz height width -bandedExtent = MatrixShape.bandedExtent . Array.shape - - -instance - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, - Shape.C size, size ~ width, Eq width, Shape.C height, Eq height) => - Multiply - (MatrixShape.Full vert horiz height width) - (MatrixShape.BandedHermitian offDiag size) - where - type Multiplied - (MatrixShape.Full vert horiz height width) - (MatrixShape.BandedHermitian offDiag size) = - MatrixShape.Full vert horiz height width - matrixMatrix = fullSquare - -instance - (Unary.Natural offDiag, Extent.C vert, Extent.C horiz, - Shape.C size, size ~ height, Eq height, Shape.C width, Eq width) => - Multiply - (MatrixShape.BandedHermitian offDiag size) - (MatrixShape.Full vert horiz height width) - where - type Multiplied - (MatrixShape.BandedHermitian offDiag size) - (MatrixShape.Full vert horiz height width) = - MatrixShape.Full vert horiz height width - matrixMatrix = squareFull - -instance - (Unary.Natural offDiag, Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, - Shape.C size, size ~ width, Eq width, Shape.C height, Eq height) => - Multiply - (MatrixShape.Banded sub super vert horiz height width) - (MatrixShape.BandedHermitian offDiag size) - where - type Multiplied - (MatrixShape.Banded sub super vert horiz height width) - (MatrixShape.BandedHermitian offDiag size) = - MatrixShape.Banded - (sub:+:offDiag) (super:+:offDiag) vert horiz height width - matrixMatrix a b = - Banded.multiply a (bandedGenSquare $ BandedHermitian.toBanded b) - -instance - (Unary.Natural offDiag, Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, - Shape.C size, size ~ height, Eq height, Shape.C width, Eq width) => - Multiply - (MatrixShape.BandedHermitian offDiag size) - (MatrixShape.Banded sub super vert horiz height width) - where - type Multiplied - (MatrixShape.BandedHermitian offDiag size) - (MatrixShape.Banded sub super vert horiz height width) = - MatrixShape.Banded - (offDiag:+:sub) (offDiag:+:super) vert horiz height width - matrixMatrix a b = - Banded.multiply (bandedGenSquare $ BandedHermitian.toBanded a) b - -instance - (Unary.Natural offDiagA, Unary.Natural offDiagB, - Shape.C sizeA, sizeA ~ sizeB, Shape.C sizeB, Eq sizeB) => - Multiply - (MatrixShape.BandedHermitian offDiagA sizeA) - (MatrixShape.BandedHermitian offDiagB sizeB) - where - type Multiplied - (MatrixShape.BandedHermitian offDiagA sizeA) - (MatrixShape.BandedHermitian offDiagB sizeB) = - MatrixShape.Banded - (offDiagA:+:offDiagB) (offDiagA:+:offDiagB) - Small Small sizeA sizeB - matrixMatrix a b = - Banded.multiply (BandedHermitian.toBanded a) (BandedHermitian.toBanded b) diff --git a/src/Numeric/LAPACK/Matrix/Private.hs b/src/Numeric/LAPACK/Matrix/Private.hs --- a/src/Numeric/LAPACK/Matrix/Private.hs +++ b/src/Numeric/LAPACK/Matrix/Private.hs @@ -1,8 +1,7 @@ module Numeric.LAPACK.Matrix.Private where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape @@ -11,24 +10,26 @@ import Foreign.ForeignPtr (ForeignPtr) -type Full vert horiz height width = - Array (MatrixShape.Full vert horiz height width) +type Full meas vert horiz height width = + Array (Layout.Full meas vert horiz height width) -type General height width = Array (MatrixShape.General height width) -type Tall height width = Array (MatrixShape.Tall height width) -type Wide height width = Array (MatrixShape.Wide height width) -type Square sh = Array (MatrixShape.Square sh) +type General height width = Array (Layout.General height width) +type Tall height width = Array (Layout.Tall height width) +type Wide height width = Array (Layout.Wide height width) +type LiberalSquare height width = Array (Layout.LiberalSquare height width) +type Square sh = Array (Layout.Square sh) +type SquareMeas meas height width = Array (Layout.SquareMeas meas height width) argGeneral :: - (MatrixShape.Order -> height -> width -> ForeignPtr a -> b) -> + (Layout.Order -> height -> width -> ForeignPtr a -> b) -> (General height width a -> b) -argGeneral f (Array (MatrixShape.Full order extent) a) = +argGeneral f (Array (Layout.Full order extent) a) = f order (Extent.height extent) (Extent.width extent) a argSquare :: - (MatrixShape.Order -> sh -> ForeignPtr a -> b) -> (Square sh a -> b) -argSquare f (Array (MatrixShape.Full order extent) a) = + (Layout.Order -> sh -> ForeignPtr a -> b) -> (Square sh a -> b) +argSquare f (Array (Layout.Full order extent) a) = f order (Extent.squareSize extent) a @@ -39,41 +40,60 @@ mapExtent :: - (Extent.C vertA, Extent.C horizA) => - (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - Full vertA horizA height width a -> Full vertB horizB height width a -mapExtent f = Array.mapShape $ MatrixShape.fullMapExtent f + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Full measA vertA horizA height width a -> + Full measB vertB horizB height width a +mapExtent f = Array.mapShape $ Layout.fullMapExtent f fromFull :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> General height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> General height width a fromFull = mapExtent Extent.toGeneral generalizeTall :: - (Extent.C vert, Extent.C horiz) => - Full vert Extent.Small height width a -> Full vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert Extent.Small height width a -> + Full Extent.Size vert horiz height width a generalizeTall = mapExtent Extent.generalizeTall generalizeWide :: - (Extent.C vert, Extent.C horiz) => - Full Extent.Small horiz height width a -> Full vert horiz height width a + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas Extent.Small horiz height width a -> + Full Extent.Size vert horiz height width a generalizeWide = mapExtent Extent.generalizeWide +weakenTall :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert Extent.Small height width a -> + Full meas vert horiz height width a +weakenTall = mapExtent Extent.weakenTall -height :: (Box.Box shape) => Array shape a -> Box.HeightOf shape -height = Box.height . Array.shape +weakenWide :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas Extent.Small horiz height width a -> + Full meas vert horiz height width a +weakenWide = mapExtent Extent.weakenWide -width :: (Box.Box shape) => Array shape a -> Box.WidthOf shape -width = Box.width . Array.shape +height :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> height +height = Layout.fullHeight . Array.shape +width :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> width +width = Layout.fullWidth . Array.shape + + revealOrder :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width a -> + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Full meas vert horiz height width a -> Either (Array (height,width) a) (Array (width,height) a) -revealOrder (Array (MatrixShape.Full order extent) a) = +revealOrder (Array (Layout.Full order extent) a) = let (h,w) = Extent.dimensions extent in case order of - MatrixShape.RowMajor -> Left $ Array (h,w) a - MatrixShape.ColumnMajor -> Right $ Array (w,h) a + Layout.RowMajor -> Left $ Array (h,w) a + Layout.ColumnMajor -> Right $ Array (w,h) a diff --git a/src/Numeric/LAPACK/Matrix/Quadratic.hs b/src/Numeric/LAPACK/Matrix/Quadratic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Quadratic.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Quadratic ( + asDiagonal, + asSymmetric, + + size, + mapSize, + + identity, + diagonal, Diagonal, + OmniMatrix.takeDiagonal, + + takeTopLeft, + takeTopRight, + takeBottomLeft, + takeBottomRight, + ) where + +import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos + +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Basic as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Basic as Full + +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Class as MatrixClass +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import Numeric.LAPACK.Matrix.Array.Banded (FlexDiagonal) +import Numeric.LAPACK.Matrix.Array.Mosaic (Symmetric) +import Numeric.LAPACK.Matrix.Array (General, Quadratic) +import Numeric.LAPACK.Matrix.Shape.Omni (Arbitrary) +import Numeric.LAPACK.Matrix.Layout.Private (Order) +import Numeric.LAPACK.Vector (Vector) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) +import Data.Function.HT (Id) + + + +asDiagonal :: Id (FlexDiagonal diag sh a) +asDiagonal = id + +asSymmetric :: Id (Symmetric sh a) +asSymmetric = id + + +size :: Quadratic pack property lower upper sh a -> sh +size = Omni.squareSize . ArrMatrix.shape + +{- | +The number of rows and columns must be maintained by the shape mapping function. +-} +mapSize :: + (Shape.C shA, Shape.C shB) => + (shA -> shB) -> + Quadratic pack property lower upper shA a -> + Quadratic pack property lower upper shB a +mapSize = OmniMatrix.mapSquareSize + + +identity :: + (Omni.Quadratic pack property lower upper, Shape.C sh, Class.Floating a) => + Order -> sh -> Quadratic pack property lower upper sh a +identity = OmniMatrix.identityOrder + +diagonal :: + (Diagonal property, Omni.Quadratic pack property lower upper, + Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> Quadratic pack property lower upper sh a +diagonal order v = diagonalAux (Omni.quadratic order $ Array.shape v) v + +class (Omni.Property property) => Diagonal property where + diagonalAux :: + (Omni.Quadratic pack property lower upper) => + (Shape.C sh, Class.Floating a) => + MatrixShape.Quadratic pack property lower upper sh -> Vector sh a -> + Quadratic pack property lower upper sh a + +instance Diagonal Arbitrary where + diagonalAux omni v = + case omni of + Omni.Full _ -> squareDiagonal omni v + Omni.LowerTriangular _ -> Triangular.diagonal (Omni.order omni) v + Omni.UpperTriangular _ -> Triangular.diagonal (Omni.order omni) v + Omni.Banded _ -> + ArrMatrix.Array $ Array.mapShape Omni.Banded $ + Banded.diagonalFat (Omni.order omni) v + +instance Diagonal Omni.Symmetric where + diagonalAux omni v = + case omni of + Omni.Full _ -> squareDiagonal omni v + Omni.LowerTriangular _ -> error "lower triangular not symmetric" + Omni.UpperTriangular _ -> error "upper triangular not symmetric" + Omni.Symmetric _ -> Symmetric.diagonal (Omni.order omni) v + +squareDiagonal :: + (Omni.Property property, Omni.Strip lower, Omni.Strip upper) => + (Shape.C sh, Class.Floating a) => + MatrixShape.Quadratic pack property lower upper sh -> Vector sh a -> + Quadratic Layout.Unpacked property lower upper sh a +squareDiagonal omni = + ArrMatrix.liftUnpacked0 . Square.diagonalOrder (Omni.order omni) + + +takeTopLeft :: + (Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic pack property lower upper (sh0::+sh1) a -> + Quadratic pack property lower upper sh0 a +takeTopLeft a = + case ArrMatrix.shape a of + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (Full.recheck . Square.fromFull . Full.uncheck . + Full.takeTop . Full.takeLeft . Square.toFull) a + Omni.LowerTriangular _ -> Triangular.takeTopLeft a + Omni.UpperTriangular _ -> Triangular.takeTopLeft a + Omni.Symmetric _ -> Symmetric.takeTopLeft a + Omni.Hermitian _ -> ArrMatrix.lift1 Mos.takeTopLeft a + Omni.Banded _ -> ArrMatrix.lift1 Banded.takeTopLeftSquare a + Omni.BandedHermitian _ -> ArrMatrix.lift1 BandedHermitian.takeTopLeft a + Omni.UnitBandedTriangular _ -> ArrMatrix.lift1 Banded.takeTopLeftSquare a + +takeBottomLeft :: + (Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic pack property Layout.Filled upper (sh0::+sh1) a -> + General sh1 sh0 a +takeBottomLeft a = + case ArrMatrix.shape a of + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (Full.takeBottom . Full.takeLeft . Square.toFull) a + Omni.LowerTriangular _ -> Triangular.takeBottomLeft a + Omni.Symmetric _ -> Matrix.transpose $ Symmetric.takeTopRight a + Omni.Hermitian _ -> + MatrixClass.adjoint $ ArrMatrix.lift1 Mos.takeTopRight a + +takeTopRight :: + (Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic pack property lower Layout.Filled (sh0::+sh1) a -> + General sh0 sh1 a +takeTopRight a = + case ArrMatrix.shape a of + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (Full.takeTop . Full.takeRight . Square.toFull) a + Omni.UpperTriangular _ -> Triangular.takeTopRight a + Omni.Symmetric _ -> Symmetric.takeTopRight a + Omni.Hermitian _ -> ArrMatrix.lift1 Mos.takeTopRight a + +takeBottomRight :: + (Shape.C sh0, Shape.C sh1, Class.Floating a) => + Quadratic pack property lower upper (sh0::+sh1) a -> + Quadratic pack property lower upper sh1 a +takeBottomRight a = + case ArrMatrix.shape a of + Omni.Full _ -> + ArrMatrix.liftUnpacked1 + (Full.recheck . Square.fromFull . Full.uncheck . + Full.takeBottom . Full.takeRight . Square.toFull) a + Omni.LowerTriangular _ -> Triangular.takeBottomRight a + Omni.UpperTriangular _ -> Triangular.takeBottomRight a + Omni.Symmetric _ -> Symmetric.takeBottomRight a + Omni.Hermitian _ -> ArrMatrix.lift1 Mos.takeBottomRight a + Omni.Banded _ -> ArrMatrix.lift1 Banded.takeBottomRightSquare a + Omni.BandedHermitian _ -> + ArrMatrix.lift1 BandedHermitian.takeBottomRight a + Omni.UnitBandedTriangular _ -> + ArrMatrix.lift1 Banded.takeBottomRightSquare a diff --git a/src/Numeric/LAPACK/Matrix/RowMajor.hs b/src/Numeric/LAPACK/Matrix/RowMajor.hs --- a/src/Numeric/LAPACK/Matrix/RowMajor.hs +++ b/src/Numeric/LAPACK/Matrix/RowMajor.hs @@ -1,10 +1,10 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Matrix.RowMajor where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor)) import Numeric.LAPACK.Matrix.Private (Full, ShapeInt, shapeInt) import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated,Conjugated)) import Numeric.LAPACK.Scalar (zero, one) @@ -173,14 +173,14 @@ kronecker :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C heightA, Shape.C widthA, Shape.C heightB, Shape.C widthB, Class.Floating a) => - Full vert horiz heightA widthA a -> + Full meas vert horiz heightA widthA a -> Matrix heightB widthB a -> Matrix (heightA,heightB) (widthA,widthB) a kronecker - (Array (MatrixShape.Full orderA extentA) a) (Array (heightB,widthB) b) = + (Array (Layout.Full orderA extentA) a) (Array (heightB,widthB) b) = let (heightA,widthA) = Extent.dimensions extentA in Array.unsafeCreate ((heightA,heightB), (widthA,widthB)) $ \cPtr -> evalContT $ do diff --git a/src/Numeric/LAPACK/Matrix/Shape.hs b/src/Numeric/LAPACK/Matrix/Shape.hs --- a/src/Numeric/LAPACK/Matrix/Shape.hs +++ b/src/Numeric/LAPACK/Matrix/Shape.hs @@ -1,107 +1,267 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Shape ( - General, - Tall, - Wide, - Square, - Full(..), fullHeight, fullWidth, - Order(..), flipOrder, - general, - square, - wide, - tall, + module Numeric.LAPACK.Matrix.Shape, + Layout.Order(..), + Layout.flipOrder, + Omni.height, + Omni.width, + Omni.extent, + Omni.squareSize, + Omni.order, + Omni.TriDiag, + Omni.DiagSingleton(..), + Omni.Property, + Omni.PowerStrip, + Omni.PowerStripSingleton(..), + Omni.powerStripSingleton, + Omni.Strip, + Omni.StripSingleton(..), + Omni.stripSingleton, + Arbitrary, + Unit, + LayoutPriv.Filled, + LayoutPriv.Empty, + Bands, + Layout.addOffDiagonals, + Layout.Packing, + Layout.Packed, + Layout.Unpacked, + ) where - Split, - SplitGeneral, - Triangle(..), - Reflector(..), - splitGeneral, - splitFromFull, +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as LayoutPriv +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import Numeric.LAPACK.Matrix.Shape.Omni (Omni(..), Arbitrary, Unit) +import Numeric.LAPACK.Matrix.Layout.Private + (Bands, UnaryProxy, Empty, Filled, Order, Packed, Unpacked) +import Numeric.LAPACK.Matrix.Extent.Private (Small, Big, Shape, Size) - Hermitian(..), - hermitian, +import qualified Data.Array.Comfort.Shape as Shape - Triangular(..), - Identity, - Diagonal, - LowerTriangular, - UpperTriangular, - Symmetric, - diagonal, - lowerTriangular, - upperTriangular, - symmetric, - autoDiag, - autoUplo, - DiagUpLo, - switchDiagUpLo, - switchDiagUpLoSym, - TriDiag, - switchTriDiag, - Unit(Unit), - NonUnit(NonUnit), +import qualified Type.Data.Num.Unary.Literal as TypeNum +import qualified Type.Data.Num.Unary as Unary +import Type.Base.Proxy (Proxy(Proxy)) - Banded(..), - BandedGeneral, - BandedSquare, - BandedLowerTriangular, - BandedUpperTriangular, - BandedDiagonal, - BandedIndex(..), - bandedGeneral, - bandedSquare, - bandedFromFull, - UnaryProxy, - addOffDiagonals, - Content, - BandedHermitian(..), - bandedHermitian, +type Full = Omni Unpacked Arbitrary Filled Filled - Box.Box, Box.HeightOf, Box.WidthOf, Box.height, Box.width, - ) where +type General = Full Size Big Big -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import Numeric.LAPACK.Matrix.Shape.Private +general :: Order -> height -> width -> General height width +general order height width = + Full $ Layout.general order height width +type Tall = Full Size Big Small -type SplitGeneral lower height width = - Split lower Extent.Big Extent.Big height width +tall :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Tall height width +tall order height width = + Full $ Layout.tall order height width -splitGeneral :: - lower -> Order -> height -> width -> SplitGeneral lower height width -splitGeneral lowerPart order height width = - Split lowerPart order $ Extent.general height width +type Wide = Full Size Small Big -splitFromFull :: - lower -> - Full vert horiz height width -> - Split lower vert horiz height width -splitFromFull lowerPart (Full order extent) = Split lowerPart order extent +wide :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> Wide height width +wide order height width = + Full $ Layout.wide order height width +type LiberalSquare = Full Size Small Small -diagonal :: Order -> size -> Triangular Empty NonUnit Empty size -diagonal = Triangular NonUnit autoUplo +liberalSquare :: + (Shape.C height, Shape.C width) => + Order -> height -> width -> LiberalSquare height width +liberalSquare order height width = + Full $ Layout.liberalSquare order height width -lowerTriangular :: Order -> size -> LowerTriangular NonUnit size -lowerTriangular = Triangular NonUnit autoUplo +type Square sh = Full Shape Small Small sh sh -upperTriangular :: Order -> size -> UpperTriangular NonUnit size -upperTriangular = Triangular NonUnit autoUplo +square :: (Shape.C sh) => Order -> sh -> Square sh +square order sh = Full $ Layout.square order sh + +type Quadratic pack property lower upper size = + QuadraticMeas pack property lower upper Shape size size +type QuadraticMeas pack property lower upper meas height width = + Omni pack property lower upper meas Small Small height width + +type Hermitian size = + Quadratic Packed Omni.HermitianUnknownDefiniteness Filled Filled size + +hermitian :: Order -> sh -> Hermitian sh +hermitian order size = Hermitian $ Layout.hermitian order size + + +type Diagonal size = Quadratic Packed Arbitrary Empty Empty size + +diagonal :: Order -> size -> Diagonal size +diagonal order size = + Banded $ + Layout.bandedSquare + (Unary.unary Unary.zero, Unary.unary Unary.zero) order size + +type Identity size = Quadratic Packed Unit Empty Empty size + +identity :: Order -> size -> Identity size +identity order size = + UnitBandedTriangular $ + Layout.bandedSquare + (Unary.unary Unary.zero, Unary.unary Unary.zero) order size + + + +type UpLo lo up = (UpLoC lo up, UpLoC up lo) + +class (DiagUpLoC lo up) => UpLoC lo up where + switchUpLo :: f Empty Filled -> f Filled Empty -> f lo up + +instance UpLoC Empty Filled where switchUpLo f _ = f +instance UpLoC Filled Empty where switchUpLo _ f = f + + +type DiagUpLo lo up = (DiagUpLoC lo up, DiagUpLoC up lo) + +class (Omni.PowerStrip lo, Omni.PowerStrip up) => DiagUpLoC lo up where + switchDiagUpLo :: + f Empty Empty -> f Empty Filled -> f Filled Empty -> f lo up + +instance DiagUpLoC Empty Empty where switchDiagUpLo f _ _ = f +instance DiagUpLoC Empty Filled where switchDiagUpLo _ f _ = f +instance DiagUpLoC Filled Empty where switchDiagUpLo _ _ f = f + + +data UpLoSingleton lo up where + Lower :: UpLoSingleton Filled Empty + Upper :: UpLoSingleton Empty Filled + +autoUplo :: (UpLo lo up) => UpLoSingleton lo up +autoUplo = switchUpLo Upper Lower + + + +type Triangular lo diag up size = Quadratic Packed diag lo up size + +triangular :: + (DiagUpLo lo up, Omni.TriDiag diag) => + Order -> size -> Triangular lo diag up size +triangular order size = + runGenTriangularDiag $ + Omni.switchTriDiag + (GenTriangularDiag $ unitTriangular order size) + (GenTriangularDiag $ arbitraryTriangular order size) + +unitTriangular :: + (DiagUpLo lo up) => + Order -> size -> Triangular lo Unit up size +unitTriangular order size = + runGenTriangularLoUp $ + switchDiagUpLo + (GenTriangularLoUp $ identity order size) + (GenTriangularLoUp $ UpperTriangular $ + Layout.upperTriangular order size) + (GenTriangularLoUp $ LowerTriangular $ + Layout.lowerTriangular order size) + +arbitraryTriangular :: + (DiagUpLo lo up) => + Order -> size -> Triangular lo Arbitrary up size +arbitraryTriangular order size = + runGenTriangularLoUp $ + switchDiagUpLo + (GenTriangularLoUp $ diagonal order size) + (GenTriangularLoUp $ upperTriangular order size) + (GenTriangularLoUp $ lowerTriangular order size) + + +newtype GenTriangularDiag lo up size a diag = + GenTriangularDiag { + runGenTriangularDiag :: Triangular lo diag up size + } + +newtype GenTriangularLoUp diag size a lo up = + GenTriangularLoUp { + runGenTriangularLoUp :: Triangular lo diag up size + } + + +type LowerTriangular size = Quadratic Packed Arbitrary Filled Empty size + +lowerTriangular :: Order -> size -> LowerTriangular size +lowerTriangular order size = + LowerTriangular $ Layout.lowerTriangular order size + + +type UpperTriangular size = Quadratic Packed Arbitrary Empty Filled size + +upperTriangular :: Order -> size -> UpperTriangular size +upperTriangular order size = + UpperTriangular $ Layout.upperTriangular order size + + +type Symmetric size = Quadratic Packed Omni.Symmetric Filled Filled size + symmetric :: Order -> size -> Symmetric size -symmetric = Triangular NonUnit autoUplo +symmetric order size = Symmetric $ Layout.symmetric order size -hermitian :: Order -> size -> Hermitian size -hermitian = Hermitian +type Banded sub super meas vert horiz = + Omni Packed Arbitrary (Bands sub) (Bands super) meas vert horiz -bandedFromFull :: - (UnaryProxy sub, UnaryProxy super) -> - Full vert horiz height width -> - Banded sub super vert horiz height width -bandedFromFull offDiag (Full order extent) = Banded offDiag order extent +bandedOffDiagonals :: + Omni Packed property (Bands sub) (Bands super) + meas vert horiz height width -> + (UnaryProxy sub, UnaryProxy super) +bandedOffDiagonals _ = (Proxy, Proxy) -bandedHermitian :: UnaryProxy off -> Order -> size -> BandedHermitian off size -bandedHermitian = BandedHermitian +type BandedGeneral sub super = + Omni Packed Arbitrary (Bands sub) (Bands super) Size Big Big + +bandedGeneral :: + (Unary.Natural sub, Unary.Natural super, + Shape.C height, Shape.C width) => + (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> + BandedGeneral sub super height width +bandedGeneral offDiag order height width = + Banded $ Layout.bandedGeneral offDiag order height width + +type BandedTriangular sub super size = + Quadratic Packed Arbitrary (Bands sub) (Bands super) size +type BandedLower sub size = BandedTriangular sub TypeNum.U0 size +type BandedUpper super size = BandedTriangular TypeNum.U0 super size + +type BandedUnitTriangular sub super size = + Quadratic Packed Unit (Bands sub) (Bands super) size +type BandedUnitLower sub size = BandedUnitTriangular sub TypeNum.U0 size +type BandedUnitUpper super size = BandedUnitTriangular TypeNum.U0 super size + + +type BandedHermitian offDiag size = + Quadratic Packed Omni.HermitianUnknownDefiniteness + (Bands offDiag) (Bands offDiag) size + +bandedHermitian :: + (Unary.Natural offDiag) => + UnaryProxy offDiag -> Order -> size -> BandedHermitian offDiag size +bandedHermitian numOff order size = + BandedHermitian $ Layout.bandedHermitian numOff order size + +-- | For Hermitian eigenvalues +type RealDiagonal size = BandedHermitian TypeNum.U0 size + +{- | For singular values + +However, diagonal matrices produced by singular value decomposition +may be non-square and Hermitian must be square. +-} +type PositiveDiagonal size = + Quadratic Packed Omni.HermitianPositiveDefinite Empty Empty size + + +type + UpperQuasitriangular size = + Quadratic Unpacked Arbitrary (Bands TypeNum.U1) Filled size diff --git a/src/Numeric/LAPACK/Matrix/Shape/Box.hs b/src/Numeric/LAPACK/Matrix/Shape/Box.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Shape/Box.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Matrix.Shape.Box where - -import qualified Data.Array.Comfort.Shape as Shape - - -class (Shape.C shape) => Box shape where - type HeightOf shape - type WidthOf shape - height :: shape -> HeightOf shape - width :: shape -> WidthOf shape - -indices :: - (Box shape, - HeightOf shape ~ height, Shape.Indexed height, - WidthOf shape ~ width, Shape.Indexed width) => - shape -> [(Shape.Index height, Shape.Index width)] -indices sh = Shape.indices (height sh, width sh) diff --git a/src/Numeric/LAPACK/Matrix/Shape/Omni.hs b/src/Numeric/LAPACK/Matrix/Shape/Omni.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Shape/Omni.hs @@ -0,0 +1,1050 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE Rank2Types #-} +module Numeric.LAPACK.Matrix.Shape.Omni ( + Omni(..), + Unit, + Arbitrary, + Symmetric, + Hermitian, + HermitianUnknownDefiniteness, + HermitianPositiveDefinite, + HermitianPositiveSemidefinite, + HermitianNegativeDefinite, + HermitianNegativeSemidefinite, + hermitianSet, + TriDiag(switchTriDiag), + DiagSingleton(..), + autoDiag, + charFromTriDiag, + packTag, + Property, + property, + PropertySingleton(..), + propertySingleton, + Strip(..), + strips, + StripSingleton(..), + stripSingleton, + PowerStrip(..), + PowerStripSingleton(..), + powerStripSingleton, + powerStrips, + BandedTriangular, + BandedTriangularSingleton(BandedLower, BandedUpper, BandedDiagonal), + bandedTriangularSingleton, + extent, + height, width, squareSize, + mapHeight, mapWidth, mapSquareSize, + order, + transpose, + Plain, + ToPlain, toPlain, + FromPlain, fromPlain, + toFull, fromFull, + toBanded, toBandedHermitian, + MultipliedBands, + MultipliedStrip, + MultipliedProperty, + UnitIfTriangular, + MergeUnit, + Quadratic, + quadratic, + uncheckedDiagonal, + Power(..), + powerSingleton, + ) where + +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentS +import Numeric.LAPACK.Matrix.Extent.Private (Extent, Small, Shape, Size) +import Numeric.LAPACK.Matrix.Layout.Private + (Bands, Empty, Filled, Packed, Unpacked) + +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Type.Data.Num.Unary as Unary +import qualified Type.Data.Bool as TBool +import Type.Data.Num.Unary.Literal (U0) +import Type.Data.Bool (False, True) +import Type.Base.Proxy (Proxy(Proxy)) + +import qualified Control.DeepSeq as DeepSeq + + + +data Unit +data Arbitrary + +class (Property diag) => TriDiag diag where + switchTriDiag :: f Unit -> f Arbitrary -> f diag +instance TriDiag Unit where switchTriDiag f _ = f +instance TriDiag Arbitrary where switchTriDiag _ f = f + +autoDiag :: TriDiag diag => DiagSingleton diag +autoDiag = switchTriDiag Unit Arbitrary + +charFromTriDiag :: TriDiag diag => DiagSingleton diag -> Char +charFromTriDiag diag = case diag of Unit -> 'U'; Arbitrary -> 'N' + + +data DiagSingleton diag where + Unit :: DiagSingleton Unit + Arbitrary :: DiagSingleton Arbitrary + +instance Eq (DiagSingleton diag) where + Unit == Unit = True + Arbitrary == Arbitrary = True + +instance Show (DiagSingleton diag) where + show Unit = "Unit" + show Arbitrary = "Arbitrary" + +instance DeepSeq.NFData (DiagSingleton diag) where + rnf Unit = () + rnf Arbitrary = () + + +data Symmetric + +data Hermitian neg zero pos +type HermitianUnknownDefiniteness = Hermitian True True True +type HermitianPositiveDefinite = Hermitian False False True +type HermitianPositiveSemidefinite = Hermitian False True True +type HermitianNegativeDefinite = Hermitian True False False +type HermitianNegativeSemidefinite = Hermitian True True False + +{- | +Impossible: + +> instance Definiteness False False False where +> instance Definiteness True False True where + +The last one is impossible for this reason: + +Given @x@ and @y@ with @x^T*A*x < 0@ and @y^T*A*y > 0@. +Because of the intermediate value theorem +there must be a @k@ from @[0,1]@ with +@z = k*x + (1-k)*y@ and @z^T*A*z = 0@. +-} +class Definiteness neg zero pos where +instance Definiteness True True True where +instance Definiteness True True False where +instance Definiteness False True True where +instance Definiteness True False False where +instance Definiteness False True False where +instance Definiteness False False True where + +hermitianSet :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + Omni pack (Hermitian neg zero pos) + lower upper meas vert horiz height width -> + (TBool.Singleton neg, TBool.Singleton zero, TBool.Singleton pos) +hermitianSet _ = (TBool.singleton, TBool.singleton, TBool.singleton) + + + +class Property property where + switchProperty :: + f Arbitrary -> + f Unit -> + f Symmetric -> + (forall neg zero pos. + (TBool.C neg, TBool.C zero, TBool.C pos) => + f (Hermitian neg zero pos)) -> + f property + +instance Property Arbitrary where switchProperty f _ _ _ = f +instance Property Unit where switchProperty _ f _ _ = f +instance Property Symmetric where switchProperty _ _ f _ = f +instance + (TBool.C neg, TBool.C zero, TBool.C pos) => + Property (Hermitian neg zero pos) where + switchProperty _ _ _ f = f + +data PropertySingleton property where + PropArbitrary :: PropertySingleton Arbitrary + PropUnit :: PropertySingleton Unit + PropSymmetric :: PropertySingleton Symmetric + PropHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + PropertySingleton (Hermitian neg zero pos) + +propertySingleton :: + (Property property) => PropertySingleton property +propertySingleton = + switchProperty PropArbitrary PropUnit PropSymmetric PropHermitian + +property :: + (Property property) => + Omni pack property lower upper meas vert horiz height width -> + PropertySingleton property +property _ = propertySingleton + + +class + (MultipliedBands c Filled ~ Filled, MultipliedBands c Empty ~ c) => + Strip c where + switchStrip :: + (forall offDiag. Unary.Natural offDiag => f (Bands offDiag)) -> + f Filled -> + f c +instance (Unary.Natural offDiag) => Strip (Bands offDiag) where + switchStrip f _ = f +instance Strip Filled where + switchStrip _ f = f + + +data StripSingleton c where + StripBands :: + (Unary.Natural offDiag) => + Unary.HeadSingleton offDiag -> StripSingleton (Bands offDiag) + StripFilled :: StripSingleton Filled + +stripSingleton :: (Strip c) => StripSingleton c +stripSingleton = switchStrip (StripBands Unary.headSingleton) StripFilled + +strips :: + (Strip lower, Strip upper) => + Omni pack property lower upper meas vert horiz height width -> + (StripSingleton lower, StripSingleton upper) +strips _ = (stripSingleton, stripSingleton) + + + +{- | +'PowerStrip' is either 'Empty' or 'Filled'. +These are the 'Strip's that are preserved in matrix powers. + +Pun intended. +-} +class (Strip c) => PowerStrip c where + switchPowerStrip :: f Empty -> f Filled -> f c +instance (offDiag ~ U0) => PowerStrip (Bands offDiag) where + switchPowerStrip f _ = f +instance PowerStrip Filled where + switchPowerStrip _ f = f + +data PowerStripSingleton c where + Empty :: PowerStripSingleton Empty + Filled :: PowerStripSingleton Filled + +powerStripSingleton :: (PowerStrip c) => PowerStripSingleton c +powerStripSingleton = switchPowerStrip Empty Filled + +powerStrips :: + (PowerStrip lower, PowerStrip upper) => + Omni pack property lower upper meas vert horiz height width -> + (PowerStripSingleton lower, PowerStripSingleton upper) +powerStrips _ = (powerStripSingleton, powerStripSingleton) + + +packTag :: + (Layout.Packing pack) => + Omni pack propery lower upper meas vert horiz height width -> + Layout.PackingSingleton pack +packTag _ = Layout.autoPacking + + +type PowerQuadratic pack property lower upper sh = + Power pack property lower upper Shape Small Small sh sh + +data Power pack property lower upper meas vert horiz height width where + PowerIdentity :: + (Layout.Packing pack) => + PowerQuadratic pack Unit Empty Empty sh + PowerDiagonal :: + (Layout.Packing pack) => + Power pack property Empty Empty meas vert horiz height width + PowerUpperTriangular :: + (Layout.Packing pack, TriDiag diag) => + PowerQuadratic pack diag Empty Filled sh + PowerLowerTriangular :: + (Layout.Packing pack, TriDiag diag) => + PowerQuadratic pack diag Filled Empty sh + PowerSymmetric :: + (Layout.Packing pack) => + PowerQuadratic pack Symmetric Filled Filled sh + PowerHermitian :: + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos) => + PowerQuadratic pack (Hermitian neg zero pos) Filled Filled sh + PowerFull :: + Power Unpacked property lower upper meas vert horiz height width + +powerSingleton :: + (Layout.Packing pack, Property property, + PowerStrip lower, PowerStrip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni pack property lower upper meas vert horiz height width -> + Power pack property lower upper meas vert horiz height width +powerSingleton shape = + case packTag shape of + Layout.Packed -> + case (shape, powerStrips shape) of + (UpperTriangular _, _) -> PowerUpperTriangular + (LowerTriangular _, _) -> PowerLowerTriangular + (Symmetric _, _) -> PowerSymmetric + (Hermitian _, _) -> PowerHermitian + (Banded _, (Empty, Empty)) -> PowerDiagonal + (BandedHermitian _, (Empty, Empty)) -> PowerDiagonal + (UnitBandedTriangular _, (Empty, Empty)) -> PowerIdentity + Layout.Unpacked -> + case (extent shape, property shape, powerStrips shape) of + (Extent.Square _, PropUnit, (Empty, Empty)) -> + PowerIdentity + (Extent.Square _, _, (Empty, Empty)) -> + PowerDiagonal + (Extent.Square _, PropArbitrary, (Empty, Filled)) -> + PowerUpperTriangular + (Extent.Square _, PropArbitrary, (Filled, Empty)) -> + PowerLowerTriangular + (Extent.Square _, PropUnit, (Empty, Filled)) -> + PowerUpperTriangular + (Extent.Square _, PropUnit, (Filled, Empty)) -> + PowerLowerTriangular + (Extent.Square _, PropSymmetric, (Filled, Filled)) -> + PowerSymmetric + (Extent.Square _, PropHermitian, (Filled, Filled)) -> + PowerHermitian + _ -> PowerFull + + +class + (Unary.Natural sub, Unary.Natural super) => + BandedTriangular sub super where + switchBandedTriangular :: + f Unary.Zero Unary.Zero -> + (forall offDiag. Unary.Natural offDiag => + f Unary.Zero (Unary.Succ offDiag)) -> + (forall offDiag. Unary.Natural offDiag => + f (Unary.Succ offDiag) Unary.Zero) -> + f sub super +instance BandedTriangular Unary.Zero Unary.Zero where + switchBandedTriangular f _ _ = f +instance (Unary.Natural super) => + BandedTriangular Unary.Zero (Unary.Succ super) where + switchBandedTriangular _ f _ = f +instance (Unary.Natural sub) => + BandedTriangular (Unary.Succ sub) Unary.Zero where + switchBandedTriangular _ _ f = f + +data BandedTriangularSingleton sub super where + BandedDiagonal :: BandedTriangularSingleton Unary.Zero Unary.Zero + BandedUpper :: + Unary.Natural offDiag => + BandedTriangularSingleton Unary.Zero (Unary.Succ offDiag) + BandedLower :: + Unary.Natural offDiag => + BandedTriangularSingleton (Unary.Succ offDiag) Unary.Zero + +bandedTriangularSingleton :: + (BandedTriangular sub super) => + Layout.Banded sub super meas vert horiz height width -> + BandedTriangularSingleton sub super +bandedTriangularSingleton _ = + switchBandedTriangular BandedDiagonal BandedUpper BandedLower + + +data Omni pack property lower upper meas vert horiz height width where + Full :: + (Property property, Strip lower, Strip upper) => + Layout.Full meas vert horiz height width -> + Omni Unpacked property lower upper meas vert horiz height width + + UpperTriangular :: + (TriDiag diag) => + Layout.UpperTriangular size -> + Omni Packed diag Empty Filled Shape Small Small size size + LowerTriangular :: + (TriDiag diag) => + Layout.LowerTriangular size -> + Omni Packed diag Filled Empty Shape Small Small size size + + Symmetric :: + Layout.Symmetric size -> + Omni Packed Symmetric Filled Filled Shape Small Small size size + Hermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + Layout.Hermitian size -> + Omni Packed (Hermitian neg zero pos) + Filled Filled Shape Small Small size size + + Banded :: + (Unary.Natural sub, Unary.Natural super) => + Layout.Banded sub super meas vert horiz height width -> + Omni Packed Arbitrary + (Bands sub) (Bands super) meas vert horiz height width + + UnitBandedTriangular :: + (BandedTriangular sub super, BandedTriangular super sub) => + Layout.BandedSquare sub super size -> + Omni Packed Unit (Bands sub) (Bands super) Shape Small Small size size + + BandedHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + Layout.BandedHermitian offDiag size -> + Omni Packed (Hermitian neg zero pos) + (Bands offDiag) (Bands offDiag) Shape Small Small size size + +deriving instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq height, Eq width) => + Eq (Omni pack property lower upper meas vert horiz height width) + +deriving instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Show height, Show width) => + Show (Omni pack property lower upper meas vert horiz height width) + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + DeepSeq.NFData height, DeepSeq.NFData width) => + DeepSeq.NFData + (Omni pack property lower upper meas vert horiz height width) where + rnf omni = + case omni of + Full shape -> DeepSeq.rnf shape + UpperTriangular shape -> DeepSeq.rnf shape + LowerTriangular shape -> DeepSeq.rnf shape + Symmetric shape -> DeepSeq.rnf shape + Hermitian shape -> DeepSeq.rnf shape + Banded shape -> DeepSeq.rnf shape + UnitBandedTriangular shape -> DeepSeq.rnf shape + BandedHermitian shape -> DeepSeq.rnf shape + + +{- | +Construct a shape from order, dimensions and type information. +-} +class + (Property property, Strip lower, Strip upper, + ExtentS.Measured meas vert, ExtentS.Measured meas horiz) => + Cons pack property lower upper meas vert horiz where + cons :: + (Shape.C height, Shape.C width) => + (ExtentS.MeasureTarget meas height ~ ExtentS.MeasureTarget meas width) => + Layout.Order -> ExtentS.Dimension meas height width -> + Omni pack property lower upper meas vert horiz height width + +instance + (Strip lower, Strip upper, + ExtentS.Measured meas vert, ExtentS.Measured meas horiz) => + Cons Unpacked Arbitrary lower upper meas vert horiz where + cons order_ = Full . Layout.Full order_ . ExtentS.consChecked + +instance + (TriDiag diag, Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons Packed diag Empty Filled meas vert horiz where + cons order_ = UpperTriangular . Layout.upperTriangular order_ + +instance + (TriDiag diag, Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons Packed diag Filled Empty meas vert horiz where + cons order_ = LowerTriangular . Layout.lowerTriangular order_ + +instance + (Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons Packed Symmetric Filled Filled meas vert horiz where + cons order_ = Symmetric . Layout.symmetric order_ + +instance + (TBool.C neg, TBool.C zero, TBool.C pos, + Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons Packed (Hermitian neg zero pos) Filled Filled meas vert horiz where + cons order_ = Hermitian . Layout.hermitian order_ + +instance + (ExtentS.Measured meas vert, ExtentS.Measured meas horiz, + Unary.Natural sub, Unary.Natural super) => + Cons Packed Arbitrary (Bands sub) (Bands super) meas vert horiz where + cons order_ = + Banded . Layout.Banded (Proxy,Proxy) order_ . ExtentS.consChecked + +instance + (BandedTriangular sub super, BandedTriangular super sub, + Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons Packed Unit (Bands sub) (Bands super) meas vert horiz where + cons order_ = + UnitBandedTriangular . Layout.Banded (Proxy,Proxy) order_ . + Extent.square + +instance + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural sub, sub ~ super, + Shape ~ meas, Small ~ vert, Small ~ horiz) => + Cons + Packed (Hermitian neg zero pos) (Bands sub) (Bands super) + meas vert horiz where + cons order_ = BandedHermitian . Layout.BandedHermitian Proxy order_ + + + +class Quadratic pack property lower upper where + quadratic :: + (Shape.C sh) => + Layout.Order -> sh -> + Omni pack property lower upper Shape Small Small sh sh + +instance + (Strip lower, Strip upper) => + Quadratic Unpacked Arbitrary lower upper where + quadratic = cons + +instance (TriDiag diag) => Quadratic Packed diag Empty Filled where + quadratic = cons + +instance (TriDiag diag) => Quadratic Packed diag Filled Empty where + quadratic = cons + +instance Quadratic Packed Symmetric Filled Filled where + quadratic = cons + +instance + (TBool.C neg, TBool.C zero, TBool.C pos) => + Quadratic Packed (Hermitian neg zero pos) Filled Filled where + quadratic = cons + +instance + (Unary.Natural sub, Unary.Natural super) => + Quadratic Packed Arbitrary (Bands sub) (Bands super) where + quadratic = cons + +instance + (BandedTriangular sub super, BandedTriangular super sub) => + Quadratic Packed Unit (Bands sub) (Bands super) where + quadratic = cons + +instance + (TBool.C neg, TBool.C zero, TBool.C pos, sub ~ super, Unary.Natural super) => + Quadratic Packed (Hermitian neg zero pos) (Bands sub) (Bands super) where + quadratic = cons + + + +class FromPlain pack property lower upper meas vert horiz height width where + type Plain pack property lower upper meas vert horiz height width + fromPlain :: + Plain pack property lower upper meas vert horiz height width -> + Omni pack property lower upper meas vert horiz height width + +class + FromPlain pack property lower upper meas vert horiz height width => + ToPlain pack property lower upper meas vert horiz height width where + toPlain :: + Omni pack property lower upper meas vert horiz height width -> + Plain pack property lower upper meas vert horiz height width + + +instance + FromPlain Unpacked Arbitrary Filled Filled meas vert horiz height width + where + type Plain Unpacked Arbitrary Filled Filled meas vert horiz height width = + Layout.Full meas vert horiz height width + fromPlain = Full + +instance + ToPlain Unpacked Arbitrary Filled Filled meas vert horiz height width + where + toPlain (Full shape) = shape + + +instance + (Layout.Packing pack, TriDiag diag, height ~ width) => + FromPlain pack diag Empty Filled Shape Small Small height width where + type Plain pack diag Empty Filled Shape Small Small height width = + Layout.UpperTriangularP pack height + fromPlain = fromMosaic UpperTriangular + +instance + (Layout.Packing pack, TriDiag diag, height ~ width) => + ToPlain pack diag Empty Filled Shape Small Small height width where + toPlain (UpperTriangular shape) = shape + toPlain (Full shape) = Layout.mosaicFromSquare shape + + +instance + (Layout.Packing pack, TriDiag diag, height ~ width) => + FromPlain pack diag Filled Empty Shape Small Small height width where + type Plain pack diag Filled Empty Shape Small Small height width = + Layout.LowerTriangularP pack height + fromPlain = fromMosaic LowerTriangular + +instance + (Layout.Packing pack, TriDiag diag, height ~ width) => + ToPlain pack diag Filled Empty Shape Small Small height width where + toPlain (LowerTriangular shape) = shape + toPlain (Full shape) = Layout.mosaicFromSquare shape + + +instance + (Layout.Packing pack, height ~ width) => + FromPlain pack Symmetric Filled Filled Shape Small Small height width + where + type Plain pack Symmetric Filled Filled Shape Small Small height width = + Layout.SymmetricP pack height + fromPlain = fromMosaic Symmetric + +instance + (Layout.Packing pack, height ~ width) => + ToPlain pack Symmetric Filled Filled Shape Small Small height width where + toPlain (Symmetric shape) = shape + toPlain (Full shape) = Layout.mosaicFromSquare shape + + +instance + (Layout.Packing pack, + TBool.C neg, TBool.C zero, TBool.C pos, height ~ width) => + FromPlain pack (Hermitian neg zero pos) Filled Filled + Shape Small Small height width + where + type Plain pack (Hermitian neg zero pos) Filled Filled + Shape Small Small height width = + Layout.HermitianP pack height + fromPlain = fromMosaic Hermitian + +instance + (Layout.Packing pack, + TBool.C neg, TBool.C zero, TBool.C pos, height ~ width) => + ToPlain pack (Hermitian neg zero pos) Filled Filled + Shape Small Small height width + where + toPlain (Hermitian shape) = shape + toPlain (Full shape) = Layout.mosaicFromSquare shape + +fromMosaic :: + (Layout.Packing pack, Property property, Strip lower, Strip upper) => + (Layout.Mosaic Packed mirror uplo sh -> + Omni Packed property lower upper Shape Small Small sh sh) -> + Layout.Mosaic pack mirror uplo sh -> + Omni pack property lower upper Shape Small Small sh sh +fromMosaic packedShape shape = withPacking $ \pack -> + case pack of + Layout.Packed -> packedShape shape + Layout.Unpacked -> Full $ Layout.squareFromMosaic shape + +withPacking :: + (Layout.Packing pack, Property property, Strip lower, Strip upper) => + (Layout.PackingSingleton pack -> + Omni pack property lower upper meas vert horiz height width) -> + Omni pack property lower upper meas vert horiz height width +withPacking f = f Layout.autoPacking + + +instance + (Unary.Natural sub, Unary.Natural super) => + FromPlain Packed Arbitrary + (Bands sub) (Bands super) meas vert horiz height width + where + type Plain Packed Arbitrary + (Bands sub) (Bands super) meas vert horiz height width = + Layout.Banded sub super meas vert horiz height width + fromPlain = Banded + +instance + (Unary.Natural sub, Unary.Natural super) => + ToPlain Packed Arbitrary + (Bands sub) (Bands super) meas vert horiz height width + where + toPlain (Banded shape) = shape + + +instance + (BandedTriangular sub super, BandedTriangular super sub, height ~ width) => + FromPlain Packed Unit + (Bands sub) (Bands super) Shape Small Small height width + where + type Plain Packed Unit + (Bands sub) (Bands super) Shape Small Small height width = + Layout.BandedSquare sub super height + fromPlain = UnitBandedTriangular + +instance + (BandedTriangular sub super, BandedTriangular super sub, height ~ width) => + ToPlain Packed Unit (Bands sub) (Bands super) Shape Small Small height width + where + toPlain (UnitBandedTriangular shape) = shape + + +instance + (Unary.Natural sub, sub ~ super, height ~ width, + TBool.C neg, TBool.C zero, TBool.C pos) => + FromPlain Packed (Hermitian neg zero pos) (Bands sub) (Bands super) + Shape Small Small height width where + type + Plain + Packed (Hermitian neg zero pos) (Bands sub) (Bands super) + Shape Small Small height width = + Layout.BandedHermitian sub height + fromPlain = BandedHermitian + +instance + (Unary.Natural sub, sub ~ super, height ~ width, + TBool.C neg, TBool.C zero, TBool.C pos) => + ToPlain Packed (Hermitian neg zero pos) (Bands sub) (Bands super) + Shape Small Small height width where + toPlain (BandedHermitian shape) = shape + + +fromFull :: + (Property property, Strip lower, Strip upper) => + Layout.Full meas vert horiz height width -> + Omni Unpacked property lower upper meas vert horiz height width +fromFull = Full + +toFull :: + (Property property, Strip lower, Strip upper) => + Omni Unpacked property lower upper meas vert horiz height width -> + Layout.Full meas vert horiz height width +toFull (Full shape) = shape + + +newtype FromDiagonal size diag = + FromDiagonal { + getFromDiagonal :: + Layout.BandedSquare U0 U0 size -> + Omni Packed diag Empty Empty Shape Small Small size size + } + +uncheckedDiagonal :: + (Layout.Packing pack, TriDiag diag) => + Layout.Order -> size -> + Omni pack diag Empty Empty Shape Small Small size size +uncheckedDiagonal order_ size = withPacking $ \pack -> + case pack of + Layout.Packed -> + getFromDiagonal + (switchTriDiag + (FromDiagonal UnitBandedTriangular) + (FromDiagonal Banded)) + (Layout.Banded (Proxy,Proxy) order_ (Extent.square size)) + Layout.Unpacked -> + Full (Layout.Full order_ (Extent.square size)) + +_fromDiagonal :: + (TriDiag diag) => + Layout.Diagonal size -> + Omni Packed diag Empty Empty Shape Small Small size size +_fromDiagonal (Layout.Banded _offDiag order_ size) = + uncheckedDiagonal order_ (Extent.squareSize size) + +_toDiagonal :: + (TriDiag diag) => + Omni Packed diag Empty Empty Shape Small Small size size -> + Layout.Diagonal size +_toDiagonal omni = + case omni of + Banded sh -> sh + UnitBandedTriangular sh -> sh + BandedHermitian (Layout.BandedHermitian k order_ size) -> + Layout.Banded (k,k) order_ (Extent.square size) + + +_fromUpperTriangular :: + (Layout.Packing pack) => + (TriDiag diag) => + Layout.UpperTriangularP pack size -> + Omni pack diag Empty Filled Shape Small Small size size +_fromUpperTriangular = fromMosaic UpperTriangular + +_toUpperTriangular :: + (TriDiag diag) => + Omni pack diag Empty Filled Shape Small Small size size -> + Layout.UpperTriangularP pack size +_toUpperTriangular (UpperTriangular shape) = shape +_toUpperTriangular (Full shape) = Layout.mosaicFromSquare shape + + +_fromLowerTriangular :: + (Layout.Packing pack) => + (TriDiag diag) => + Layout.LowerTriangularP pack size -> + Omni pack diag Filled Empty Shape Small Small size size +_fromLowerTriangular = fromMosaic LowerTriangular + +_toLowerTriangular :: + (TriDiag diag) => + Omni pack diag Filled Empty Shape Small Small size size -> + Layout.LowerTriangularP pack size +_toLowerTriangular (LowerTriangular shape) = shape +_toLowerTriangular (Full shape) = Layout.mosaicFromSquare shape + + +_fromSymmetric :: + (Layout.Packing pack) => + Layout.SymmetricP pack size -> + Omni pack Symmetric Filled Filled Shape Small Small size size +_fromSymmetric = fromMosaic Symmetric + +_toSymmetric :: + Omni pack Symmetric Filled Filled Shape Small Small size size -> + Layout.SymmetricP pack size +_toSymmetric (Symmetric shape) = shape +_toSymmetric (Full shape) = Layout.mosaicFromSquare shape + + +_fromHermitian :: + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos) => + Layout.HermitianP pack size -> + Omni pack (Hermitian neg zero pos) Filled Filled Shape Small Small size size +_fromHermitian = fromMosaic Hermitian + +_toHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos) => + Omni pack (Hermitian neg zero pos) + Filled Filled Shape Small Small size size -> + Layout.HermitianP pack size +_toHermitian (Hermitian shape) = shape +_toHermitian (Full shape) = Layout.mosaicFromSquare shape + + +_fromBanded :: + (Unary.Natural sub, Unary.Natural super) => + Layout.Banded sub super meas vert horiz height width -> + Omni Packed Arbitrary (Bands sub) (Bands super) meas vert horiz height width +_fromBanded = Banded + +toBanded :: + (Unary.Natural sub, Unary.Natural super) => + Omni Packed Arbitrary + (Bands sub) (Bands super) meas vert horiz height width -> + Layout.Banded sub super meas vert horiz height width +toBanded (Banded shape) = shape + + +_fromUnitBandedTriangular :: + (BandedTriangular sub super, BandedTriangular super sub) => + Layout.Banded sub super Shape Small Small size size -> + Omni Packed Unit (Bands sub) (Bands super) Shape Small Small size size +_fromUnitBandedTriangular = UnitBandedTriangular + +_toUnitBandedTriangular :: + (BandedTriangular sub super, BandedTriangular super sub) => + Omni Packed Unit (Bands sub) (Bands super) Shape Small Small size size -> + Layout.Banded sub super Shape Small Small size size +_toUnitBandedTriangular (UnitBandedTriangular shape) = shape + + +_fromBandedHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + Layout.BandedHermitian offDiag size -> + Omni Packed (Hermitian neg zero pos) + (Bands offDiag) (Bands offDiag) Shape Small Small size size +_fromBandedHermitian = BandedHermitian + +toBandedHermitian :: + (TBool.C neg, TBool.C zero, TBool.C pos, Unary.Natural offDiag) => + Omni Packed (Hermitian neg zero pos) + (Bands offDiag) (Bands offDiag) Shape Small Small size size -> + Layout.BandedHermitian offDiag size +toBandedHermitian (BandedHermitian shape) = shape + + + +height :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni pack property lower upper meas vert horiz height width -> height +height omni = + case omni of + Full shape -> Layout.fullHeight shape + UpperTriangular shape -> Layout.mosaicSize shape + LowerTriangular shape -> Layout.mosaicSize shape + Symmetric shape -> Layout.mosaicSize shape + Hermitian shape -> Layout.mosaicSize shape + Banded shape -> Layout.bandedHeight shape + UnitBandedTriangular shape -> Layout.bandedHeight shape + BandedHermitian shape -> Layout.bandedHermitianSize shape + +width :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni pack property lower upper meas vert horiz height width -> width +width omni = + case omni of + Full shape -> Layout.fullWidth shape + UpperTriangular shape -> Layout.mosaicSize shape + LowerTriangular shape -> Layout.mosaicSize shape + Symmetric shape -> Layout.mosaicSize shape + Hermitian shape -> Layout.mosaicSize shape + Banded shape -> Layout.bandedWidth shape + UnitBandedTriangular shape -> Layout.bandedWidth shape + BandedHermitian shape -> Layout.bandedHermitianSize shape + +squareSize :: Omni pack property lower upper Shape Small Small sh sh -> sh +squareSize = height + +extent :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni pack property lower upper meas vert horiz height width -> + Extent meas vert horiz height width +extent omni = + case omni of + Full shape -> Layout.fullExtent shape + UpperTriangular shape -> Extent.square $ Layout.mosaicSize shape + LowerTriangular shape -> Extent.square $ Layout.mosaicSize shape + Symmetric shape -> Extent.square $ Layout.mosaicSize shape + Hermitian shape -> Extent.square $ Layout.mosaicSize shape + Banded shape -> Layout.bandedExtent shape + UnitBandedTriangular shape -> Layout.bandedExtent shape + BandedHermitian shape -> + Extent.square $ Layout.bandedHermitianSize shape + + +mapExtentUnchecked :: + (Extent Size vertA horizA heightA widthA -> + Extent Size vertB horizB heightB widthB) -> + Omni pack property lower upper Size vertA horizA heightA widthA -> + Omni pack property lower upper Size vertB horizB heightB widthB +mapExtentUnchecked f omni = + case omni of + Full shape@Layout.Full{Layout.fullExtent = ext} -> + Full shape{Layout.fullExtent = f ext} + Banded shape@Layout.Banded{Layout.bandedExtent = ext} -> + Banded shape{Layout.bandedExtent = f ext} + +mapHeight :: + (Shape.C heightA, Shape.C heightB, Extent.C vert, Extent.C horiz) => + (heightA -> heightB) -> + Omni pack property lower upper Size vert horiz heightA width -> + Omni pack property lower upper Size vert horiz heightB width +mapHeight f = + mapExtentUnchecked $ Extent.mapHeight $ Layout.mapChecked "mapHeight" f + +mapWidth :: + (Shape.C widthA, Shape.C widthB, Extent.C vert, Extent.C horiz) => + (widthA -> widthB) -> + Omni pack property lower upper Size vert horiz height widthA -> + Omni pack property lower upper Size vert horiz height widthB +mapWidth f = + mapExtentUnchecked $ Extent.mapWidth $ Layout.mapChecked "mapWidth" f + +mapSquareSize :: + (Shape.C shA, Shape.C shB) => + (shA -> shB) -> + Omni pack property lower upper Shape Small Small shA shA -> + Omni pack property lower upper Shape Small Small shB shB +mapSquareSize f omni = + let cf = Layout.mapChecked "mapSquareSize" f in + case omni of + Full shape@Layout.Full{Layout.fullExtent = ext} -> + Full shape{Layout.fullExtent = Extent.mapSquareSize cf ext} + UpperTriangular shape@Layout.Mosaic{Layout.mosaicSize = size} -> + UpperTriangular shape{Layout.mosaicSize = cf size} + LowerTriangular shape@Layout.Mosaic{Layout.mosaicSize = size} -> + LowerTriangular shape{Layout.mosaicSize = cf size} + Symmetric shape@Layout.Mosaic{Layout.mosaicSize = size} -> + Symmetric shape{Layout.mosaicSize = cf size} + Hermitian shape@Layout.Mosaic{Layout.mosaicSize = size} -> + Hermitian shape{Layout.mosaicSize = cf size} + Banded shape@Layout.Banded{Layout.bandedExtent = ext} -> + Banded shape{Layout.bandedExtent = Extent.mapSquareSize cf ext} + UnitBandedTriangular shape@Layout.Banded{Layout.bandedExtent = ext} -> + UnitBandedTriangular + shape{Layout.bandedExtent = Extent.mapSquareSize cf ext} + BandedHermitian + shape@Layout.BandedHermitian{Layout.bandedHermitianSize = size} -> + BandedHermitian shape{Layout.bandedHermitianSize = cf size} + + +order :: + Omni pack property lower upper meas vert horiz height width -> + Layout.Order +order omni = + case omni of + Full shape -> Layout.fullOrder shape + UpperTriangular shape -> Layout.mosaicOrder shape + LowerTriangular shape -> Layout.mosaicOrder shape + Symmetric shape -> Layout.mosaicOrder shape + Hermitian shape -> Layout.mosaicOrder shape + Banded shape -> Layout.bandedOrder shape + UnitBandedTriangular shape -> Layout.bandedOrder shape + BandedHermitian shape -> Layout.bandedHermitianOrder shape + +_forceOrderDiagonal :: + Layout.Order -> + Omni Packed property Empty Empty meas vert horiz height width -> + Omni Packed property Empty Empty meas vert horiz height width +_forceOrderDiagonal newOrder omni = + case omni of + Banded sh -> + Banded sh{Layout.bandedOrder = newOrder} + BandedHermitian sh -> + BandedHermitian sh{Layout.bandedHermitianOrder = newOrder} + UnitBandedTriangular sh -> + UnitBandedTriangular sh{Layout.bandedOrder = newOrder} + + +transpose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Omni pack property lower upper meas vert horiz height width -> + Omni pack property upper lower meas horiz vert width height +transpose (Full shape) = + Full (Layout.transpose shape) +transpose (UpperTriangular shape) = + LowerTriangular (Layout.triangularTranspose shape) +transpose (LowerTriangular shape) = + UpperTriangular (Layout.triangularTranspose shape) +transpose (Symmetric shape) = Symmetric shape +transpose (Hermitian shape) = Hermitian shape +transpose (Banded shape) = + Banded (Layout.bandedTranspose shape) +transpose (UnitBandedTriangular shape) = + UnitBandedTriangular (Layout.bandedTranspose shape) +transpose (BandedHermitian shape) = + BandedHermitian shape + + +instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Shape.C + (Omni pack property lower upper meas vert horiz height width) where + + size omni = + case omni of + Full shape -> Shape.size shape + UpperTriangular shape -> Shape.size shape + LowerTriangular shape -> Shape.size shape + Symmetric shape -> Shape.size shape + Hermitian shape -> Shape.size shape + Banded shape -> Shape.size shape + UnitBandedTriangular shape -> Shape.size shape + BandedHermitian shape -> Shape.size shape + + + +type family MultipliedBands bandsA bandsB +type instance MultipliedBands Filled bandsB = Filled +type instance MultipliedBands (Bands k) Filled = Filled +type instance MultipliedBands (Bands k) (Bands l) = Bands (k Unary.:+: l) + +type family MultipliedStrip contA contB +type instance MultipliedStrip Filled contB = Filled +type instance MultipliedStrip Empty contB = contB + +type family MultipliedProperty propA propB +type instance MultipliedProperty Arbitrary propB = Arbitrary +type instance MultipliedProperty Symmetric propB = Arbitrary +type instance MultipliedProperty (Hermitian neg zero pos) propB = Arbitrary +type instance MultipliedProperty Unit Arbitrary = Arbitrary +type instance MultipliedProperty Unit Symmetric = Arbitrary +type instance MultipliedProperty Unit (Hermitian neg zero pos) = Arbitrary +type instance MultipliedProperty Unit Unit = Unit + +type family UnitIfTriangular lower upper +type instance UnitIfTriangular Empty upper = Unit +type instance UnitIfTriangular Filled Empty = Unit +type instance UnitIfTriangular Filled Filled = Arbitrary +type instance UnitIfTriangular Filled (Bands (Unary.Succ k)) = Arbitrary +type instance UnitIfTriangular (Bands (Unary.Succ k)) Empty = Unit +type instance UnitIfTriangular (Bands (Unary.Succ k)) Filled = Arbitrary +type instance UnitIfTriangular (Bands (Unary.Succ k)) (Bands (Unary.Succ l)) = + Arbitrary + +type family MergeUnit unit0 unit1 +type instance MergeUnit Unit unit1 = unit1 +type instance MergeUnit Arbitrary unit1 = Arbitrary diff --git a/src/Numeric/LAPACK/Matrix/Shape/Private.hs b/src/Numeric/LAPACK/Matrix/Shape/Private.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Shape/Private.hs +++ /dev/null @@ -1,1065 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Numeric.LAPACK.Matrix.Shape.Private where - -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Extent.Private (Extent) -import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) - -import qualified Type.Data.Num.Unary.Literal as TypeNum -import qualified Type.Data.Num.Unary.Proof as Proof -import qualified Type.Data.Num.Unary as Unary -import Type.Data.Num.Unary (unary, (:+:)) -import Type.Data.Num (integralFromProxy) -import Type.Base.Proxy (Proxy(Proxy)) - -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape (triangleSize, triangleRoot) - -import Control.DeepSeq (NFData, rnf) -import Control.Applicative (Const(Const, getConst)) - -import Data.Functor.Identity (Identity(Identity), runIdentity) -import Data.List (tails) -import Data.Tuple.HT (mapSnd, swap, double) -import Data.Bool.HT (if') - - -data Order = RowMajor | ColumnMajor - deriving (Eq, Show) - -instance NFData Order where - rnf RowMajor = () - rnf ColumnMajor = () - -flipOrder :: Order -> Order -flipOrder RowMajor = ColumnMajor -flipOrder ColumnMajor = RowMajor - -transposeFromOrder :: Order -> Char -transposeFromOrder RowMajor = 'T' -transposeFromOrder ColumnMajor = 'N' - -swapOnRowMajor :: Order -> (a,a) -> (a,a) -swapOnRowMajor order = - case order of - RowMajor -> swap - ColumnMajor -> id - -sideSwapFromOrder :: Order -> (a,a) -> (Char, (a,a)) -sideSwapFromOrder order (m0,n0) = - let ((side,m), (_,n)) = swapOnRowMajor order (('L', m0), ('R', n0)) - in (side,(m,n)) - - -mapChecked :: - (Shape.C sha, Shape.C shb) => - String -> (sha -> shb) -> sha -> shb -mapChecked name f sizeA = - let sizeB = f sizeA - in if Shape.size sizeA == Shape.size sizeB - then sizeB - else error $ name ++ ": sizes mismatch" - - -data Full vert horiz height width = - Full { - fullOrder :: Order, - fullExtent :: Extent vert horiz height width - } deriving (Eq, Show) - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Box.Box (Full vert horiz height width) where - type HeightOf (Full vert horiz height width) = height - type WidthOf (Full vert horiz height width) = width - height = fullHeight - width = fullWidth - -instance - (Extent.C vert, Extent.C horiz, NFData height, NFData width) => - NFData (Full vert horiz height width) where - rnf (Full order extent) = rnf (order, extent) - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Shape.C (Full vert horiz height width) where - - size (Full _ extent) = Shape.size (Extent.dimensions extent) - uncheckedSize (Full _ extent) = - Shape.uncheckedSize (Extent.dimensions extent) - -instance - (Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => - Shape.Indexed (Full vert horiz height width) where - - type Index (Full vert horiz height width) = - (Shape.Index height, Shape.Index width) - indices (Full order extent) = fullIndices order extent - - offset (Full RowMajor extent) = - Shape.offset (Extent.dimensions extent) - offset (Full ColumnMajor extent) = - Shape.offset (swap $ Extent.dimensions extent) . swap - uncheckedOffset (Full RowMajor extent) = - Shape.uncheckedOffset (Extent.dimensions extent) - uncheckedOffset (Full ColumnMajor extent) = - Shape.uncheckedOffset (swap $ Extent.dimensions extent) . swap - - sizeOffset (Full RowMajor extent) = - Shape.sizeOffset (Extent.dimensions extent) - sizeOffset (Full ColumnMajor extent) = - mapSnd (.swap) $ Shape.sizeOffset (swap $ Extent.dimensions extent) - uncheckedSizeOffset (Full RowMajor extent) = - Shape.uncheckedSizeOffset (Extent.dimensions extent) - uncheckedSizeOffset (Full ColumnMajor extent) = - mapSnd (.swap) $ - Shape.uncheckedSizeOffset (swap $ Extent.dimensions extent) - - inBounds (Full _ extent) = Shape.inBounds (Extent.dimensions extent) - -instance - (Extent.C vert, Extent.C horiz, - Shape.InvIndexed height, Shape.InvIndexed width) => - Shape.InvIndexed (Full vert horiz height width) where - - indexFromOffset (Full order extent) = fullIndexFromOffset order extent - - -transpose :: - (Extent.C vert, Extent.C horiz) => - Full vert horiz height width -> Full horiz vert width height -transpose (Full order extent) = Full (flipOrder order) (Extent.transpose extent) - -dimensions :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Full vert horiz height width -> (Int, Int) -dimensions (Full order extent) = - swapOnRowMajor order - (Shape.size $ Extent.height extent, - Shape.size $ Extent.width extent) - -fullHeight :: - (Extent.C vert, Extent.C horiz) => Full vert horiz height width -> height -fullHeight = Extent.height . fullExtent - -fullWidth :: - (Extent.C vert, Extent.C horiz) => Full vert horiz height width -> width -fullWidth = Extent.width . fullExtent - - -fullIndices :: - (Extent.C vert, Extent.C horiz, Shape.Indexed a, Shape.Indexed b) => - Order -> Extent vert horiz a b -> [(Shape.Index a, Shape.Index b)] -fullIndices order extent = - case order of - RowMajor -> Shape.indices $ Extent.dimensions extent - ColumnMajor -> map swap $ Shape.indices $ swap $ Extent.dimensions extent - -fullIndexFromOffset :: - (Extent.C vert, Extent.C horiz, Shape.InvIndexed a, Shape.InvIndexed b) => - Order -> Extent vert horiz a b -> Int -> - (Shape.Index a, Shape.Index b) -fullIndexFromOffset order extent = - case order of - RowMajor -> - Shape.indexFromOffset (Extent.dimensions extent) - ColumnMajor -> - swap . Shape.indexFromOffset (swap $ Extent.dimensions extent) - - -type General height width = Full Extent.Big Extent.Big height width -type Tall height width = Full Extent.Big Extent.Small height width -type Wide height width = Full Extent.Small Extent.Big height width -type Square size = Full Extent.Small Extent.Small size size - - -fullMapExtent :: - Extent.Map vertA horizA vertB horizB height width -> - Full vertA horizA height width -> - Full vertB horizB height width -fullMapExtent f (Full order extent) = Full order $ Extent.apply f extent - -general :: Order -> height -> width -> General height width -general order height width = Full order $ Extent.general height width - -tall :: - (Shape.C height, Shape.C width) => - Order -> height -> width -> Tall height width -tall order height width = - if Shape.size height >= Shape.size width - then Full order $ Extent.tall height width - else error "MatrixShape.tall: height smaller than width" - -wide :: - (Shape.C height, Shape.C width) => - Order -> height -> width -> Wide height width -wide order height width = - if Shape.size height <= Shape.size width - then Full order $ Extent.wide height width - else error "MatrixShape.wide: width smaller than height" - -square :: Order -> sh -> Square sh -square order sh = Full order $ Extent.square sh - - -caseTallWide :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Full vert horiz height width -> - Either (Tall height width) (Wide height width) -caseTallWide (Full order extent) = - either (Left . Full order) (Right . Full order) $ - Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent - - -data Split lower vert horiz height width = - Split { - splitLower :: lower, - splitOrder :: Order, - splitExtent :: Extent vert horiz height width - } deriving (Eq, Show) - -splitHeight :: - (Extent.C vert, Extent.C horiz) => - Split lower vert horiz height width -> height -splitHeight = Extent.height . splitExtent - -splitWidth :: - (Extent.C vert, Extent.C horiz) => - Split lower vert horiz height width -> width -splitWidth = Extent.width . splitExtent - -splitMapExtent :: - Extent.Map vertA horizA vertB horizB height width -> - Split lower vertA horizA height width -> - Split lower vertB horizB height width -splitMapExtent f (Split lowerPart order extent) = - Split lowerPart order $ Extent.apply f extent - - -caseTallWideSplit :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Split lower vert horiz height width -> - Either - (Split lower Extent.Big Extent.Small height width) - (Split lower Extent.Small Extent.Big height width) -caseTallWideSplit (Split lowerPart order extent) = - either (Left . Split lowerPart order) (Right . Split lowerPart order) $ - Extent.caseTallWide (\h w -> Shape.size h >= Shape.size w) extent - -instance - (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Box.Box (Split lower vert horiz height width) where - type HeightOf (Split lower vert horiz height width) = height - type WidthOf (Split lower vert horiz height width) = width - height = splitHeight - width = splitWidth - -data Reflector = Reflector deriving (Eq, Show) -data Triangle = Triangle deriving (Eq, Show) - -instance NFData Reflector where rnf Reflector = () -instance NFData Triangle where rnf Triangle = () - -splitPart :: - (Extent.C vert, Extent.C horiz, - Shape.Indexed height, Shape.Indexed width) => - Split lower vert horiz height width -> - (Shape.Index height, Shape.Index width) -> Either lower Triangle -splitPart (Split lowerPart _ extent) (r,c) = - if Shape.offset (Extent.height extent) r > - Shape.offset (Extent.width extent) c - then Left lowerPart - else Right Triangle - -instance - (NFData lower, Extent.C vert, Extent.C horiz, NFData height, NFData width) => - NFData (Split lower vert horiz height width) where - rnf (Split lowerPart order extent) = rnf (lowerPart, order, extent) - -instance - (Eq lower, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Shape.C (Split lower vert horiz height width) where - - size (Split _ _ extent) = Shape.size (Extent.dimensions extent) - uncheckedSize (Split _ _ extent) = - Shape.uncheckedSize (Extent.dimensions extent) - -instance - (Eq lower, Extent.C vert, Extent.C horiz, - Shape.Indexed height, Shape.Indexed width) => - Shape.Indexed (Split lower vert horiz height width) where - - type Index (Split lower vert horiz height width) = - (Either lower Triangle, - (Shape.Index height, Shape.Index width)) - - indices sh@(Split _ order extent) = - map (\ix -> (splitPart sh ix, ix)) $ fullIndices order extent - - offset sh@(Split _ order extent) (part,ix) = - if part == splitPart sh ix - then - case order of - RowMajor -> Shape.offset (Extent.dimensions extent) ix - ColumnMajor -> - Shape.offset (swap $ Extent.dimensions extent) (swap ix) - else error "Shape.Split.offset: wrong matrix part" - uncheckedOffset (Split _ RowMajor extent) = - Shape.uncheckedOffset (Extent.dimensions extent) . snd - uncheckedOffset (Split _ ColumnMajor extent) = - Shape.uncheckedOffset (swap $ Extent.dimensions extent) . swap . snd - - sizeOffset sh@(Split _ order extent) = - let check (part,ix) a = - if part == splitPart sh ix - then a - else error "Shape.Split.sizeOffset: wrong matrix part" - in case order of - RowMajor -> - mapSnd (\getOffset (part,ix) -> check (part,ix) $ getOffset ix) $ - Shape.sizeOffset (Extent.dimensions extent) - ColumnMajor -> - mapSnd - (\getOffset (part,ix) -> - check (part,ix) $ getOffset $ swap ix) $ - Shape.sizeOffset (swap $ Extent.dimensions extent) - uncheckedSizeOffset (Split _ RowMajor extent) = - mapSnd (.snd) $ Shape.uncheckedSizeOffset (Extent.dimensions extent) - uncheckedSizeOffset (Split _ ColumnMajor extent) = - mapSnd (.swap.snd) $ - Shape.uncheckedSizeOffset (swap $ Extent.dimensions extent) - - inBounds sh@(Split _ _ extent) (part,ix) = - Shape.inBounds (Extent.dimensions extent) ix - && - part == splitPart sh ix - -instance - (Eq lower, Extent.C vert, Extent.C horiz, - Shape.InvIndexed height, Shape.InvIndexed width) => - Shape.InvIndexed (Split lower vert horiz height width) where - - indexFromOffset sh@(Split _ order extent) k = - let ix = fullIndexFromOffset order extent k - in (splitPart sh ix, ix) - - -{- | -Store the upper triangular half of a real symmetric or complex Hermitian matrix. --} -data Hermitian size = - Hermitian { - hermitianOrder :: Order, - hermitianSize :: size - } deriving (Eq, Show) - -instance (Shape.C size) => Box.Box (Hermitian size) where - type HeightOf (Hermitian size) = size - type WidthOf (Hermitian size) = size - height = hermitianSize - width = hermitianSize - -hermitianFromSymmetric :: Symmetric size -> Hermitian size -hermitianFromSymmetric (Triangular _diag _uplo order size) = - Hermitian order size - -uploFromOrder :: Order -> Char -uploFromOrder RowMajor = 'L' -uploFromOrder ColumnMajor = 'U' - -instance (NFData size) => NFData (Hermitian size) where - rnf (Hermitian order size) = rnf (order, size) - -instance (Shape.C size) => Shape.C (Hermitian size) where - size (Hermitian _ size) = triangleSize $ Shape.size size - uncheckedSize (Hermitian _ size) = triangleSize $ Shape.uncheckedSize size - -instance (Shape.Indexed size) => Shape.Indexed (Hermitian size) where - type Index (Hermitian size) = (Shape.Index size, Shape.Index size) - - indices (Hermitian order size) = triangleIndices order size - - offset (Hermitian order size) = triangleOffset order size - uncheckedOffset (Hermitian order size) = - triangleUncheckedOffset order size - - sizeOffset (Hermitian order size) = triangleSizeOffset order size - uncheckedSizeOffset (Hermitian order size) = - triangleUncheckedSizeOffset order size - - inBounds (Hermitian _ size) ix@(r,c) = - Shape.inBounds (size,size) ix - && - Shape.offset size r <= Shape.offset size c - -instance (Shape.InvIndexed size) => Shape.InvIndexed (Hermitian size) where - indexFromOffset (Hermitian order size) k = - triangleIndexFromOffset order size k - - - -data Triangular lo diag up size = - Triangular { - triangularDiag :: diag, - triangularUplo :: (lo,up), - triangularOrder :: Order, - triangularSize :: size - } deriving (Eq, Show) - -instance - (Content lo, TriDiag diag, Content up, Shape.C size) => - Box.Box (Triangular lo diag up size) where - type HeightOf (Triangular lo diag up size) = size - type WidthOf (Triangular lo diag up size) = size - height = triangularSize - width = triangularSize - -symmetricFromHermitian :: Hermitian size -> Symmetric size -symmetricFromHermitian (Hermitian order size) = - Triangular NonUnit autoUplo order size - - -data Unit = Unit deriving (Eq, Show) -data NonUnit = NonUnit deriving (Eq, Show) - -class TriDiag diag where switchTriDiag :: f Unit -> f NonUnit -> f diag -instance TriDiag Unit where switchTriDiag f _ = f -instance TriDiag NonUnit where switchTriDiag _ f = f - -autoDiag :: TriDiag diag => diag -autoDiag = runIdentity $ switchTriDiag (Identity Unit) (Identity NonUnit) - -caseTriDiag :: TriDiag diag => diag -> a -> a -> a -caseTriDiag diag unit nonUnit = - getConstAs diag $ switchTriDiag (Const unit) (Const nonUnit) - -charFromTriDiag :: TriDiag diag => diag -> Char -charFromTriDiag diag = caseTriDiag diag 'U' 'N' - - -relaxUnitDiagonal :: - (TriDiag diag) => Triangular lo Unit up sh -> Triangular lo diag up sh -relaxUnitDiagonal shape = shape{triangularDiag = autoDiag} - -strictNonUnitDiagonal :: - (TriDiag diag) => Triangular lo diag up sh -> Triangular lo NonUnit up sh -strictNonUnitDiagonal shape = shape{triangularDiag = NonUnit} - - -data Empty = Empty deriving (Eq, Show) -data Filled = Filled deriving (Eq, Show) - -lower :: (Filled,Empty) -lower = (Filled,Empty) - -upper :: (Empty,Filled) -upper = (Empty,Filled) - -type Identity = Triangular Empty Unit Empty -type Diagonal = Triangular Empty NonUnit Empty -type LowerTriangular diag = Triangular Filled diag Empty -type UpperTriangular diag = Triangular Empty diag Filled -type FlexSymmetric diag = Triangular Filled diag Filled -type Symmetric = FlexSymmetric NonUnit - -triangularTranspose :: - (Content lo, Content up) => - Triangular lo diag up sh -> Triangular up diag lo sh -triangularTranspose (Triangular diag uplo order size) = - Triangular diag - (swap uplo) - (caseDiagUpLoSym uplo flipOrder flipOrder flipOrder id order) - size - - -class Content c where switchContent :: f Empty -> f Filled -> f c -instance Content Empty where switchContent f _ = f -instance Content Filled where switchContent _ f = f - - -type UpLo lo up = (UpLoC lo up, UpLoC up lo) - -class (DiagUpLoC lo up, UpLoSymC lo up) => UpLoC lo up where - switchUpLo :: f Empty Filled -> f Filled Empty -> f lo up - -instance UpLoC Empty Filled where switchUpLo f _ = f -instance UpLoC Filled Empty where switchUpLo _ f = f - - -type DiagUpLo lo up = (DiagUpLoC lo up, DiagUpLoC up lo) - -class (Content lo, Content up) => DiagUpLoC lo up where - switchDiagUpLo :: - f Empty Empty -> f Empty Filled -> f Filled Empty -> f lo up - -instance DiagUpLoC Empty Empty where switchDiagUpLo f _ _ = f -instance DiagUpLoC Empty Filled where switchDiagUpLo _ f _ = f -instance DiagUpLoC Filled Empty where switchDiagUpLo _ _ f = f - - -type UpLoSym lo up = (UpLoSymC lo up, UpLoSymC up lo) - -class (Content lo, Content up) => UpLoSymC lo up where - switchUpLoSym :: - f Empty Filled -> f Filled Empty -> f Filled Filled -> f lo up - -instance UpLoSymC Empty Filled where switchUpLoSym f _ _ = f -instance UpLoSymC Filled Empty where switchUpLoSym _ f _ = f -instance UpLoSymC Filled Filled where switchUpLoSym _ _ f = f - - -switchDiagUpLoSym :: - (Content lo, Content up) => - f Empty Empty -> f Empty Filled -> f Filled Empty -> f Filled Filled -> - f lo up -switchDiagUpLoSym fDiag fUpper fLower fSymm = - getFlip $ - switchContent - (Flip $ switchContent fDiag fUpper) - (Flip $ switchContent fLower fSymm) - -autoContent :: Content c => c -autoContent = runIdentity $ switchContent (Identity Empty) (Identity Filled) - -autoUplo :: (Content lo, Content up) => (lo,up) -autoUplo = (autoContent,autoContent) - -uploOrder :: (Content lo, Content up) => (lo,up) -> Order -> Order -uploOrder (_loc,upc) = caseContent upc flipOrder id - -getConstAs :: c -> Const a c -> a -getConstAs _ = getConst - -caseContent :: Content c => c -> a -> a -> a -caseContent c lo up = - getConstAs c $ switchContent (Const lo) (Const up) - -caseLoUp :: UpLo lo up => (lo,up) -> a -> a -> a -caseLoUp (_loc,upc) = caseContent upc - -caseDiagUpLoSym :: (Content lo, Content up) => (lo,up) -> a -> a -> a -> a -> a -caseDiagUpLoSym (loc,upc) diag up lo symm = - caseContent loc - (caseContent upc diag up) - (caseContent upc lo symm) - - -newtype Const2 a lo up = Const2 {getConst2 :: a} - -getContentConst2 :: (lo,up) -> Const2 a lo up -> a -getContentConst2 _ = getConst2 - -caseUpLoSym :: (UpLoSym lo up) => (lo,up) -> a -> a -> a -> a -caseUpLoSym c lo up sym = - getContentConst2 c $ switchUpLoSym (Const2 lo) (Const2 up) (Const2 sym) - - -instance - (Content lo, TriDiag diag, Content up, NFData size) => - NFData (Triangular lo diag up size) where - rnf (Triangular diag (loc,upc) order size) = - rnf - (flip getFlip diag $ - switchTriDiag (Flip $ \Unit -> ()) (Flip $ \NonUnit -> ()), - let rnfContent c = - flip getFlip c $ - switchContent - (Flip $ \Empty -> ()) - (Flip $ \Filled -> ()) - in (rnfContent loc, rnfContent upc), - order, size) - -instance - (Content lo, TriDiag diag, Content up, Shape.C size) => - Shape.C (Triangular lo diag up size) where - - size (Triangular _diag uplo _ size) = - let n = Shape.size size - in caseDiagUpLoSym uplo n - (triangleSize n) - (triangleSize n) - (triangleSize n) - uncheckedSize (Triangular _diag uplo _ size) = - let n = Shape.uncheckedSize size - in caseDiagUpLoSym uplo n - (triangleSize n) - (triangleSize n) - (triangleSize n) - -instance - (Content lo, TriDiag diag, Content up, Shape.Indexed size) => - Shape.Indexed (Triangular lo diag up size) where - type Index (Triangular lo diag up size) = - (Shape.Index size, Shape.Index size) - - indices (Triangular _diag uplo order size) = - caseDiagUpLoSym uplo - (map double $ Shape.indices size) - (triangleIndices order size) - (map swap $ triangleIndices (flipOrder order) size) - (triangleIndices order size) - - offset (Triangular _diag uplo order size) = - caseDiagUpLoSym uplo - (Shape.offset size . snd) - (triangleOffset order size) - (triangleOffset (flipOrder order) size . swap) - (triangleOffset order size) - uncheckedOffset (Triangular _diag uplo order size) = - caseDiagUpLoSym uplo - (Shape.offset size . snd) - (triangleUncheckedOffset order size) - (triangleUncheckedOffset (flipOrder order) size . swap) - (triangleUncheckedOffset order size) - - sizeOffset (Triangular _diag uplo order size) = - caseDiagUpLoSym uplo - (mapSnd (.snd) $ Shape.sizeOffset size) - (triangleSizeOffset order size) - (mapSnd (.swap) $ triangleSizeOffset (flipOrder order) size) - (triangleSizeOffset order size) - uncheckedSizeOffset (Triangular _diag uplo order size) = - caseDiagUpLoSym uplo - (mapSnd (.snd) $ Shape.uncheckedSizeOffset size) - (triangleUncheckedSizeOffset order size) - (mapSnd (.swap) $ triangleUncheckedSizeOffset (flipOrder order) size) - (triangleUncheckedSizeOffset order size) - - inBounds (Triangular _diag uplo _ size) ix@(r,c) = - Shape.inBounds (size,size) ix - && - caseDiagUpLoSym uplo - (Shape.offset size r == Shape.offset size c) - (Shape.offset size r <= Shape.offset size c) - (Shape.offset size r >= Shape.offset size c) - (Shape.offset size r <= Shape.offset size c) - -instance - (Content lo, TriDiag diag, Content up, Shape.InvIndexed size) => - Shape.InvIndexed (Triangular lo diag up size) where - - indexFromOffset (Triangular _diag uplo order size) k = - caseDiagUpLoSym uplo - (double $ Shape.indexFromOffset size k) - (triangleIndexFromOffset order size k) - (swap $ triangleIndexFromOffset (flipOrder order) size k) - (triangleIndexFromOffset order size k) - - -triangleRootDouble :: Int -> Double -triangleRootDouble = triangleRoot . fromIntegral - -triangleExtent :: String -> Int -> Int -triangleExtent name size = - let n = round $ triangleRootDouble size - in if size == triangleSize n - then n - else error (name ++ ": no triangular number of elements") - -triangleIndices :: - (Shape.Indexed sh) => Order -> sh -> [(Shape.Index sh, Shape.Index sh)] -triangleIndices RowMajor = Shape.indices . Shape.upperTriangular -triangleIndices ColumnMajor = map swap . Shape.indices . Shape.lowerTriangular - -triangleOffset :: - (Shape.Indexed sh) => Order -> sh -> (Shape.Index sh, Shape.Index sh) -> Int -triangleOffset order size = - case order of - RowMajor -> Shape.offset (Shape.upperTriangular size) - ColumnMajor -> Shape.offset (Shape.lowerTriangular size) . swap - -triangleUncheckedOffset :: - (Shape.Indexed sh) => Order -> sh -> (Shape.Index sh, Shape.Index sh) -> Int -triangleUncheckedOffset order size = - case order of - RowMajor -> Shape.uncheckedOffset (Shape.upperTriangular size) - ColumnMajor -> Shape.uncheckedOffset (Shape.lowerTriangular size) . swap - -triangleSizeOffset :: - (Shape.Indexed sh) => - Order -> sh -> (Int, (Shape.Index sh, Shape.Index sh) -> Int) -triangleSizeOffset order size = - case order of - RowMajor -> Shape.sizeOffset (Shape.upperTriangular size) - ColumnMajor -> - mapSnd (.swap) $ Shape.sizeOffset (Shape.lowerTriangular size) - -triangleUncheckedSizeOffset :: - (Shape.Indexed sh) => - Order -> sh -> (Int, (Shape.Index sh, Shape.Index sh) -> Int) -triangleUncheckedSizeOffset order size = - case order of - RowMajor -> Shape.uncheckedSizeOffset (Shape.upperTriangular size) - ColumnMajor -> - mapSnd (.swap) $ Shape.uncheckedSizeOffset (Shape.lowerTriangular size) - -triangleIndexFromOffset :: - (Shape.InvIndexed sh) => - Order -> sh -> Int -> (Shape.Index sh, Shape.Index sh) -triangleIndexFromOffset order size = - case order of - RowMajor -> Shape.indexFromOffset (Shape.upperTriangular size) - ColumnMajor -> swap . Shape.indexFromOffset (Shape.lowerTriangular size) - - -type UnaryProxy a = Proxy (Unary.Un a) - -data Banded sub super vert horiz height width = - Banded { - bandedOffDiagonals :: (UnaryProxy sub, UnaryProxy super), - bandedOrder :: Order, - bandedExtent :: Extent vert horiz height width - } deriving (Eq, Show) - -type BandedGeneral sub super = Banded sub super Extent.Big Extent.Big -type BandedSquare sub super size = - Banded sub super Extent.Small Extent.Small size size - -type BandedLowerTriangular sub size = BandedSquare sub TypeNum.U0 size -type BandedUpperTriangular super size = BandedSquare TypeNum.U0 super size - -type BandedDiagonal size = BandedSquare TypeNum.U0 TypeNum.U0 size - - -bandedHeight :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width -> height -bandedHeight = Extent.height . bandedExtent - -bandedWidth :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width -> width -bandedWidth = Extent.width . bandedExtent - -bandedMapExtent :: - Extent.Map vertA horizA vertB horizB height width -> - Banded sub super vertA horizA height width -> - Banded sub super vertB horizB height width -bandedMapExtent f (Banded numDiag order extent) = - Banded numDiag order $ Extent.apply f extent - -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width) => - Box.Box (Banded sub super vert horiz height width) where - type HeightOf (Banded sub super vert horiz height width) = height - type WidthOf (Banded sub super vert horiz height width) = width - height = bandedHeight - width = bandedWidth - -bandedBreadth :: - (Unary.Natural sub, Unary.Natural super) => - (UnaryProxy sub, UnaryProxy super) -> Int -bandedBreadth (sub,super) = - integralFromProxy sub + 1 + integralFromProxy super - -numOffDiagonals :: - (Unary.Natural sub, Unary.Natural super) => - Order -> (UnaryProxy sub, UnaryProxy super) -> (Int,Int) -numOffDiagonals order (sub,super) = - swapOnRowMajor order (integralFromProxy sub, integralFromProxy super) - -natFromProxy :: (Unary.Natural n) => UnaryProxy n -> Proof.Nat n -natFromProxy Proxy = Proof.Nat - -addOffDiagonals :: - (Unary.Natural subA, Unary.Natural superA, - Unary.Natural subB, Unary.Natural superB, - (subA :+: subB) ~ subC, - (superA :+: superB) ~ superC) => - (UnaryProxy subA, UnaryProxy superA) -> - (UnaryProxy subB, UnaryProxy superB) -> - ((Proof.Nat subC, Proof.Nat superC), - (UnaryProxy subC, UnaryProxy superC)) -addOffDiagonals (subA,superA) (subB,superB) = - ((Proof.addNat (natFromProxy subA) (natFromProxy subB), - Proof.addNat (natFromProxy superA) (natFromProxy superB)), - (Proxy,Proxy)) - -bandedTranspose :: - (Extent.C vert, Extent.C horiz) => - Banded sub super vert horiz height width -> - Banded super sub horiz vert width height -bandedTranspose (Banded (sub,super) order extent) = - Banded (super,sub) (flipOrder order) (Extent.transpose extent) - - -bandedGeneral :: - (UnaryProxy sub, UnaryProxy super) -> Order -> height -> width -> - Banded sub super Extent.Big Extent.Big height width -bandedGeneral offDiag order height width = - Banded offDiag order (Extent.general height width) - -bandedSquare :: - (UnaryProxy sub, UnaryProxy super) -> Order -> size -> - Banded sub super Extent.Small Extent.Small size size -bandedSquare offDiag order = Banded offDiag order . Extent.square - - -data BandedIndex row column = - InsideBox row column - | VertOutsideBox Int column - | HorizOutsideBox row Int - deriving (Eq, Show) - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, NFData height, NFData width) => - NFData (Banded sub super vert horiz height width) where - rnf (Banded (Proxy,Proxy) order extent) = rnf (order, extent) - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Shape.C (Banded sub super vert horiz height width) where - - size (Banded offDiag order extent) = - bandedBreadth offDiag * - case order of - RowMajor -> Shape.size (Extent.height extent) - ColumnMajor -> Shape.size (Extent.width extent) - uncheckedSize (Banded offDiag order extent) = - bandedBreadth offDiag * - case order of - RowMajor -> Shape.uncheckedSize (Extent.height extent) - ColumnMajor -> Shape.uncheckedSize (Extent.width extent) - -instance - (Unary.Natural sub, Unary.Natural super, - Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => - Shape.Indexed (Banded sub super vert horiz height width) where - - type Index (Banded sub super vert horiz height width) = - BandedIndex (Shape.Index height) (Shape.Index width) - indices (Banded (sub,super) order extent) = - let (height,width) = Extent.dimensions extent - in case order of - RowMajor -> - map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ - bandedIndicesRowMajor (sub,super) (height,width) - ColumnMajor -> - map (\(c,r) -> - either (flip VertOutsideBox c) (flip InsideBox c) r) $ - bandedIndicesRowMajor (super,sub) (width,height) - - offset shape ix = - if Shape.inBounds shape ix - then Shape.uncheckedOffset shape ix - else error "Banded.offset: index outside band" - - uncheckedOffset (Banded (sub,super) order extent) ix = - let (height,width) = Extent.dimensions extent - kl = integralFromProxy sub - ku = integralFromProxy super - in bandedOffset (kl,ku) order (height,width) ix - - inBounds (Banded (sub,super) order extent) ix = - let (height,width) = Extent.dimensions extent - kl = integralFromProxy sub - ku = integralFromProxy super - insideBand r c = Shape.inBounds (Shape.Range (-kl) ku) (c-r) - in case (order,ix) of - (_, InsideBox r c) -> - Shape.inBounds (height,width) (r,c) - && - insideBand (Shape.offset height r) (Shape.offset width c) - (RowMajor, HorizOutsideBox r c) -> - Shape.inBounds height r - && - insideBand (Shape.offset height r) (outsideOffset width c) - (ColumnMajor, VertOutsideBox r c) -> - Shape.inBounds width c - && - insideBand (outsideOffset height r) (Shape.offset width c) - _ -> False - -instance - (Unary.Natural sub, Unary.Natural super, Extent.C vert, Extent.C horiz, - Shape.InvIndexed height, Shape.InvIndexed width) => - Shape.InvIndexed (Banded sub super vert horiz height width) where - - indexFromOffset (Banded (sub,super) order extent) j = - bandedIndexFromOffset - Shape.indexFromOffset Shape.indexFromOffset - (integralFromProxy sub, integralFromProxy super) order - (Extent.dimensions extent) j - - uncheckedIndexFromOffset (Banded (sub,super) order extent) j = - bandedIndexFromOffset - Shape.uncheckedIndexFromOffset Shape.uncheckedIndexFromOffset - (integralFromProxy sub, integralFromProxy super) order - (Extent.dimensions extent) j - -outsideOffset :: Shape.C sh => sh -> Int -> Int -outsideOffset size k = if k<0 then k else Shape.size size + k - -bandedOffset :: - (Shape.Indexed height, Shape.Indexed width) => - (Int, Int) -> Order -> (height, width) -> - BandedIndex (Shape.Index height) (Shape.Index width) -> Int -bandedOffset (kl,ku) order (height,width) ix = - let k = kl+ku - in case ix of - InsideBox r c -> - let i = Shape.uncheckedOffset height r - j = Shape.uncheckedOffset width c - in case order of - RowMajor -> k*i + kl+j - ColumnMajor -> k*j + ku+i - VertOutsideBox r c -> - let i = outsideOffset height r - j = Shape.uncheckedOffset width c - in k*j + ku+i - HorizOutsideBox r c -> - let i = Shape.uncheckedOffset height r - j = outsideOffset width c - in k*i + kl+j - -bandedIndicesRowMajor :: - (Unary.Natural sub, Unary.Natural super, - Shape.Indexed height, Shape.Indexed width) => - (UnaryProxy sub, UnaryProxy super) -> - (height, width) -> - [(Shape.Index height, Either Int (Shape.Index width))] -bandedIndicesRowMajor (sub,super) (height,width) = - let kl = integralFromProxy sub - ku = integralFromProxy super - in concat $ - zipWith (\r -> map ((,) r)) (Shape.indices height) $ - map (take (kl+1+ku)) $ tails $ - (map Left $ take kl $ iterate (1+) (-kl)) ++ - (map Right $ Shape.indices width) ++ - (map Left $ iterate (1+) 0) - -bandedIndexFromOffset :: - (Shape.C height, Shape.C width) => - (height -> Int -> row) -> - (width -> Int -> column) -> - (Int,Int) -> Order -> (height,width) -> Int -> BandedIndex row column -bandedIndexFromOffset - rowFromOffset columnFromOffset (kl,ku) order (height,width) j = - case order of - RowMajor -> - let n = Shape.size width - (rb,cb) = divMod j (kl+1+ku) - r = rowFromOffset height rb - ci = rb+cb-kl - in if' (ci<0) (HorizOutsideBox r ci) $ - if' (ci>=n) (HorizOutsideBox r (ci-n)) $ - InsideBox r (columnFromOffset width ci) - ColumnMajor -> - let m = Shape.size height - (cb,rb) = divMod j (kl+1+ku) - c = columnFromOffset width cb - ri = rb+cb-ku - in if' (ri<0) (VertOutsideBox ri c) $ - if' (ri>=m) (VertOutsideBox (ri-m) c) $ - InsideBox (rowFromOffset height ri) c - - -data BandedHermitian off size = - BandedHermitian { - bandedHermitianOffDiagonals :: UnaryProxy off, - bandedHermitianOrder :: Order, - bandedHermitianSize :: size - } deriving (Eq, Show) - -instance - (Unary.Natural off, Shape.C size) => - Box.Box (BandedHermitian off size) where - type HeightOf (BandedHermitian off size) = size - type WidthOf (BandedHermitian off size) = size - height = bandedHermitianSize - width = bandedHermitianSize - -instance (Unary.Natural off, NFData size) => - NFData (BandedHermitian off size) where - rnf (BandedHermitian Proxy order size) = rnf (order, size) - -instance (Unary.Natural off, Shape.C size) => - Shape.C (BandedHermitian off size) where - size (BandedHermitian offDiag _order size) = - (1 + integralFromProxy offDiag) * Shape.size size - uncheckedSize (BandedHermitian offDiag _order size) = - (1 + integralFromProxy offDiag) * Shape.uncheckedSize size - -instance (Unary.Natural off, Shape.Indexed size) => - Shape.Indexed (BandedHermitian off size) where - type Index (BandedHermitian off size) = - BandedIndex (Shape.Index size) (Shape.Index size) - indices (BandedHermitian offDiag order size) = - case order of - RowMajor -> - map (\(r,c) -> either (HorizOutsideBox r) (InsideBox r) c) $ - bandedIndicesRowMajor (unary TypeNum.u0, offDiag) (size,size) - ColumnMajor -> - map (\(c,r) -> - either (flip VertOutsideBox c) (flip InsideBox c) r) $ - bandedIndicesRowMajor (offDiag, unary TypeNum.u0) (size,size) - - offset shape ix = - if Shape.inBounds shape ix - then Shape.uncheckedOffset shape ix - else error "BandedHermitian.offset: index outside band" - - uncheckedOffset (BandedHermitian offDiag order size) ix = - let k = integralFromProxy offDiag - in bandedOffset (0,k) order (size,size) ix - - inBounds (BandedHermitian offDiag order size) ix = - let ku = integralFromProxy offDiag - insideBand r c = Shape.inBounds (Shape.Range 0 ku) (c-r) - in case (order,ix) of - (_, InsideBox r c) -> - Shape.inBounds (size,size) (r,c) - && - insideBand (Shape.offset size r) (Shape.offset size c) - (RowMajor, HorizOutsideBox r c) -> - Shape.inBounds size r - && - insideBand (Shape.offset size r) (outsideOffset size c) - (ColumnMajor, VertOutsideBox r c) -> - Shape.inBounds size c - && - insideBand (outsideOffset size r) (Shape.offset size c) - _ -> False - -instance (Unary.Natural off, Shape.InvIndexed size) => - Shape.InvIndexed (BandedHermitian off size) where - - indexFromOffset (BandedHermitian offDiag order size) j = - bandedHermitianIndexFromOffset - Shape.indexFromOffset Shape.indexFromOffset - (integralFromProxy offDiag) order size j - - uncheckedIndexFromOffset (BandedHermitian offDiag order size) j = - bandedHermitianIndexFromOffset - Shape.uncheckedIndexFromOffset Shape.uncheckedIndexFromOffset - (integralFromProxy offDiag) order size j - -bandedHermitianIndexFromOffset :: - (Shape.C sh) => - (sh -> Int -> row) -> - (sh -> Int -> column) -> - Int -> Order -> sh -> Int -> BandedIndex row column -bandedHermitianIndexFromOffset rowFromOffset columnFromOffset k order size j = - case order of - RowMajor -> - let n = Shape.size size - (rb,cb) = divMod j (k+1) - r = rowFromOffset size rb - ci = rb+cb - in if ci - let (cb,rb) = divMod j (k+1) - c = columnFromOffset size cb - ri = rb+cb-k - in if ri>=0 - then InsideBox (rowFromOffset size ri) c - else VertOutsideBox ri c diff --git a/src/Numeric/LAPACK/Matrix/Special.hs b/src/Numeric/LAPACK/Matrix/Special.hs --- a/src/Numeric/LAPACK/Matrix/Special.hs +++ b/src/Numeric/LAPACK/Matrix/Special.hs @@ -1,11 +1,27 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Matrix.Special ( - Type.Matrix(Scale,Inverse), Scale, Inverse, + Matrix.Matrix(Scale,Inverse), Scale, Inverse, inverse, ) where import qualified Numeric.LAPACK.Matrix.Inverse as Inverse -import qualified Numeric.LAPACK.Matrix.Type as Type +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import Numeric.LAPACK.Matrix.Layout.Private (Empty, Filled) +import Data.Tuple.HT (mapPair) -type Scale sh = Type.Matrix (Type.Scale sh) -type Inverse typ = Type.Matrix (Inverse.Inverse typ) + +type Scale sh = Matrix.Quadratic Matrix.Scale () () Empty Empty sh +type Inverse typ lower upper sh = + Matrix.Quadratic (Inverse.Inverse typ) lower upper Filled Filled sh + +inverse :: + (Omni.Strip lower, Inverse.Fill lower ~ lowerf, + Omni.Strip upper, Inverse.Fill upper ~ upperf) => + Matrix.QuadraticMeas typ xl xu upper lower meas width height a -> + Matrix.QuadraticMeas (Inverse.Inverse typ) (xl,lower) (xu,upper) + lowerf upperf meas height width a +inverse a = + case mapPair (Inverse.filledPowerStripFact, Inverse.filledPowerStripFact) $ + Matrix.strips a of + (Inverse.PowerStripFact, Inverse.PowerStripFact) -> Inverse.Inverse a diff --git a/src/Numeric/LAPACK/Matrix/Square.hs b/src/Numeric/LAPACK/Matrix/Square.hs --- a/src/Numeric/LAPACK/Matrix/Square.hs +++ b/src/Numeric/LAPACK/Matrix/Square.hs @@ -6,7 +6,8 @@ mapSize, toFull, toGeneral, - fromGeneral, + fromFull, + liberalFromFull, fromScalar, toScalar, fromList, @@ -24,6 +25,7 @@ trace, stack, (|=|), + takeTopLeft, takeBottomRight, multiply, square, @@ -49,9 +51,11 @@ import qualified Numeric.LAPACK.Matrix.Basic as FullBasic import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array (Full, General, Square) +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Array + (Full, General, Square, SquareMeas, LiberalSquare) import Numeric.LAPACK.Matrix.Private (ShapeInt) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (ComplexOf) @@ -59,7 +63,7 @@ import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) @@ -68,7 +72,7 @@ size :: Square sh a -> sh -size = MatrixShape.fullHeight . ArrMatrix.shape +size = Omni.squareSize . ArrMatrix.shape mapSize :: (sh0 -> sh1) -> Square sh0 a -> Square sh1 a mapSize = ArrMatrix.lift1 . Basic.mapSize @@ -77,13 +81,22 @@ toGeneral = toFull toFull :: - (Extent.C vert, Extent.C horiz) => Square sh a -> Full vert horiz sh sh a + (Extent.Measured meas vert, Extent.Measured meas horiz) => + Square sh a -> Full meas vert horiz sh sh a toFull = ArrMatrix.lift1 Basic.toFull -fromGeneral :: (Eq sh) => General sh sh a -> Square sh a -fromGeneral = ArrMatrix.lift1 Basic.fromGeneral +fromFull :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Eq sh) => + Full meas vert horiz sh sh a -> Square sh a +fromFull = ArrMatrix.lift1 Basic.fromFull +liberalFromFull :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width a -> LiberalSquare height width a +liberalFromFull = ArrMatrix.lift1 Basic.liberalFromFull + fromScalar :: (Storable a) => a -> Square () a fromScalar = ArrMatrix.lift0 . Basic.fromScalar @@ -133,21 +146,37 @@ infix 3 |=| (|=|) :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sizeA, Eq sizeA, Shape.C sizeB, Eq sizeB, Class.Floating a) => - (Square sizeA a, Full vert horiz sizeA sizeB a) -> - (Full horiz vert sizeB sizeA a, Square sizeB a) -> - Square (sizeA:+:sizeB) a + (Square sizeA a, Full meas vert horiz sizeA sizeB a) -> + (Full meas horiz vert sizeB sizeA a, Square sizeB a) -> + Square (sizeA::+sizeB) a (a,b) |=| (c,d) = stack a b c d stack :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sizeA, Eq sizeA, Shape.C sizeB, Eq sizeB, Class.Floating a) => - Square sizeA a -> Full vert horiz sizeA sizeB a -> - Full horiz vert sizeB sizeA a -> Square sizeB a -> - Square (sizeA:+:sizeB) a + Square sizeA a -> Full meas vert horiz sizeA sizeB a -> + Full meas horiz vert sizeB sizeA a -> Square sizeB a -> + Square (sizeA::+sizeB) a stack = ArrMatrix.lift4 Basic.stack +takeTopLeft :: + (Shape.C sizeA, Shape.C sizeB, Class.Floating a) => + Square (sizeA::+sizeB) a -> Square sizeA a +takeTopLeft = + ArrMatrix.lift1 + (FullBasic.recheck . Basic.fromFull . FullBasic.uncheck . + FullBasic.takeLeft . FullBasic.takeTop . Basic.toFull) + +takeBottomRight :: + (Shape.C sizeA, Shape.C sizeB, Class.Floating a) => + Square (sizeA::+sizeB) a -> Square sizeB a +takeBottomRight = + ArrMatrix.lift1 + (FullBasic.recheck . Basic.fromFull . FullBasic.uncheck . + FullBasic.takeRight . FullBasic.takeBottom . Basic.toFull) + multiply :: (Shape.C sh, Eq sh, Class.Floating a) => Square sh a -> Square sh a -> Square sh a @@ -189,12 +218,15 @@ solve :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Square sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a + Square sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a solve = ArrMatrix.lift2 Linear.solve -inverse :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a +inverse :: + (Extent.Measure meas, Shape.C height, Shape.C width, Class.Floating a) => + SquareMeas meas height width a -> SquareMeas meas width height a inverse = ArrMatrix.lift1 Linear.inverse determinant :: (Shape.C sh, Class.Floating a) => Square sh a -> a @@ -203,7 +235,7 @@ eigenvalues :: - (Shape.C sh, Class.Floating a) => + (ExtShape.Permutable sh, Class.Floating a) => Square sh a -> Vector sh (ComplexOf a) eigenvalues = Eigen.values . ArrMatrix.toVector @@ -231,13 +263,14 @@ * 'Numeric.LAPACK.Matrix.Hermitian.congruenceDiagonalAdjoint' -} schur :: - (Shape.C sh, Class.Floating a) => - Square sh a -> (Square sh a, Square sh a) + (ExtShape.Permutable sh, Class.Floating a) => + Square sh a -> (Square sh a, Triangular.QuasiUpper sh a) schur = - mapPair (ArrMatrix.lift0, ArrMatrix.lift0) . Eigen.schur . ArrMatrix.toVector + mapPair (ArrMatrix.lift0, ArrMatrix.liftUnpacked0) . + Eigen.schur . ArrMatrix.toVector schurComplex :: - (Shape.C sh, Class.Real a, Complex a ~ ac) => + (ExtShape.Permutable sh, Class.Real a, Complex a ~ ac) => Square sh ac -> (Square sh ac, Triangular.Upper sh ac) schurComplex = mapSnd Triangular.takeUpper . schur @@ -272,7 +305,7 @@ * 'Numeric.LAPACK.Singular.decomposeWide' -} eigensystem :: - (Shape.C sh, Class.Floating a, ComplexOf a ~ ac) => + (ExtShape.Permutable sh, Class.Floating a, ComplexOf a ~ ac) => Square sh a -> (Square sh ac, Vector sh ac, Square sh ac) eigensystem = mapTriple (ArrMatrix.lift0, id, ArrMatrix.lift0) . diff --git a/src/Numeric/LAPACK/Matrix/Square/Basic.hs b/src/Numeric/LAPACK/Matrix/Square/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Square/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Square/Basic.hs @@ -1,9 +1,11 @@ {-# LANGUAGE TypeOperators #-} module Numeric.LAPACK.Matrix.Square.Basic ( Square, + LiberalSquare, mapSize, toFull, - fromGeneral, + fromFull, + liberalFromFull, fromScalar, toScalar, fromList, @@ -18,6 +20,7 @@ identityFromWidth, identityFromHeight, diagonal, + diagonalOrder, takeDiagonal, trace, @@ -30,18 +33,18 @@ ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Basic as Basic import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), swapOnRowMajor) import Numeric.LAPACK.Matrix.Private - (Full, mapExtent, - General, argGeneral, Square, argSquare, ShapeInt, shapeInt) + (General, argGeneral, LiberalSquare, Square, argSquare, + Full, mapExtent, ShapeInt, shapeInt) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (zero, one) import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) @@ -56,7 +59,7 @@ import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Storable (Storable, peek, poke) @@ -70,22 +73,28 @@ mapSize :: (sh0 -> sh1) -> Square sh0 a -> Square sh1 a -mapSize f = - Array.mapShape - (\(MatrixShape.Full order extent) -> - MatrixShape.Full order $ ExtentPriv.mapSquareSize f extent) +mapSize = Basic.mapExtent . ExtentPriv.mapSquareSize toFull :: - (Extent.C vert, Extent.C horiz) => Square sh a -> Full vert horiz sh sh a -toFull = mapExtent Extent.fromSquare + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Square sh a -> Full meas vert horiz sh sh a +toFull = mapExtent ExtentPriv.fromSquare -fromGeneral :: (Eq sh) => General sh sh a -> Square sh a -fromGeneral = mapExtent (ExtentPriv.Map ExtentPriv.squareFromGeneral) +fromFull :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Eq sh) => + Full meas vert horiz sh sh a -> Square sh a +fromFull = mapExtent ExtentPriv.squareFromFull +liberalFromFull :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Full meas vert horiz height width a -> LiberalSquare height width a +liberalFromFull = mapExtent ExtentPriv.liberalSquareFromFull + fromScalar :: (Storable a) => a -> Square () a fromScalar a = - Array.unsafeCreate (MatrixShape.square RowMajor ()) $ flip poke a + Array.unsafeCreate (Layout.square RowMajor ()) $ flip poke a toScalar :: (Storable a) => Square () a -> a toScalar = argSquare $ \_ () a -> @@ -93,7 +102,7 @@ fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Square sh a fromList sh = - CheckedArray.fromList (MatrixShape.square RowMajor sh) + CheckedArray.fromList (Layout.square RowMajor sh) autoFromList :: (Storable a) => [a] -> Square ShapeInt a autoFromList xs = @@ -105,7 +114,7 @@ transpose :: Square sh a -> Square sh a -transpose = Array.mapShape MatrixShape.transpose +transpose = Array.mapShape Layout.transpose adjoint :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a adjoint = transpose . Vector.conjugate @@ -132,7 +141,7 @@ identityOrder, _identityOrder :: (Shape.C sh, Class.Floating a) => Order -> sh -> Square sh a identityOrder order sh = - Array.unsafeCreate (MatrixShape.square order sh) $ \aPtr -> + Array.unsafeCreate (Layout.square order sh) $ \aPtr -> evalContT $ do uploPtr <- Call.char 'A' nPtr <- Call.cint $ Shape.size sh @@ -141,7 +150,7 @@ liftIO $ LapackGen.laset uploPtr nPtr nPtr alphaPtr betaPtr aPtr nPtr _identityOrder order sh = - Array.unsafeCreateWithSize (MatrixShape.square order sh) $ \blockSize yPtr -> + Array.unsafeCreateWithSize (Layout.square order sh) $ \blockSize yPtr -> evalContT $ do nPtr <- Call.alloca xPtr <- Call.number zero @@ -158,7 +167,7 @@ diagonal :: (Shape.C sh, Class.Floating a) => Vector sh a -> Square sh a diagonal (Array sh x) = - Array.unsafeCreateWithSize (MatrixShape.square ColumnMajor sh) $ + Array.unsafeCreateWithSize (Layout.square ColumnMajor sh) $ \blockSize yPtr -> evalContT $ do nPtr <- Call.alloca @@ -175,6 +184,12 @@ poke incyPtr (n+1) BlasGen.copy nPtr xPtr incxPtr yPtr incyPtr +diagonalOrder :: + (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Square sh a +diagonalOrder order = + (case order of ColumnMajor -> id; RowMajor -> transpose) . diagonal + + takeDiagonal :: (Shape.C sh, Class.Floating a) => Square sh a -> Vector sh a takeDiagonal = argSquare $ \_ sh x -> Array.unsafeCreateWithSize sh $ \n yPtr -> evalContT $ do @@ -191,11 +206,11 @@ stack :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sizeA, Eq sizeA, Shape.C sizeB, Eq sizeB, Class.Floating a) => - Square sizeA a -> Full vert horiz sizeA sizeB a -> - Full horiz vert sizeB sizeA a -> Square sizeB a -> - Square (sizeA:+:sizeB) a + Square sizeA a -> Full meas vert horiz sizeA sizeB a -> + Full meas horiz vert sizeB sizeA a -> Square sizeB a -> + Square (sizeA::+sizeB) a stack a b c d = Basic.stack a (Matrix.fromFull b) (Matrix.fromFull c) d @@ -213,7 +228,7 @@ Square height a -> General height width a -> Square width a congruence b a0 = let a = Basic.mapWidth Unchecked a0 - in mapSize (\(Unchecked sh) -> sh) $ fromGeneral $ + in mapSize (\(Unchecked sh) -> sh) $ fromFull $ Basic.multiply (Basic.adjoint a) $ Basic.multiply (toFull b) a congruenceAdjoint :: @@ -221,7 +236,7 @@ General height width a -> Square width a -> Square height a congruenceAdjoint a0 b = let a = Basic.mapHeight Unchecked a0 - in mapSize (\(Unchecked sh) -> sh) $ fromGeneral $ + in mapSize (\(Unchecked sh) -> sh) $ fromFull $ Basic.multiply a $ Basic.multiply (toFull b) $ Basic.adjoint a {- @@ -231,7 +246,7 @@ (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -> Square sh a multiplyCommutativeUnchecked - (Array shape@(MatrixShape.Full order extent) a) + (Array shape@(Layout.Full order extent) a) (Array _ b) = Array.unsafeCreate shape $ \cPtr -> let n = Shape.size $ Extent.height extent diff --git a/src/Numeric/LAPACK/Matrix/Square/Eigen.hs b/src/Numeric/LAPACK/Matrix/Square/Eigen.hs --- a/src/Numeric/LAPACK/Matrix/Square/Eigen.hs +++ b/src/Numeric/LAPACK/Matrix/Square/Eigen.hs @@ -6,9 +6,10 @@ ComplexOf, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Basic as Basic -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), swapOnRowMajor) +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Layout.Private (Order(ColumnMajor), swapOnRowMajor) import Numeric.LAPACK.Matrix.Private (Square, argSquare) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (ComplexOf, RealOf, zero) @@ -36,12 +37,11 @@ import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) -import Data.Tuple.HT (mapThd3) import Data.Complex (Complex) values :: - (Shape.C sh, Class.Floating a) => + (ExtShape.Permutable sh, Class.Floating a) => Square sh a -> Vector sh (ComplexOf a) values = getValues $ @@ -54,7 +54,7 @@ newtype Values sh a = Values {getValues :: Values_ sh a} valuesAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => Values_ sh a valuesAux = argSquare $ \_order size a -> Array.unsafeCreateWithSize size $ \n wPtr -> do @@ -76,7 +76,7 @@ schur :: - (Shape.C sh, Class.Floating a) => + (ExtShape.Permutable sh, Class.Floating a) => Square sh a -> (Square sh a, Square sh a) schur = getSchur $ @@ -89,10 +89,10 @@ newtype Schur sh a = Schur {getSchur :: Schur_ sh a} schurAux :: - (Shape.C sh, Class.Floating a, RealOf a ~ ar, Storable ar) => + (ExtShape.Permutable sh, Class.Floating a, RealOf a ~ ar, Storable ar) => Schur_ sh a schurAux = argSquare $ \order size a -> - let sh = MatrixShape.square ColumnMajor size + let sh = Layout.square ColumnMajor size in Array.unsafeCreateWithSizeAndResult sh $ \_ vsPtr -> ArrayIO.unsafeCreate sh $ \sPtr -> do @@ -159,31 +159,27 @@ +type System sh a = (Square sh a, Vector sh a, Square sh a) + decompose :: - (Shape.C sh, Class.Floating a, ComplexOf a ~ ac) => - Square sh a -> (Square sh ac, Vector sh ac, Square sh ac) + (ExtShape.Permutable sh, Class.Floating a, ComplexOf a ~ ac) => + Square sh a -> System sh ac decompose = getDecompose $ Class.switchFloating - (Decompose $ mapThd3 Basic.adjoint . decomposeReal) - (Decompose $ mapThd3 Basic.adjoint . decomposeReal) - (Decompose $ mapThd3 Basic.adjoint . decomposeComplex) - (Decompose $ mapThd3 Basic.adjoint . decomposeComplex) + (Decompose decomposeReal) + (Decompose decomposeReal) + (Decompose decomposeComplex) + (Decompose decomposeComplex) newtype Decompose sh a = - Decompose { - getDecompose :: - Square sh a -> - (Square sh (ComplexOf a), - Vector sh (ComplexOf a), - Square sh (ComplexOf a)) - } + Decompose {getDecompose :: Square sh a -> System sh (ComplexOf a)} decomposeReal :: - (Shape.C sh, Class.Real a, Complex a ~ ac) => - Square sh a -> (Square sh ac, Vector sh ac, Square sh ac) + (ExtShape.Permutable sh, Class.Real a, Complex a ~ ac) => + Square sh a -> System sh ac decomposeReal = argSquare $ \order size a -> - (\(w, (vlc,vrc)) -> (vlc, w, vrc)) $ + (\(w, (vlc,vrc)) -> (vlc, w, Basic.adjoint vrc)) $ Array.unsafeCreateWithSizeAndResult size $ \n wPtr -> evalContT $ do jobvlPtr <- Call.char 'V' @@ -202,7 +198,7 @@ jobvlPtr jobvrPtr nPtr aPtr ldaPtr wrPtr wiPtr vlPtr ldvlPtr vrPtr ldvrPtr liftIO $ zipComplex n wrPtr wiPtr wPtr - liftIO $ createArrayPair order (MatrixShape.square ColumnMajor size) $ + liftIO $ createArrayPair order (Layout.square ColumnMajor size) $ \vlcPtr vrcPtr -> do eigenvectorsToComplex n wiPtr vlPtr vlcPtr eigenvectorsToComplex n wiPtr vrPtr vrcPtr @@ -239,10 +235,10 @@ go vPtr vcPtr . map (zero/=) =<< peekArray n wiPtr decomposeComplex :: - (Shape.C sh, Class.Real a, Complex a ~ ac) => - Square sh ac -> (Square sh ac, Vector sh ac, Square sh ac) + (ExtShape.Permutable sh, Class.Real a, Complex a ~ ac) => + Square sh ac -> System sh ac decomposeComplex = argSquare $ \order size a -> - (\(w, (vlc,vrc)) -> (vlc, w, vrc)) $ + (\(w, (vlc,vrc)) -> (vlc, w, Basic.adjoint vrc)) $ Array.unsafeCreateWithSizeAndResult size $ \n wPtr -> evalContT $ do jobvlPtr <- Call.char 'V' @@ -254,7 +250,7 @@ ldvrPtr <- Call.leadingDim n rworkPtr <- Call.allocaArray (2*n) - liftIO $ createArrayPair order (MatrixShape.square ColumnMajor size) $ + liftIO $ createArrayPair order (Layout.square ColumnMajor size) $ \vlPtr vrPtr -> withAutoWorkspaceInfo eigenMsg "geev" $ \workPtr lworkPtr infoPtr -> diff --git a/src/Numeric/LAPACK/Matrix/Square/Linear.hs b/src/Numeric/LAPACK/Matrix/Square/Linear.hs --- a/src/Numeric/LAPACK/Matrix/Square/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/Square/Linear.hs @@ -5,14 +5,14 @@ determinant, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Permutation.Private as Perm import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, withInfo, diagonalMsg) -import Numeric.LAPACK.Matrix.Shape.Private (transposeFromOrder) -import Numeric.LAPACK.Matrix.Private (Full, Square, argSquare) +import Numeric.LAPACK.Matrix.Layout.Private (transposeFromOrder) +import Numeric.LAPACK.Matrix.Private (Full, Square, SquareMeas, argSquare) import Numeric.LAPACK.Private (withAutoWorkspaceInfo, copyBlock, copyToTemp, copyToColumnMajorTemp) @@ -35,9 +35,10 @@ solve, _solve :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Square sh a -> Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a + Square sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a solve = argSquare $ \orderA shA a -> solver "Square.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do @@ -63,10 +64,13 @@ LapackGen.gesv nPtr nrhsPtr aPtr ldaPtr ipivPtr xPtr ldxPtr -inverse :: (Shape.C sh, Class.Floating a) => Square sh a -> Square sh a -inverse (Array shape@(MatrixShape.Full _order extent) a) = - Array.unsafeCreateWithSize shape $ \blockSize bPtr -> do - let n = Shape.size $ Extent.squareSize extent +inverse :: + (Extent.Measure meas, Shape.C height, Shape.C width, Class.Floating a) => + SquareMeas meas height width a -> SquareMeas meas width height a +inverse (Array shape@(Layout.Full _order extent) a) = + Array.unsafeCreateWithSize (Layout.inverse shape) $ + \blockSize bPtr -> do + let n = Shape.size $ Extent.height extent evalContT $ do nPtr <- Call.cint n aPtr <- ContT $ withForeignPtr a diff --git a/src/Numeric/LAPACK/Matrix/Superscript.hs b/src/Numeric/LAPACK/Matrix/Superscript.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Superscript.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{- | +This module provides an infix operator and some data constructors +that shall resemble mathematical notation. +E.g. you can write @a#^T@ for @Matrix.transpose a@. +It is clearly abuse of the type system +because I suspect you will never write algorithms +that are generic in the superscript type. +-} +module Numeric.LAPACK.Matrix.Superscript where + +import qualified Numeric.LAPACK.Singular as Singular +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix.Layout.Private (Filled) +import Numeric.LAPACK.Matrix.Extent (Shape, Small) +import Numeric.LAPACK.Matrix (Matrix) + +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Numeric.Netlib.Class as Class + + +{- | +left associative in contrast to ^, ^^ etc. +because there is no law analogous to power law @(x^a)^b = x^(a*b)@. +-} +infixl 8 #^ + +class Superscript sup where + data Exponent sup + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a + (#^) :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Shape.C widthA, Shape.C heightA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C widthB, Shape.C heightB) => + (Class.Floating a) => + Matrix typA xlA xuA lowerA upperA measA vertA horizA heightA widthA a -> + Exponent sup + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a -> + Matrix typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a + + +data None +instance Superscript None where + data Exponent None + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + N :: + Exponent None + typ xl xu lower upper meas vert horiz height width + typ xl xu lower upper meas vert horiz height width a + a#^N = a + + +data Transpose +instance Superscript Transpose where + data Exponent Transpose + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + T :: + (Matrix.Transpose typ) => + Exponent Transpose + typ xl xu lower upper meas vert horiz height width + typ xu xl upper lower meas horiz vert width height a + a#^T = Matrix.transpose a + + +data Adjoint +instance Superscript Adjoint where + data Exponent Adjoint + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + A :: + (Matrix.Transpose typ, Matrix.Complex typ) => + Exponent Adjoint + typ xl xu lower upper meas vert horiz height width + typ xu xl upper lower meas horiz vert width height a + a#^A = Matrix.adjoint a + + +data Conjugate +instance Superscript Conjugate where + data Exponent Conjugate + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + C :: + (Matrix.Complex typ) => + Exponent Conjugate + typ xl xu lower upper meas vert horiz height width + typ xl xu lower upper meas vert horiz height width a + a#^C = Matrix.conjugate a + + +data Inverse +instance Superscript Inverse where + data Exponent Inverse + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + -- We could relax lowerB and upperB using Filled type function + Inv :: + (Matrix.Inverse typ xl xu, + Omni.PowerStrip lower, Omni.PowerStrip upper) => + Exponent Inverse + typ xl xu lower upper meas Small Small height width + typ xl xu lower upper meas Small Small width height a + a#^Inv = Matrix.inverse a + + +data PseudoInverse +instance Superscript PseudoInverse where + data Exponent PseudoInverse + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + Pseudo :: + (typ ~ ArrMatrix.Array Layout.Unpacked Omni.Arbitrary) => + Matrix.RealOf a -> + Exponent PseudoInverse + typ () () Filled Filled Shape Small Small sh sh + typ () () Filled Filled Shape Small Small sh sh a + a#^Pseudo rcond = snd $ Singular.pseudoInverseRCond rcond a + + +data Power +instance Superscript Power where + data Exponent Power + typA xlA xuA lowerA upperA measA vertA horizA heightA widthA + typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a where + -- We could relax lowerB and upperB using Filled type function + Exp :: + (Matrix.Power typ xl xu, + Omni.PowerStrip lower, Omni.PowerStrip upper) => + Integer -> + Exponent Power + typ xl xu lower upper Shape Small Small sh sh + typ xl xu lower upper Shape Small Small sh sh a + a#^Exp n = Matrix.power n a diff --git a/src/Numeric/LAPACK/Matrix/Symmetric.hs b/src/Numeric/LAPACK/Matrix/Symmetric.hs --- a/src/Numeric/LAPACK/Matrix/Symmetric.hs +++ b/src/Numeric/LAPACK/Matrix/Symmetric.hs @@ -1,140 +1,292 @@ {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Symmetric ( Symmetric, + takeUpper, + fromUpper, + pack, + assureSymmetry, + size, - fromList, autoFromList, + fromList, + autoFromList, identity, diagonal, takeDiagonal, + forceOrder, transpose, adjoint, stack, (#%%%#), split, + takeTopLeft, + takeTopRight, + takeBottomRight, toSquare, fromHermitian, + multiplyVector, + multiplyFull, + square, + + tensorProduct, + sumRank1, sumRank1NonEmpty, + gramian, gramianTransposed, congruenceDiagonal, congruenceDiagonalTransposed, congruence, congruenceTransposed, anticommutator, anticommutatorTransposed, + addTransposed, + + solve, + inverse, + determinant, ) where +import qualified Numeric.LAPACK.Matrix.Symmetric.Linear as Linear import qualified Numeric.LAPACK.Matrix.Symmetric.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic +import qualified Numeric.LAPACK.Matrix.Full as Full +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as ArrUnpacked import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array.Triangular (Symmetric, Hermitian) -import Numeric.LAPACK.Matrix.Array (Full, General, Square) -import Numeric.LAPACK.Matrix.Shape.Private (Order) +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Array.Mosaic + (Symmetric, SymmetricP, FlexHermitianP, Upper, assureMirrored) +import Numeric.LAPACK.Matrix.Array (Full, General, Square, packTag) +import Numeric.LAPACK.Matrix.Layout.Private (Order) import Numeric.LAPACK.Matrix.Private (ShapeInt) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (one) import qualified Numeric.Netlib.Class as Class -import qualified Data.Array.Comfort.Storable as Array +import qualified Type.Data.Bool as TBool + +import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) +import qualified Data.NonEmpty as NonEmpty import Foreign.Storable (Storable) -size :: Symmetric sh a -> sh -size = MatrixShape.triangularSize . ArrMatrix.shape +size :: SymmetricP pack sh a -> sh +size = Omni.squareSize . ArrMatrix.shape -transpose :: Symmetric sh a -> Symmetric sh a -transpose = Triangular.transpose +transpose :: SymmetricP pack sh a -> SymmetricP pack sh a +transpose = id -adjoint :: (Shape.C sh, Class.Floating a) => Symmetric sh a -> Symmetric sh a -adjoint = Triangular.adjoint +adjoint :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> SymmetricP pack sh a +adjoint = ArrMatrix.lift1 Vector.conjugate fromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Symmetric sh a -fromList = Triangular.symmetricFromList +fromList order sh = ArrMatrix.lift0 . Mosaic.fromList order sh autoFromList :: (Storable a) => Order -> [a] -> Symmetric ShapeInt a -autoFromList = Triangular.autoSymmetricFromList +autoFromList order = ArrMatrix.lift0 . Mosaic.autoFromList order -toSquare :: (Shape.C sh, Class.Floating a) => Symmetric sh a -> Square sh a -toSquare = Triangular.toSquare +toSquare :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> Square sh a +toSquare a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Symmetric.toSquare a + Layout.Unpacked -> ArrMatrix.liftUnpacked1 id a -fromHermitian :: (Shape.C sh, Class.Real a) => Hermitian sh a -> Symmetric sh a +fromHermitian :: + (Layout.Packing pack, TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Real a) => + FlexHermitianP pack neg zero pos sh a -> SymmetricP pack sh a fromHermitian = - ArrMatrix.lift1 $ Array.mapShape MatrixShape.symmetricFromHermitian + ArrMatrix.lift1 $ Array.mapShape Layout.symmetricFromHermitian identity :: (Shape.C sh, Class.Floating a) => Order -> sh -> Symmetric sh a -identity order = Triangular.relaxUnitDiagonal . Triangular.identity order +identity order = ArrMatrix.lift0 . Packed.identity order diagonal :: (Shape.C sh, Class.Floating a) => Order -> Vector sh a -> Symmetric sh a -diagonal = Triangular.diagonal +diagonal order = ArrMatrix.lift0 . Packed.diagonal order takeDiagonal :: (Shape.C sh, Class.Floating a) => Symmetric sh a -> Vector sh a -takeDiagonal = Triangular.takeDiagonal +takeDiagonal = Triangular.takeDiagonal . takeUpper +forceOrder :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Order -> SymmetricP pack sh a -> SymmetricP pack sh a +forceOrder order a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 (Packed.forceOrder order) a + Layout.Unpacked -> ArrMatrix.liftUnpacked1 (FullBasic.forceOrder order) a + +pack :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> Symmetric sh a +pack = ArrMatrix.lift1 Mosaic.pack + +takeUpper :: Symmetric sh a -> Upper sh a +takeUpper = ArrMatrix.lift1 Mosaic.takeUpper + +fromUpper :: Upper sh a -> Symmetric sh a +fromUpper = ArrMatrix.lift1 Mosaic.fromUpper + +assureSymmetry :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Square sh a -> SymmetricP pack sh a +assureSymmetry = assureMirrored + + stack :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - Symmetric sh0 a -> + (Layout.Packing pack, + Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => + SymmetricP pack sh0 a -> General sh0 sh1 a -> - Symmetric sh1 a -> - Symmetric (sh0:+:sh1) a -stack = Triangular.stackSymmetric + SymmetricP pack sh1 a -> + SymmetricP pack (sh0::+sh1) a +stack a = + case packTag a of + Layout.Packed -> ArrMatrix.lift3 Packed.stackUpper a + Layout.Unpacked -> + ArrMatrix.liftUnpacked3 + (\a_ b_ c_ -> + FullBasic.stackMosaic a_ b_ (FullBasic.transpose b_) c_) + a infixr 2 #%%%# (#%%%#) :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - (Symmetric sh0 a, General sh0 sh1 a) -> - Symmetric sh1 a -> - Symmetric (sh0:+:sh1) a + (Layout.Packing pack, + Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => + (SymmetricP pack sh0 a, General sh0 sh1 a) -> + SymmetricP pack sh1 a -> + SymmetricP pack (sh0::+sh1) a (#%%%#) = uncurry stack split :: - (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - Symmetric (sh0:+:sh1) a -> - (Symmetric sh0 a, General sh0 sh1 a, Symmetric sh1 a) -split = Triangular.splitSymmetric + (Layout.Packing pack, + Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => + SymmetricP pack (sh0::+sh1) a -> + (SymmetricP pack sh0 a, General sh0 sh1 a, SymmetricP pack sh1 a) +split a = (takeTopLeft a, takeTopRight a, takeBottomRight a) +takeTopLeft :: + (Layout.Packing pack, Shape.C sh0, Shape.C sh1, Class.Floating a) => + SymmetricP pack (sh0::+sh1) a -> SymmetricP pack sh0 a +takeTopLeft a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeTopLeft a + Layout.Unpacked -> ArrUnpacked.takeTopLeft a +takeTopRight :: + (Layout.Packing pack, Shape.C sh0, Shape.C sh1, Class.Floating a) => + SymmetricP pack (sh0::+sh1) a -> General sh0 sh1 a +takeTopRight a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeTopRight a + Layout.Unpacked -> ArrUnpacked.takeTopRight a +takeBottomRight :: + (Layout.Packing pack, Shape.C sh0, Shape.C sh1, Class.Floating a) => + SymmetricP pack (sh0::+sh1) a -> SymmetricP pack sh1 a +takeBottomRight a = + case packTag a of + Layout.Unpacked -> ArrUnpacked.takeBottomRight a + Layout.Packed -> ArrMatrix.lift1 Packed.takeBottomRight a + + + +multiplyVector :: + (Layout.Packing pack) => + (Shape.C sh, Eq sh, Class.Floating a) => + SymmetricP pack sh a -> Vector sh a -> Vector sh a +multiplyVector = Symmetric.multiplyVector . ArrMatrix.toVector + +multiplyFull :: + (Layout.Packing pack) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, + Class.Floating a) => + SymmetricP pack height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull = ArrMatrix.lift2 Symmetric.multiplyFull + +square :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> SymmetricP pack sh a +square = ArrMatrix.lift1 $ Mosaic.square Omni.Arbitrary + + + +tensorProduct :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> SymmetricP pack sh a +tensorProduct order = ArrMatrix.lift0 . Symmetric.outerUpper order + +sumRank1 :: + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(a, Vector sh a)] -> SymmetricP pack sh a +sumRank1 order sh = ArrMatrix.lift0 . Basic.sumRank1 order sh + +sumRank1NonEmpty :: + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> NonEmpty.T [] (a, Vector sh a) -> SymmetricP pack sh a +sumRank1NonEmpty order (NonEmpty.Cons x xs) = + sumRank1 order (Array.shape $ snd x) (x:xs) + +{- +We do not export a generic function that is polymorphic in the mirror parameter, +because Symmetric and Hermitian Gramian are actually different functions. +-} {- | gramian A = A^T * A -} gramian :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Symmetric width a -gramian = ArrMatrix.lift1 Basic.gramian + General height width a -> SymmetricP pack width a +gramian = ArrMatrix.lift1 Symmetric.gramian {- | gramianTransposed A = A * A^T = gramian (A^T) -} gramianTransposed :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Symmetric height a -gramianTransposed = ArrMatrix.lift1 Basic.gramianTransposed + General height width a -> SymmetricP pack height a +gramianTransposed = ArrMatrix.lift1 Symmetric.gramianTransposed {- | congruenceDiagonal D A = A^T * D * A -} congruenceDiagonal :: + (Layout.Packing pack) => (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Vector height a -> General height width a -> Symmetric width a + Vector height a -> General height width a -> SymmetricP pack width a congruenceDiagonal = ArrMatrix.lift1 . Basic.congruenceDiagonal {- | congruenceDiagonalTransposed A D = A * D * A^T -} congruenceDiagonalTransposed :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Vector width a -> Symmetric height a + General height width a -> Vector width a -> SymmetricP pack height a congruenceDiagonalTransposed a = ArrMatrix.lift0 . Basic.congruenceDiagonalTransposed (ArrMatrix.toVector a) @@ -142,17 +294,22 @@ congruence B A = A^T * B * A -} congruence :: + (Layout.Packing pack) => (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Symmetric height a -> General height width a -> Symmetric width a -congruence = ArrMatrix.lift2 Basic.congruence + SymmetricP pack height a -> General height width a -> SymmetricP pack width a +congruence = + ArrMatrix.lift2 $ \b -> Symmetric.congruence (Mosaic.unpackDirty b) {- | congruenceTransposed B A = A * B * A^T -} congruenceTransposed :: + (Layout.Packing pack) => (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - General height width a -> Symmetric width a -> Symmetric height a -congruenceTransposed = ArrMatrix.lift2 Basic.congruenceTransposed + General height width a -> SymmetricP pack width a -> SymmetricP pack height a +congruenceTransposed = + ArrMatrix.lift2 $ \a -> + Symmetric.congruenceTransposed a . Mosaic.unpackDirty {- | @@ -162,12 +319,15 @@ thus I like to call it Symmetric anticommutator. -} anticommutator :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> Symmetric width a -anticommutator = ArrMatrix.lift2 $ Basic.scaledAnticommutator one + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> SymmetricP pack width a +anticommutator = + ArrMatrix.lift2 $ + Symmetric.scaledAnticommutator Layout.SimpleMirror one {- | anticommutatorTransposed A B @@ -175,10 +335,49 @@ = anticommutator (transpose A) (transpose B) -} anticommutatorTransposed :: - (Extent.C vert, Extent.C horiz, + (Layout.Packing pack, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - Full vert horiz height width a -> - Full vert horiz height width a -> Symmetric height a + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> SymmetricP pack height a anticommutatorTransposed = - ArrMatrix.lift2 $ Basic.scaledAnticommutatorTransposed one + ArrMatrix.lift2 $ + Symmetric.scaledAnticommutatorTransposed Layout.SimpleMirror one + + +{- | +addTransposed A = A^T + A +-} +addTransposed :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + Square sh a -> SymmetricP pack sh a +addTransposed a = + let pck = Layout.autoPacking + in ArrMatrix.requirePacking pck $ + case pck of + Layout.Packed -> ArrMatrix.lift1 Symmetric.addMirrored a + Layout.Unpacked -> + ArrMatrix.liftUnpacked1 FullBasic.recheck $ + let au = ArrUnpacked.uncheck a + in ArrMatrix.add (Full.transpose au) au + + + +solve :: + (Layout.Packing pack) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => + SymmetricP pack sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve = ArrMatrix.lift2 Symmetric.solve + +inverse :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> SymmetricP pack sh a +inverse = ArrMatrix.lift1 Symmetric.inverse + +determinant :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> a +determinant = Linear.determinant . ArrMatrix.toVector diff --git a/src/Numeric/LAPACK/Matrix/Symmetric/Basic.hs b/src/Numeric/LAPACK/Matrix/Symmetric/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Symmetric/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Symmetric/Basic.hs @@ -1,30 +1,28 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Symmetric.Basic ( Symmetric, - - gramian, gramianTransposed, - congruenceDiagonal, congruenceDiagonalTransposed, - congruence, congruenceTransposed, - scaledAnticommutator, scaledAnticommutatorTransposed, + SymmetricP, + sumRank1, + congruenceDiagonal, congruenceDiagonalTransposed, ) where import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Split as Split -import Numeric.LAPACK.Matrix.Triangular.Private (pack, recheck) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), NonUnit(NonUnit)) -import Numeric.LAPACK.Matrix.Modifier - (Transposition(NonTransposed, Transposed)) -import Numeric.LAPACK.Matrix.Private (Full) +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import Numeric.LAPACK.Matrix.Symmetric.Unified + (skipCheckCongruence, spr, syr, complement, + scaledAnticommutator, scaledAnticommutatorTransposed) +import Numeric.LAPACK.Matrix.Mosaic.Private + (withPacking, noLabel, applyFuncPair, triArg) +import Numeric.LAPACK.Matrix.Layout.Private + (MirrorSingleton(SimpleMirror), Order, uploFromOrder) +import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (zero, one) -import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) +import Numeric.LAPACK.Scalar (zero) +import Numeric.LAPACK.Private (fill) -import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class @@ -32,178 +30,60 @@ import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (poke) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) - -type Symmetric sh = Array (MatrixShape.FlexSymmetric NonUnit sh) +import Data.Foldable (forM_) --- cf. Hermitian.Basic -gramian :: - (Shape.C height, Shape.C width, Class.Floating a) => - Matrix.General height width a -> Symmetric width a -gramian (Array (MatrixShape.Full order extent) a) = - Array.unsafeCreate (symmetricShape order $ Extent.width extent) $ - \bPtr -> gramianIO order a bPtr $ gramianParameters order extent - -gramianParameters :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Order -> - Extent.Extent vert horiz height width -> - ((Int, Int), (Char, Char, Int)) -gramianParameters order extent = - let (height, width) = Extent.dimensions extent - n = Shape.size width - k = Shape.size height - in ((n,k), - case order of - ColumnMajor -> ('U', 'T', k) - RowMajor -> ('L', 'N', n)) +type Symmetric sh = SymmetricP Layout.Unpacked sh +type SymmetricP pack sh = Array (Layout.SymmetricP pack sh) -gramianTransposed :: - (Shape.C height, Shape.C width, Class.Floating a) => - Matrix.General height width a -> Symmetric height a -gramianTransposed (Array (MatrixShape.Full order extent) a) = - Array.unsafeCreate (symmetricShape order $ Extent.height extent) $ - \bPtr -> gramianIO order a bPtr $ gramianTransposedParameters order extent - -gramianTransposedParameters :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Order -> - Extent.Extent vert horiz height width -> - ((Int, Int), (Char, Char, Int)) -gramianTransposedParameters order extent = - let (height, width) = Extent.dimensions extent - n = Shape.size height - k = Shape.size width - in ((n,k), - case order of - ColumnMajor -> ('U', 'N', n) - RowMajor -> ('L', 'T', k)) +sumRank1 :: + (Layout.Packing pack, Shape.C sh, Eq sh, Class.Floating a) => + Order -> sh -> [(a, Vector sh a)] -> SymmetricP pack sh a +sumRank1 order sh xs = + let pack = Layout.autoPacking + in Array.unsafeCreateWithSize (Layout.symmetricP pack order sh) $ + \triSize aPtr -> do -gramianIO :: - (Class.Floating a) => - Order -> - ForeignPtr a -> Ptr a -> - ((Int, Int), (Char, Char, Int)) -> IO () -gramianIO order a bPtr ((n,k), (uplo,trans,lda)) = + let n = Shape.size sh evalContT $ do - uploPtr <- Call.char uplo - transPtr <- Call.char trans + uploPtr <- Call.char $ uploFromOrder order nPtr <- Call.cint n - kPtr <- Call.cint k - alphaPtr <- Call.number one - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.leadingDim lda - betaPtr <- Call.number zero - cPtr <- Call.allocaArray (n*n) - ldcPtr <- Call.leadingDim n + alphaPtr <- Call.alloca + incxPtr <- Call.cint 1 liftIO $ do - BlasGen.syrk uploPtr transPtr - nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr - pack order n cPtr bPtr - -skipCheckCongruence :: - ((sh -> Unchecked sh) -> matrix0 -> matrix1) -> - (matrix1 -> Symmetric (Unchecked sh) a) -> matrix0 -> Symmetric sh a -skipCheckCongruence mapSize f a = - recheck $ f $ mapSize Unchecked a + fill zero triSize aPtr + forM_ xs $ \(alpha, Array shX x) -> do + Call.assert "Symmetric.sumRank1: non-matching vector size" (sh==shX) + poke alphaPtr alpha + evalContT $ do + xPtr <- ContT $ withForeignPtr x + withPacking pack $ + applyFuncPair (noLabel spr) (noLabel syr) + uploPtr nPtr alphaPtr xPtr incxPtr (triArg aPtr n) + complement pack NonConjugated order n aPtr congruenceDiagonal :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Vector height a -> Matrix.General height width a -> Symmetric width a + (Layout.Packing pack, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Vector height a -> Matrix.General height width a -> SymmetricP pack width a congruenceDiagonal d = skipCheckCongruence Basic.mapWidth $ \a -> - scaledAnticommutator 0.5 a $ Basic.scaleRows d a + scaledAnticommutator SimpleMirror 0.5 a $ + Basic.scaleRows d a congruenceDiagonalTransposed :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Matrix.General height width a -> Vector width a -> Symmetric height a + (Layout.Packing pack, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Matrix.General height width a -> Vector width a -> SymmetricP pack height a congruenceDiagonalTransposed = flip $ \d -> skipCheckCongruence Basic.mapHeight $ \a -> - scaledAnticommutatorTransposed 0.5 a $ Basic.scaleColumns d a - - -congruence :: - (Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Symmetric height a -> Matrix.General height width a -> Symmetric width a -congruence b = - skipCheckCongruence Basic.mapWidth $ \a -> - scaledAnticommutator one a $ - Split.tallMultiplyR NonTransposed - (Split.takeHalf MatrixShape.triangularOrder b) a - -congruenceTransposed :: - (Shape.C height, Shape.C width, Eq width, Class.Floating a) => - Matrix.General height width a -> Symmetric width a -> Symmetric height a -congruenceTransposed = - flip $ \b -> skipCheckCongruence Basic.mapHeight $ \a -> - scaledAnticommutatorTransposed one a $ - Basic.swapMultiply (Split.tallMultiplyR Transposed) - a (Split.takeHalf MatrixShape.triangularOrder b) - - -scaledAnticommutator :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - a -> - Full vert horiz height width a -> - Full vert horiz height width a -> Symmetric width a -scaledAnticommutator alpha arr (Array (MatrixShape.Full order extentB) b) = do - let (Array (MatrixShape.Full _ extentA) a) = Basic.forceOrder order arr - Array.unsafeCreate (symmetricShape order $ Extent.width extentB) $ - \cpPtr -> do - Call.assert "Symmetric.anticommutator: extents mismatch" - (extentA==extentB) - scaledAnticommutatorIO alpha order a b cpPtr $ - gramianParameters order extentB - -scaledAnticommutatorTransposed :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - a -> - Full vert horiz height width a -> - Full vert horiz height width a -> Symmetric height a -scaledAnticommutatorTransposed - alpha arr (Array (MatrixShape.Full order extentB) b) = do - let (Array (MatrixShape.Full _ extentA) a) = Basic.forceOrder order arr - Array.unsafeCreate (symmetricShape order $ Extent.height extentB) $ - \cpPtr -> do - Call.assert "Symmetric.anticommutatorTransposed: extents mismatch" - (extentA==extentB) - scaledAnticommutatorIO alpha order a b cpPtr $ - gramianTransposedParameters order extentB - -scaledAnticommutatorIO :: - (Class.Floating a) => - a -> - Order -> ForeignPtr a -> ForeignPtr a -> Ptr a -> - ((Int, Int), (Char, Char, Int)) -> IO () -scaledAnticommutatorIO alpha order a b cpPtr ((n,k), (uplo,trans,lda)) = - evalContT $ do - uploPtr <- Call.char uplo - transPtr <- Call.char trans - nPtr <- Call.cint n - kPtr <- Call.cint k - alphaPtr <- Call.number alpha - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.leadingDim lda - bPtr <- ContT $ withForeignPtr b - let ldbPtr = ldaPtr - betaPtr <- Call.number zero - cPtr <- Call.allocaArray (n*n) - ldcPtr <- Call.leadingDim n - liftIO $ do - BlasGen.syr2k uploPtr transPtr nPtr kPtr alphaPtr - aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr - pack order n cPtr cpPtr - - -symmetricShape :: Order -> size -> MatrixShape.Symmetric size -symmetricShape = MatrixShape.Triangular NonUnit MatrixShape.autoUplo + scaledAnticommutatorTransposed SimpleMirror 0.5 a $ + Basic.scaleColumns d a diff --git a/src/Numeric/LAPACK/Matrix/Symmetric/Linear.hs b/src/Numeric/LAPACK/Matrix/Symmetric/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Symmetric/Linear.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Symmetric.Linear ( + determinant, + ) where + +import qualified Numeric.LAPACK.Matrix.Symmetric.Unified as Symmetric +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import Numeric.LAPACK.Matrix.Symmetric.Basic (SymmetricP) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Shape as Shape + +import Foreign.Ptr (Ptr) +import Foreign.Storable (peek) + + +determinant :: + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> a +determinant = Symmetric.determinant peekBlockDeterminant + +peekBlockDeterminant :: + (Class.Floating a) => (Ptr a, Maybe (Ptr a, Ptr a)) -> IO a +peekBlockDeterminant (a0Ptr,ext) = do + a0 <- peek a0Ptr + case ext of + Nothing -> return a0 + Just (a1Ptr,bPtr) -> do + a1 <- peek a1Ptr + b <- peek bPtr + return (a0*a1 - b*b) diff --git a/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs b/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Symmetric/Private.hs +++ /dev/null @@ -1,157 +0,0 @@ -module Numeric.LAPACK.Matrix.Symmetric.Private where - -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Triangular.Private - (diagonalPointerPairs, columnMajorPointers, rowMajorPointers, - forPointers, pack, unpackToTemp, copyTriangleToTemp) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), uploFromOrder) -import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated, Conjugated)) -import Numeric.LAPACK.Matrix.Private (Full) -import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, withInfo) -import Numeric.LAPACK.Scalar (zero, one) -import Numeric.LAPACK.Private (copyBlock, copyToTemp, copyCondConjugate) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.BLAS.FFI.Generic as BlasGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape (triangleSize) - -import Foreign.Marshal.Array (advancePtr) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable, peek) - -import qualified System.IO.Lazy as LazyIO - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Applicative ((<$>)) - - -unpack :: Class.Floating a => - Conjugation -> Order -> Int -> Ptr a -> Ptr a -> IO () -unpack conj order n packedPtr fullPtr = evalContT $ do - incxPtr <- Call.cint 1 - incyPtr <- Call.cint n - liftIO $ case order of - RowMajor -> - forPointers (rowMajorPointers n fullPtr packedPtr) $ - \nPtr (dstPtr,srcPtr) -> do - copyCondConjugate conj nPtr srcPtr incxPtr dstPtr incyPtr - BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr - ColumnMajor -> - forPointers (columnMajorPointers n fullPtr packedPtr) $ - \nPtr ((dstRowPtr,dstColumnPtr),srcPtr) -> do - copyCondConjugate conj nPtr srcPtr incxPtr dstRowPtr incyPtr - BlasGen.copy nPtr srcPtr incxPtr dstColumnPtr incxPtr - - -square :: - (Class.Floating a) => - Conjugation -> Order -> Int -> ForeignPtr a -> Ptr a -> IO () -square conj order n a bpPtr = - evalContT $ do - sidePtr <- Call.char 'L' - uploPtr <- Call.char 'U' - nPtr <- Call.cint n - ldPtr <- Call.leadingDim n - aPtr <- unpackToTemp (unpack conj order) n a - bPtr <- Call.allocaArray (n*n) - alphaPtr <- Call.number one - betaPtr <- Call.number zero - liftIO $ do - (if conj==Conjugated then BlasGen.hemm else BlasGen.symm) - sidePtr uploPtr - nPtr nPtr alphaPtr aPtr ldPtr - aPtr ldPtr betaPtr bPtr ldPtr - pack order n bPtr bpPtr - - -solve :: - (Extent.C vert, Extent.C horiz, - Shape.C width, Shape.C height, Eq height, Class.Floating a) => - String -> Conjugation -> Order -> height -> ForeignPtr a -> - Full vert horiz height width a -> - Full vert horiz height width a -solve name conj order sh a = - solver name sh $ \n nPtr nrhsPtr xPtr ldxPtr -> do - uploPtr <- Call.char $ uploFromOrder order - apPtr <- copyTriangleToTemp conj order (triangleSize n) a - ipivPtr <- Call.allocaArray n - liftIO $ - let (lapackName,slv) = - case conj of - Conjugated -> ("hpsv", LapackGen.hpsv) - NonConjugated -> ("spsv", LapackGen.spsv) - in withInfo lapackName $ - slv uploPtr nPtr nrhsPtr apPtr ipivPtr xPtr ldxPtr - - -inverse :: - Class.Floating a => - Conjugation -> Order -> Int -> ForeignPtr a -> Int -> Ptr a -> IO () -inverse conj order n a triSize bPtr = evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - ipivPtr <- Call.allocaArray n - workPtr <- Call.allocaArray n - liftIO $ do - copyBlock triSize aPtr bPtr - case conj of - Conjugated -> do - withInfo "hptrf" $ LapackGen.hptrf uploPtr nPtr bPtr ipivPtr - withInfo "hptri" $ LapackGen.hptri uploPtr nPtr bPtr ipivPtr workPtr - NonConjugated -> do - withInfo "sptrf" $ LapackGen.sptrf uploPtr nPtr bPtr ipivPtr - withInfo "sptri" $ LapackGen.sptri uploPtr nPtr bPtr ipivPtr workPtr - - -blockDiagonalPointers :: - (Storable a) => - Order -> [(Ptr CInt, Ptr a)] -> LazyIO.T [(Ptr a, Maybe (Ptr a, Ptr a))] -blockDiagonalPointers order = - let go ((ipiv0Ptr,a0Ptr):ptrs0) = do - ipiv <- LazyIO.interleave $ peek ipiv0Ptr - (ext,ptrTuples) <- - if ipiv >= 0 - then (,) Nothing <$> go ptrs0 - else - case ptrs0 of - [] -> error "Symmetric.determinant: incomplete 2x2 block" - (_ipiv1Ptr,a1Ptr):ptrs1 -> - let bPtr = - case order of - ColumnMajor -> advancePtr a1Ptr (-1) - RowMajor -> advancePtr a0Ptr 1 - in (,) (Just (a1Ptr,bPtr)) <$> go ptrs1 - return $ (a0Ptr,ext) : ptrTuples - go [] = return [] - in go - -determinant :: - (Class.Floating a, Class.Floating ar) => - Conjugation -> ((Ptr a, Maybe (Ptr a, Ptr a)) -> IO ar) -> - Order -> Int -> ForeignPtr a -> IO ar -determinant conj peekBlockDeterminant order n a = evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - aPtr <- copyToTemp (triangleSize n) a - ipivPtr <- Call.allocaArray n - let (name,trf) = - case conj of - Conjugated -> ("hptrf", LapackGen.hptrf) - NonConjugated -> ("sptrf", LapackGen.sptrf) - liftIO $ withDeterminantInfo name - (trf uploPtr nPtr aPtr ipivPtr) - (((return $!) =<<) $ - LazyIO.run - (fmap product $ - mapM (LazyIO.interleave . peekBlockDeterminant) =<< - blockDiagonalPointers order - (diagonalPointerPairs order n ipivPtr aPtr))) diff --git a/src/Numeric/LAPACK/Matrix/Symmetric/Unified.hs b/src/Numeric/LAPACK/Matrix/Symmetric/Unified.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Matrix/Symmetric/Unified.hs @@ -0,0 +1,726 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +module Numeric.LAPACK.Matrix.Symmetric.Unified where + +import qualified Numeric.LAPACK.Matrix.Mosaic.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Generic as Mosaic +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as MosaicPriv +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Matrix.Private as Matrix +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Mosaic.Private + (Mosaic, recheck, copyTriangleToTemp, forPointers, + diagonalPointers, columnMajorPointers, rowMajorPointers, + withPacking, withPackingLinear, runPacking, + noLabel, label, applyFuncPair, triArg, + Labelled(Labelled)) +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor,ColumnMajor), uploFromOrder, uploOrder) +import Numeric.LAPACK.Matrix.Modifier + (Conjugation(NonConjugated, Conjugated), conjugatedOnRowMajor, + Transposition(NonTransposed, Transposed), transposeOrder) +import Numeric.LAPACK.Matrix.Private (Full, General, Square) +import Numeric.LAPACK.Linear.Private (solver, withDeterminantInfo, diagonalMsg) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero, one) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) +import Numeric.LAPACK.Private + (fill, copyBlock, copyToTemp, + condConjugate, copyCondConjugate, condConjugateToTemp, + withAutoWorkspace, pointerSeq) + +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.BLAS.FFI.Complex as BlasComplex +import qualified Numeric.BLAS.FFI.Real as BlasReal +import qualified Numeric.BLAS.FFI.Generic as BlasGen +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import Foreign.Marshal.Array (advancePtr) +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable, peek) + +import qualified System.IO.Lazy as LazyIO +import System.IO.Unsafe (unsafePerformIO) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) +import Control.Applicative ((<$>)) + + + +data MirrorSingleton mirror where + SimpleMirror :: MirrorSingleton Layout.SimpleMirror + ConjugateMirror :: MirrorSingleton Layout.ConjugateMirror + +deriving instance Eq (MirrorSingleton mirror) +deriving instance Show (MirrorSingleton mirror) + +class (Layout.Mirror mirror) => Mirror mirror where + autoMirror :: MirrorSingleton mirror +instance Mirror Layout.SimpleMirror where autoMirror = SimpleMirror +instance Mirror Layout.ConjugateMirror where autoMirror = ConjugateMirror + +narrowMirror :: (Mirror mirror) => f mirror -> MirrorSingleton mirror +narrowMirror _ = autoMirror + +conjugationFromMirror :: (Mirror mirror) => f mirror -> Conjugation +conjugationFromMirror mirror = + case narrowMirror mirror of + SimpleMirror -> NonConjugated + ConjugateMirror -> Conjugated + + + +{- | +> let b = takeHalf a +> ==> +> isTriangular b && a == addTransposed b +-} +takeHalf :: + (Shape.C sh, Class.Floating a) => + Unpacked.Mosaic mirror Shape.Upper sh a -> + Unpacked.Triangular Shape.Upper sh a +takeHalf (Array shape a) = + Array.unsafeCreateWithSize + shape{Layout.mosaicMirror = Layout.NoMirror} $ + \size bPtr -> evalContT $ do + let n = Shape.size $ Layout.mosaicSize shape + aPtr <- ContT $ withForeignPtr a + nPtr <- Call.cint n + alphaPtr <- Call.number 0.5 + incxPtr <- Call.cint (n+1) + liftIO $ do + copyBlock size aPtr bPtr + BlasGen.scal nPtr alphaPtr bPtr incxPtr + + +toSquare :: + (Mirror mirror, Shape.C sh, Class.Floating a) => + Packed.Mosaic mirror Shape.Upper sh a -> Square sh a +toSquare (Array (Layout.Mosaic _pack mirror _uplo order sh) a) = + Array.unsafeCreate (Layout.square order sh) $ \bPtr -> + withForeignPtr a $ \aPtr -> evalContT $ do + + let conj = conjugationFromMirror mirror + let n = Shape.size sh + incxPtr <- Call.cint 1 + incyPtr <- Call.cint n + liftIO $ case order of + RowMajor -> + forPointers (rowMajorPointers n bPtr aPtr) $ + \nPtr (dstPtr,srcPtr) -> do + copyCondConjugate conj nPtr srcPtr incxPtr dstPtr incyPtr + BlasGen.copy nPtr srcPtr incxPtr dstPtr incxPtr + ColumnMajor -> + forPointers (columnMajorPointers n bPtr aPtr) $ + \nPtr ((dstRowPtr,dstColumnPtr),srcPtr) -> do + copyCondConjugate conj nPtr srcPtr incxPtr dstRowPtr incyPtr + BlasGen.copy nPtr srcPtr incxPtr dstColumnPtr incxPtr + + +addMirrored :: + (Mirror mirror, Shape.C sh, Class.Floating a) => + Square sh a -> Packed.Mosaic mirror Shape.Upper sh a +addMirrored (Array (Layout.Full order extent) a) = + let sh = Extent.squareSize extent + mirror = Layout.autoMirror + shape = + Layout.Mosaic Layout.Packed mirror Layout.Upper order sh + in Array.unsafeCreate shape $ \bPtr -> evalContT $ do + + let conj = conjugationFromMirror mirror + let n = Shape.size sh + alphaPtr <- Call.number one + incxPtr <- Call.cint 1 + incnPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + liftIO $ case order of + RowMajor -> + forPointers (rowMajorPointers n aPtr bPtr) $ + \nPtr (srcPtr,dstPtr) -> do + copyCondConjugate conj nPtr srcPtr incnPtr dstPtr incxPtr + BlasGen.axpy nPtr alphaPtr srcPtr incxPtr dstPtr incxPtr + ColumnMajor -> + forPointers (columnMajorPointers n aPtr bPtr) $ + \nPtr ((srcRowPtr,srcColumnPtr),dstPtr) -> do + copyCondConjugate conj nPtr srcRowPtr incnPtr dstPtr incxPtr + BlasGen.axpy nPtr alphaPtr srcColumnPtr incxPtr dstPtr incxPtr + + +complementUnpacked :: + (Class.Floating a) => + Conjugation -> Order -> Int -> Ptr a -> Ptr a -> IO () +complementUnpacked conj order n aPtr bPtr = evalContT $ do + inc1Ptr <- Call.cint 1 + incnPtr <- Call.cint n + let number = take n . zip [0..] + liftIO $ case order of + RowMajor -> + forPointers (number $ zip (pointerSeq 1 aPtr) (pointerSeq n bPtr)) $ + \nPtr (srcPtr,dstPtr) -> + copyCondConjugate conj nPtr srcPtr incnPtr dstPtr inc1Ptr + ColumnMajor -> + forPointers (number $ zip (pointerSeq n aPtr) (pointerSeq 1 bPtr)) $ + \nPtr (srcPtr,dstPtr) -> + copyCondConjugate conj nPtr srcPtr inc1Ptr dstPtr incnPtr + +complement :: + (Class.Floating a) => + Layout.PackingSingleton pack -> + Conjugation -> Order -> Int -> Ptr a -> IO () +complement pack conj order n bPtr = do + case pack of + Layout.Packed -> return () + Layout.Unpacked -> complementUnpacked conj order n bPtr bPtr + + +type SPMV ar a = + Ptr CChar -> Ptr CInt -> Ptr ar -> Ptr a -> + Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () + +type SYMV ar a = + Ptr CChar -> Ptr CInt -> Ptr ar -> Ptr a -> Ptr CInt -> + Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () + +multiplyVectorCont :: + (Class.Floating ar, Class.Floating a) => + SPMV ar a -> + SYMV ar a -> + Layout.PackingSingleton pack -> + Layout.UpLoSingleton uplo -> + Layout.Order -> + Int -> + ForeignPtr a -> Ptr a -> Ptr a -> ContT () IO () +multiplyVectorCont spmv symv pack uplo order n a xPtr yPtr = do + uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order + nPtr <- Call.cint n + alphaPtr <- Call.number one + aPtr <- ContT $ withForeignPtr a + incxPtr <- Call.cint 1 + betaPtr <- Call.number zero + incyPtr <- Call.cint 1 + withPacking pack $ + applyFuncPair (noLabel spmv) (noLabel symv) + uploPtr nPtr alphaPtr (triArg aPtr n) + xPtr incxPtr betaPtr yPtr incyPtr + +-- Triangular is a bit different, it has no alpha +multiplyVector :: + (Mirror mirror, Shape.C sh, Eq sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> Vector sh a -> Vector sh a +multiplyVector + (Array (Layout.Mosaic pack mirror uplo order shA) a) (Array shX x) = + Array.unsafeCreateWithSize shX $ \n yPtr -> do + Call.assert "Symmetric.multiplyVector: width shapes mismatch" (shA == shX) + evalContT $ + case narrowMirror mirror of + ConjugateMirror -> do + let conj = conjugatedOnRowMajor order + xPtr <- condConjugateToTemp conj n x + multiplyVectorCont BlasGen.hpmv BlasGen.hemv + pack uplo order n a xPtr yPtr + nPtr <- Call.cint n + incyPtr <- Call.cint 1 + liftIO $ condConjugate conj nPtr yPtr incyPtr + SimpleMirror -> do + xPtr <- ContT $ withForeignPtr x + case Scalar.complexSingletonOfFunctor x of + Scalar.Real -> + multiplyVectorCont BlasReal.spmv BlasReal.symv + pack uplo order n a xPtr yPtr + Scalar.Complex -> + multiplyVectorCont LapackComplex.spmv LapackComplex.symv + pack uplo order n a xPtr yPtr + + +multiplyFull :: + (Layout.UpLo uplo, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Mosaic pack mirror uplo height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull = + Unpacked.multiplyFull Omni.Arbitrary . Mosaic.unpackDirty + + +forceUpper :: + (Layout.Packing pack, Mirror mirror, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> + Mosaic pack mirror Shape.Upper sh a +forceUpper a = + case Layout.mosaicUplo $ Array.shape a of + Layout.Upper -> a + Layout.Lower -> upperFromLower a + +upperFromLower :: + (Layout.Packing pack, Mirror mirror, Shape.C sh, Class.Floating a) => + Mosaic pack mirror Shape.Lower sh a -> + Mosaic pack mirror Shape.Upper sh a +upperFromLower + (Array (Layout.Mosaic pack mirror Layout.Lower order sh) a) = + + (case narrowMirror mirror of + SimpleMirror -> id + ConjugateMirror -> Vector.conjugate) $ + Array + (Layout.Mosaic + pack mirror Layout.Upper (Layout.flipOrder order) sh) + a + + +type SYR ar a f = + Ptr CChar -> Ptr CInt -> Ptr ar -> Ptr a -> Ptr CInt -> Ptr a -> f + +withSyrSingleton :: + (Class.Floating a) => (Scalar.ComplexSingleton a -> SYR a a f) -> SYR a a f +withSyrSingleton f = f Scalar.complexSingleton + +spr :: (Class.Floating a) => SYR a a (IO ()) +spr = withSyrSingleton $ \sw -> + case sw of + Scalar.Real -> BlasReal.spr + Scalar.Complex -> LapackComplex.spr + +syr :: (Class.Floating a) => SYR a a (Ptr CInt -> IO ()) +syr = withSyrSingleton $ \sw -> + case sw of + Scalar.Real -> BlasReal.syr + Scalar.Complex -> LapackComplex.syr + +outerCont :: + (Class.Floating a, Class.Floating ar) => + SYR ar a (IO ()) -> + SYR ar a (Ptr CInt -> IO ()) -> + ForeignPtr a -> Int -> + Layout.PackingSingleton pack -> + Layout.UpLoSingleton uplo -> + Ptr a -> ContT () IO () +outerCont spr_ syr_ x n pack uplo aPtr = do + uploPtr <- Call.char $ Layout.uploChar uplo + nPtr <- Call.cint n + alphaPtr <- Call.number one + xPtr <- ContT $ withForeignPtr x + incxPtr <- Call.cint 1 + withPacking pack $ + applyFuncPair (noLabel spr_) (noLabel syr_) + uploPtr nPtr alphaPtr xPtr incxPtr (triArg aPtr n) + +outer :: + (Layout.Packing pack, Mirror mirror, Layout.UpLo uplo, + Shape.C sh, Class.Floating a) => + Vector sh a -> Mosaic pack mirror uplo sh a +outer (Array sh x) = + let n = Shape.size sh + pack = Layout.autoPacking + mirror = Layout.autoMirror + uplo = Layout.autoUplo + order = Layout.ColumnMajor + in Array.unsafeCreateWithSize + (Layout.Mosaic pack mirror uplo order sh) $ + \triSize aPtr -> do + fill zero triSize aPtr + evalContT $ + case (Scalar.complexSingletonOfFunctor x, narrowMirror mirror) of + (Scalar.Complex, ConjugateMirror) -> + outerCont BlasComplex.hpr BlasComplex.her x n pack uplo aPtr + _ -> outerCont spr syr x n pack uplo aPtr + complement pack (conjugationFromMirror mirror) (uploOrder uplo order) n aPtr + +outerUpper :: + (Layout.Packing pack, Mirror mirror, Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> Mosaic pack mirror Shape.Upper sh a +outerUpper order x = + case order of + Layout.ColumnMajor -> outer x + Layout.RowMajor -> upperFromLower $ outer x + + +upperShape :: + (Layout.Mirror mirror) => + Layout.PackingSingleton pack -> + Layout.MirrorSingleton mirror -> Order -> size -> + Layout.Mosaic pack mirror Shape.Upper size +upperShape pack mirror = Layout.Mosaic pack mirror Layout.Upper + +unpackedShape :: + (Layout.Mirror mirror) => + Layout.MirrorSingleton mirror -> Order -> size -> + Layout.Mosaic Layout.Unpacked mirror Shape.Upper size +unpackedShape = upperShape Layout.Unpacked + +skipCheckCongruence :: + ((sh -> Unchecked sh) -> matrix0 -> matrix1) -> + (matrix1 -> Mosaic pack mirror uplo (Unchecked sh) a) -> + matrix0 -> Mosaic pack mirror uplo sh a +skipCheckCongruence mapSize f = recheck . f . mapSize Unchecked + + +postHook :: (Monad m) => m () -> ContT r m () +postHook hook = ContT $ \act -> do r <- act (); hook; return r + +temporaryUnpacked :: + (Mirror mirror, Class.Floating a) => + Layout.PackingSingleton pack -> MirrorSingleton mirror -> Order -> + Int -> Ptr a -> ContT () IO (Ptr a) +temporaryUnpacked pack mirror order n cpPtr = + case pack of + Layout.Packed -> do + cPtr <- Call.allocaArray (n*n) + postHook $ MosaicPriv.pack order n cPtr cpPtr + return cPtr + Layout.Unpacked -> do + postHook $ + complementUnpacked + (conjugationFromMirror mirror) order n cpPtr cpPtr + return cpPtr + + +gramianParameters :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + MirrorSingleton mirror -> + Transposition -> + Order -> + Extent.Extent meas vert horiz height width -> + ((Int, Int), (Char, Char, Int)) +gramianParameters mirror trans order extent = + let (height, width) = Extent.dimensions extent + n = Shape.size width + k = Shape.size height + mirrorChar = + case mirror of + SimpleMirror -> 'T' + ConjugateMirror -> 'C' + transChar = + case transposeOrder trans order of + ColumnMajor -> mirrorChar + RowMajor -> 'N' + lda = + case order of + ColumnMajor -> k + RowMajor -> n + in (case trans of NonTransposed -> (n,k); Transposed -> (k,n), + (uploFromOrder order, transChar, lda)) + + +{- +Another way to unify 'gramian' and 'gramianAdjoint' +would have been this function: + +> gramianConjugation :: +> Conjugation -> General height width a -> Hermitian width a + +with + +> gramianAdjoint a = gramianConjugation (transpose a) + +but I would like to have + +> order (gramianAdjoint a) = order a +-} +gramianIO :: + (Mirror mirror, Class.Floating a) => + Layout.PackingSingleton pack -> MirrorSingleton mirror -> Order -> + ForeignPtr a -> Ptr a -> + ((Int, Int), (Char, Char, Int)) -> IO () +gramianIO pack mirror order a cpPtr ((n,k), (uplo,trans,lda)) = evalContT $ do + uploPtr <- Call.char uplo + transPtr <- Call.char trans + nPtr <- Call.cint n + kPtr <- Call.cint k + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim lda + cPtr <- temporaryUnpacked pack mirror order n cpPtr + ldcPtr <- Call.leadingDim n + case (k, mirror, Scalar.complexSingletonOfFunctor a) of + (0, _, _) -> liftIO $ fill zero (n*n) cPtr + (_, ConjugateMirror, Scalar.Complex) -> do + alphaPtr <- Call.number one + betaPtr <- Call.number zero + liftIO $ + BlasComplex.herk uploPtr transPtr + nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr + _ -> do + alphaPtr <- Call.number one + betaPtr <- Call.number zero + liftIO $ + BlasGen.syrk uploPtr transPtr + nPtr kPtr alphaPtr aPtr ldaPtr betaPtr cPtr ldcPtr + +gramian :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Shape.C width, Class.Floating a) => + Matrix.General height width a -> + Mosaic pack mirror Shape.Upper width a +gramian (Array (Layout.Full order extent) a) = + let pack = Layout.autoPacking + mirror = Layout.autoMirror + in Array.unsafeCreate (upperShape pack mirror order $ Extent.width extent) $ + \bPtr -> + gramianIO pack (narrowMirror mirror) order a bPtr $ + gramianParameters (narrowMirror mirror) NonTransposed order extent + +gramianTransposed :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Shape.C width, Class.Floating a) => + Matrix.General height width a -> + Mosaic pack mirror Shape.Upper height a +gramianTransposed (Array (Layout.Full order extent) a) = + let pack = Layout.autoPacking + mirror = Layout.autoMirror + in Array.unsafeCreate (upperShape pack mirror order $ Extent.height extent) $ + \bPtr -> + gramianIO pack (narrowMirror mirror) order a bPtr $ + gramianParameters (narrowMirror mirror) Transposed order extent + + +scaledAnticommutatorIO :: + (Mirror mirror, Class.Floating a) => + Layout.PackingSingleton pack -> MirrorSingleton mirror -> Order -> a -> + ForeignPtr a -> ForeignPtr a -> Ptr a -> + ((Int, Int), (Char, Char, Int)) -> IO () +scaledAnticommutatorIO + pack mirror order alpha a b cpPtr ((n,k), (uplo,trans,lda)) = + evalContT $ do + uploPtr <- Call.char uplo + transPtr <- Call.char trans + nPtr <- Call.cint n + kPtr <- Call.cint k + alphaPtr <- Call.number alpha + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim lda + bPtr <- ContT $ withForeignPtr b + let ldbPtr = ldaPtr + cPtr <- temporaryUnpacked pack mirror order n cpPtr + ldcPtr <- Call.leadingDim n + case (mirror, Scalar.complexSingletonOfFunctor a) of + (ConjugateMirror, Scalar.Complex) -> do + betaPtr <- Call.number zero + liftIO $ + BlasComplex.her2k uploPtr transPtr nPtr kPtr alphaPtr + aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr + _ -> do + betaPtr <- Call.number zero + liftIO $ + BlasGen.syr2k uploPtr transPtr nPtr kPtr alphaPtr + aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldcPtr + +scaledAnticommutator :: + (Layout.Packing pack, Mirror mirror, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Layout.MirrorSingleton mirror -> + a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> + Mosaic pack mirror Shape.Upper width a +scaledAnticommutator mirror + alpha arr (Array (Layout.Full order extentB) b) = do + let (Array (Layout.Full _ extentA) a) = Basic.forceOrder order arr + pack = Layout.autoPacking + Array.unsafeCreate (upperShape pack mirror order $ Extent.width extentB) $ + \cPtr -> do + Call.assert "Symmetric.anticommutator: extents mismatch" + (extentA==extentB) + scaledAnticommutatorIO pack (narrowMirror mirror) order alpha a b cPtr $ + gramianParameters (narrowMirror mirror) NonTransposed order extentB + +scaledAnticommutatorTransposed :: + (Layout.Packing pack, Mirror mirror, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Layout.MirrorSingleton mirror -> + a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a -> + Mosaic pack mirror Shape.Upper height a +scaledAnticommutatorTransposed mirror + alpha arr (Array (Layout.Full order extentB) b) = do + let (Array (Layout.Full _ extentA) a) = Basic.forceOrder order arr + pack = Layout.autoPacking + Array.unsafeCreate (upperShape pack mirror order $ Extent.height extentB) $ + \cPtr -> do + Call.assert "Symmetric.anticommutatorTransposed: extents mismatch" + (extentA==extentB) + scaledAnticommutatorIO pack (narrowMirror mirror) order alpha a b cPtr $ + gramianParameters (narrowMirror mirror) Transposed order extentB + + +congruenceRealDiagonal :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Vector height (RealOf a) -> + General height width a -> + Mosaic pack mirror Shape.Upper width a +congruenceRealDiagonal d = + skipCheckCongruence Basic.mapWidth $ \a -> + scaledAnticommutator Layout.autoMirror 0.5 a $ + Basic.scaleRowsReal d a + +congruenceRealDiagonalTransposed :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + General height width a -> + Vector width (RealOf a) -> + Mosaic pack mirror Shape.Upper height a +congruenceRealDiagonalTransposed = + flip $ \d -> skipCheckCongruence Basic.mapHeight $ \a -> + scaledAnticommutatorTransposed Layout.autoMirror 0.5 a $ + Basic.scaleColumnsReal d a + +congruence :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + Unpacked.Mosaic mirror Shape.Upper height a -> + Matrix.General height width a -> + Mosaic pack mirror Shape.Upper width a +congruence b = + skipCheckCongruence Basic.mapWidth $ \a -> + scaledAnticommutator + (Layout.mosaicMirror $ Array.shape b) one a $ + Unpacked.multiplyFull Omni.Arbitrary (takeHalf b) a + +congruenceTransposed :: + (Layout.Packing pack, Mirror mirror, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Matrix.General height width a -> + Unpacked.Mosaic mirror Shape.Upper width a -> + Mosaic pack mirror Shape.Upper height a +congruenceTransposed = + flip $ \b -> skipCheckCongruence Basic.mapHeight $ \a -> + scaledAnticommutatorTransposed + (Layout.mosaicMirror $ Array.shape b) one a $ + Basic.swapMultiply + (Unpacked.multiplyFull Omni.Arbitrary . Mosaic.transpose) + a (takeHalf b) + + +solve :: + (Mirror mirror, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Eq height, Class.Floating a) => + Mosaic pack mirror Shape.Upper height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +solve (Array shape@(Layout.Mosaic pack mirror _upper order sh) a) = + solver (show mirror) sh $ \n nPtr nrhsPtr xPtr ldxPtr -> do + uploPtr <- Call.char $ uploFromOrder order + let conj = conjugationFromMirror mirror + aPtr <- copyTriangleToTemp conj order (Shape.size shape) a + ipivPtr <- Call.allocaArray n + withPackingLinear diagonalMsg pack $ fmap autoWorkspace $ + uncurry applyFuncPair + (case conj of + Conjugated -> + (label "hpsv" LapackGen.hpsv, label "hesv" LapackGen.hesv) + NonConjugated -> + (label "spsv" LapackGen.spsv, label "sysv" LapackGen.sysv)) + uploPtr nPtr nrhsPtr (triArg aPtr n) ipivPtr xPtr ldxPtr + + +inverse :: + (Mirror mirror, Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Mosaic pack mirror uplo sh a -> + Mosaic pack mirror uplo sh a +inverse (Array shape@(Layout.Mosaic pack mirror uplo order sh) a) = + Array.unsafeCreateWithSize shape $ \triSize bPtr -> evalContT $ do + + let n = Shape.size sh + let realOrder = uploOrder uplo order + uploPtr <- Call.char $ uploFromOrder realOrder + nPtr <- Call.cint n + aPtr <- ContT $ withForeignPtr a + ipivPtr <- Call.allocaArray n + liftIO $ copyBlock triSize aPtr bPtr + let conj = conjugationFromMirror mirror + let (trf,tri) = + case conj of + Conjugated -> + ((label "hptrf" LapackGen.hptrf, label "hetrf" LapackGen.hetrf), + (label "hptri" LapackGen.hptri, label "hetri" LapackGen.hetri)) + NonConjugated -> + ((label "sptrf" LapackGen.sptrf, label "sytrf" LapackGen.sytrf), + (label "sptri" LapackGen.sptri, label "sytri" LapackGen.sytri)) + withPackingLinear diagonalMsg pack $ fmap autoWorkspace $ + uncurry applyFuncPair trf uploPtr nPtr (triArg bPtr n) ipivPtr + workPtr <- Call.allocaArray n + withPackingLinear diagonalMsg pack $ + uncurry applyFuncPair tri uploPtr nPtr (triArg bPtr n) ipivPtr workPtr + liftIO $ complement pack conj realOrder n bPtr + + +blockDiagonalPointers :: + (Storable a) => + Order -> [(Ptr CInt, Ptr a)] -> LazyIO.T [(Ptr a, Maybe (Ptr a, Ptr a))] +blockDiagonalPointers order = + let go ((ipiv0Ptr,a0Ptr):ptrs0) = do + ipiv <- LazyIO.interleave $ peek ipiv0Ptr + (ext,ptrTuples) <- + if ipiv >= 0 + then (,) Nothing <$> go ptrs0 + else + case ptrs0 of + [] -> error "Symmetric.determinant: incomplete 2x2 block" + (_ipiv1Ptr,a1Ptr):ptrs1 -> + let bPtr = + case order of + ColumnMajor -> advancePtr a1Ptr (-1) + RowMajor -> advancePtr a0Ptr 1 + in (,) (Just (a1Ptr,bPtr)) <$> go ptrs1 + return $ (a0Ptr,ext) : ptrTuples + go [] = return [] + in go + +determinant :: + (Mirror mirror, Layout.UpLo uplo, + Shape.C sh, Class.Floating a, Class.Floating ar) => + ((Ptr a, Maybe (Ptr a, Ptr a)) -> IO ar) -> + Mosaic pack mirror uplo sh a -> ar +determinant peekBlockDeterminant + (Array shape@(Layout.Mosaic pack mirror uplo order sh) a) = + unsafePerformIO $ evalContT $ do + + let conj = conjugationFromMirror mirror + let n = Shape.size sh + uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order + nPtr <- Call.cint n + aPtr <- copyToTemp (Shape.size shape) a + ipivPtr <- Call.allocaArray n + let diagPtrs = + case pack of + Layout.Packed -> diagonalPointers order n aPtr + Layout.Unpacked -> take n $ pointerSeq (n+1) aPtr + let (utrf,ptrf) = + case conj of + Conjugated -> + (label "hptrf" LapackGen.hptrf, label "hetrf" LapackGen.hetrf) + NonConjugated -> + (label "sptrf" LapackGen.sptrf, label "sytrf" LapackGen.sytrf) + let Labelled name makeTrf = + runPacking pack $ fmap autoWorkspace $ + applyFuncPair utrf ptrf uploPtr nPtr (triArg aPtr n) ipivPtr + trf <- makeTrf + liftIO $ + withDeterminantInfo name trf + ((return $!) =<< + LazyIO.run + (fmap product $ + mapM (LazyIO.interleave . peekBlockDeterminant) =<< + blockDiagonalPointers order (zip (pointerSeq 1 ipivPtr) diagPtrs))) + +autoWorkspace :: + (Class.Floating a) => (Ptr a -> Ptr CInt -> info -> IO ()) -> info -> IO () +autoWorkspace trf info = + withAutoWorkspace $ \work lwork -> trf work lwork info diff --git a/src/Numeric/LAPACK/Matrix/Triangular.hs b/src/Numeric/LAPACK/Matrix/Triangular.hs --- a/src/Numeric/LAPACK/Matrix/Triangular.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular.hs @@ -1,39 +1,34 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Triangular ( Triangular, MatrixShape.UpLo, - Diagonal, FlexDiagonal, - Upper, FlexUpper, UnitUpper, - Lower, FlexLower, UnitLower, - Symmetric, FlexSymmetric, + Upper, FlexUpper, Triangular.UnitUpper, Triangular.QuasiUpper, + Lower, FlexLower, Triangular.UnitLower, size, fromList, autoFromList, - diagonalFromList, autoDiagonalFromList, lowerFromList, autoLowerFromList, upperFromList, autoUpperFromList, - symmetricFromList, autoSymmetricFromList, - asDiagonal, asLower, asUpper, asSymmetric, - requireUnitDiagonal, requireNonUnitDiagonal, - relaxUnitDiagonal, strictNonUnitDiagonal, - identity, + asLower, asUpper, + requireUnitDiagonal, requireArbitraryDiagonal, + relaxUnitDiagonal, strictArbitraryDiagonal, + OmniMatrix.identityOrder, diagonal, takeDiagonal, transpose, adjoint, - stackDiagonal, (%%%), stackLower, (#%%%), stackUpper, (%%%#), - stackSymmetric, (#%%%#), - splitDiagonal, splitLower, splitUpper, - splitSymmetric, takeTopLeft, takeTopRight, takeBottomLeft, takeBottomRight, + pack, toSquare, takeLower, takeUpper, @@ -44,8 +39,6 @@ add, sub, - Tri.PowerDiag, - Tri.PowerContentDiag, multiplyVector, square, multiply, @@ -62,122 +55,143 @@ import qualified Numeric.LAPACK.Matrix.Triangular.Eigen as Eigen import qualified Numeric.LAPACK.Matrix.Triangular.Linear as Linear import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Triangular.Private as Tri +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Mosaic.Packed as Packed +import qualified Numeric.LAPACK.Matrix.Mosaic.Generic as Mos +import qualified Numeric.LAPACK.Matrix.Basic as FullBasic +import qualified Numeric.LAPACK.Matrix.Array.Mosaic as Triangular +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as ArrUnpacked +import qualified Numeric.LAPACK.Matrix.Array.Basic as OmniMatrix import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Class as MatrixClass +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent as Extent -import Numeric.LAPACK.Matrix.Array.Triangular ( - Triangular, - Diagonal, FlexDiagonal, - Lower, FlexLower, UnitLower, - Upper, FlexUpper, UnitUpper, - Symmetric, FlexSymmetric, +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array.Mosaic ( + Triangular, TriangularP, + Lower, FlexLower, FlexLowerP, + Upper, FlexUpper, FlexUpperP, ) -import Numeric.LAPACK.Matrix.Array (Full, General, Square) -import Numeric.LAPACK.Matrix.Shape.Private (NonUnit, Unit, Order) +import Numeric.LAPACK.Matrix.Array.Unpacked (Unpacked) +import Numeric.LAPACK.Matrix.Array (Full, General, Square, packTag, diagTag) +import Numeric.LAPACK.Matrix.Shape.Omni (Arbitrary, Unit) +import Numeric.LAPACK.Matrix.Layout.Private (Order, Filled) import Numeric.LAPACK.Matrix.Private (ShapeInt) import Numeric.LAPACK.Vector (Vector) import qualified Numeric.Netlib.Class as Class +import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable (Array) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) -import Data.Tuple.HT (mapTriple) +import Data.Tuple.HT (mapPair) +import Data.Function.HT (Id) -size :: Triangular lo diag up sh a -> sh -size = MatrixShape.triangularSize . ArrMatrix.shape +size :: TriangularP pack lo diag up sh a -> sh +size = Omni.squareSize . ArrMatrix.shape transpose :: - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag) => - Triangular lo diag up sh a -> Triangular up diag lo sh a -transpose = ArrMatrix.lift1 Basic.transpose + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => + TriangularP pack lo diag up sh a -> TriangularP pack up diag lo sh a +transpose = Matrix.transpose adjoint :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular up diag lo sh a -adjoint = ArrMatrix.lift1 Basic.adjoint + TriangularP pack lo diag up sh a -> TriangularP pack up diag lo sh a +adjoint = MatrixClass.adjoint + fromList :: - (MatrixShape.Content lo, MatrixShape.Content up, Shape.C sh, Storable a) => - Order -> sh -> [a] -> Triangular lo NonUnit up sh a -fromList order sh = ArrMatrix.lift0 . Basic.fromList order sh + (MatrixShape.UpLo lo up, Shape.C sh, Storable a) => + Order -> sh -> [a] -> Triangular lo Arbitrary up sh a +fromList order sh xs = + let m = + case uploTag m of + MatrixShape.Upper -> upperFromList order sh xs + MatrixShape.Lower -> lowerFromList order sh xs + in m lowerFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Lower sh a -lowerFromList = fromList +lowerFromList order sh = ArrMatrix.lift0 . Mos.fromList order sh upperFromList :: (Shape.C sh, Storable a) => Order -> sh -> [a] -> Upper sh a -upperFromList = fromList - -symmetricFromList :: - (Shape.C sh, Storable a) => Order -> sh -> [a] -> Symmetric sh a -symmetricFromList = fromList - -diagonalFromList :: - (Shape.C sh, Storable a) => Order -> sh -> [a] -> Diagonal sh a -diagonalFromList = fromList +upperFromList order sh = ArrMatrix.lift0 . Mos.fromList order sh autoFromList :: - (MatrixShape.Content lo, MatrixShape.Content up, Storable a) => - Order -> [a] -> Triangular lo NonUnit up ShapeInt a -autoFromList order = ArrMatrix.lift0 . Basic.autoFromList order + (MatrixShape.UpLo lo up, Storable a) => + Order -> [a] -> Triangular lo Arbitrary up ShapeInt a +autoFromList order xs = + let m = + case uploTag m of + MatrixShape.Upper -> autoUpperFromList order xs + MatrixShape.Lower -> autoLowerFromList order xs + in m autoLowerFromList :: (Storable a) => Order -> [a] -> Lower ShapeInt a -autoLowerFromList = autoFromList +autoLowerFromList order = ArrMatrix.lift0 . Mos.autoFromList order autoUpperFromList :: (Storable a) => Order -> [a] -> Upper ShapeInt a -autoUpperFromList = autoFromList - -autoSymmetricFromList :: (Storable a) => Order -> [a] -> Symmetric ShapeInt a -autoSymmetricFromList = autoFromList - -autoDiagonalFromList :: (Storable a) => Order -> [a] -> Diagonal ShapeInt a -autoDiagonalFromList = autoFromList +autoUpperFromList order = ArrMatrix.lift0 . Mos.autoFromList order -asDiagonal :: FlexDiagonal diag sh a -> FlexDiagonal diag sh a -asDiagonal = id - -asLower :: FlexLower diag sh a -> FlexLower diag sh a +asLower :: Id (FlexLowerP pack diag sh a) asLower = id -asUpper :: FlexUpper diag sh a -> FlexUpper diag sh a +asUpper :: Id (FlexUpperP pack diag sh a) asUpper = id -asSymmetric :: FlexSymmetric diag sh a -> FlexSymmetric diag sh a -asSymmetric = id -requireUnitDiagonal :: Triangular lo Unit up sh a -> Triangular lo Unit up sh a +requireUnitDiagonal :: Id (TriangularP pack lo Unit up sh a) requireUnitDiagonal = id -requireNonUnitDiagonal :: - Triangular lo NonUnit up sh a -> Triangular lo NonUnit up sh a -requireNonUnitDiagonal = id +requireArbitraryDiagonal :: Id (TriangularP pack lo Arbitrary up sh a) +requireArbitraryDiagonal = id +pack :: + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + TriangularP pack lo diag up sh a -> Triangular lo diag up sh a +pack a = + case uploTag a of + MatrixShape.Lower -> ArrMatrix.lift1 Mosaic.pack a + MatrixShape.Upper -> ArrMatrix.lift1 Mosaic.pack a + toSquare :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Square sh a -toSquare = ArrMatrix.lift1 Basic.toSquare + TriangularP pack lo diag up sh a -> Square sh a +toSquare = OmniMatrix.toFull takeLower :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> Lower height a -takeLower = ArrMatrix.lift1 Basic.takeLower + (Omni.Property property, Omni.Strip upper) => + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Unpacked property Filled upper meas Extent.Small horiz height width a -> + Lower height a +takeLower = ArrMatrix.lift0 . Basic.takeLower . ArrMatrix.unpackedToVector takeUpper :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> Upper width a -takeUpper = ArrMatrix.lift1 Basic.takeUpper + (Omni.Property property, Omni.Strip lower) => + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Unpacked property lower Filled meas vert Extent.Small height width a -> + Upper width a +takeUpper = ArrMatrix.lift0 . Basic.takeUpper . ArrMatrix.unpackedToVector fromLowerRowMajor :: (Shape.C sh, Class.Floating a) => @@ -200,244 +214,297 @@ toUpperRowMajor = Basic.toUpperRowMajor . ArrMatrix.toVector forceOrder :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Order -> Triangular lo diag up sh a -> Triangular lo diag up sh a -forceOrder = ArrMatrix.lift1 . Basic.forceOrder + Order -> TriangularP pack lo diag up sh a -> TriangularP pack lo diag up sh a +forceOrder = ArrMatrix.forceOrder {- | @adaptOrder x y@ contains the data of @y@ with the layout of @x@. -} adaptOrder :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo diag up sh a -> - Triangular lo diag up sh a -adaptOrder = ArrMatrix.lift2 Basic.adaptOrder + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a +adaptOrder = ArrMatrix.adaptOrder add, sub :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, Eq lo, Eq up, Eq sh, Shape.C sh, Class.Floating a) => - Triangular lo NonUnit up sh a -> - Triangular lo NonUnit up sh a -> - Triangular lo NonUnit up sh a -add = ArrMatrix.lift2 Basic.add -sub = ArrMatrix.lift2 Basic.sub + TriangularP pack lo Arbitrary up sh a -> + TriangularP pack lo Arbitrary up sh a -> + TriangularP pack lo Arbitrary up sh a +add = ArrMatrix.add +sub = ArrMatrix.sub +{- identity :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, Shape.C sh, Class.Floating a) => Order -> sh -> Triangular lo Unit up sh a identity order = ArrMatrix.lift0 . Basic.identity order +-} diagonal :: - (MatrixShape.Content lo, MatrixShape.Content up, - Shape.C sh, Class.Floating a) => - Order -> Vector sh a -> Triangular lo NonUnit up sh a -diagonal order = ArrMatrix.lift0 . Basic.diagonal order + (MatrixShape.UpLo lo up, Shape.C sh, Class.Floating a) => + Order -> Vector sh a -> Triangular lo Arbitrary up sh a +diagonal order v = + getDiagonal $ + MatrixShape.switchUpLo + (Diagonal $ ArrMatrix.lift0 $ Packed.diagonal order v) + (Diagonal $ ArrMatrix.lift0 $ Packed.diagonal order v) +newtype Diagonal_ sh a lo up = + Diagonal { + getDiagonal :: Triangular lo Arbitrary up sh a + } + takeDiagonal :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -takeDiagonal = Basic.takeDiagonal . ArrMatrix.toVector + TriangularP pack lo diag up sh a -> Vector sh a +takeDiagonal = OmniMatrix.takeDiagonal + + relaxUnitDiagonal :: (MatrixShape.TriDiag diag) => - Triangular lo Unit up sh a -> Triangular lo diag up sh a -relaxUnitDiagonal = ArrMatrix.lift1 Basic.relaxUnitDiagonal + TriangularP pack lo Unit up sh a -> TriangularP pack lo diag up sh a +relaxUnitDiagonal a@(ArrMatrix.Array _arr) = + case ArrMatrix.shape a of + Omni.Full _ -> ArrMatrix.liftUnpacked1 id a + Omni.LowerTriangular _ -> ArrMatrix.lift1 id a + Omni.UpperTriangular _ -> ArrMatrix.lift1 id a + Omni.UnitBandedTriangular _ -> + let m = + case diagTag m of + Omni.Unit -> a + Omni.Arbitrary -> ArrMatrix.lift1 id a + in m -strictNonUnitDiagonal :: +strictArbitraryDiagonal :: (MatrixShape.TriDiag diag) => - Triangular lo diag up sh a -> Triangular lo NonUnit up sh a -strictNonUnitDiagonal = ArrMatrix.lift1 Basic.strictNonUnitDiagonal + TriangularP pack lo diag up sh a -> TriangularP pack lo Arbitrary up sh a +strictArbitraryDiagonal a = + case diagTag a of + Omni.Arbitrary -> a + Omni.Unit -> + case ArrMatrix.shape a of + Omni.Full _ -> ArrMatrix.liftUnpacked1 id a + Omni.LowerTriangular _ -> ArrMatrix.lift1 id a + Omni.UpperTriangular _ -> ArrMatrix.lift1 id a + Omni.UnitBandedTriangular _ -> ArrMatrix.lift1 id a -infixr 2 %%%, %%%#, #%%%# +infixr 2 %%%# infixl 2 #%%% -stackDiagonal, (%%%) :: - (MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - FlexDiagonal diag sh0 a -> - FlexDiagonal diag sh1 a -> - FlexDiagonal diag (sh0:+:sh1) a -stackDiagonal = ArrMatrix.lift2 Basic.stackDiagonal -(%%%) = stackDiagonal - stackLower :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexLower diag sh0 a -> + FlexLowerP pack diag sh0 a -> General sh1 sh0 a -> - FlexLower diag sh1 a -> - FlexLower diag (sh0:+:sh1) a -stackLower = ArrMatrix.lift3 Basic.stackLower + FlexLowerP pack diag sh1 a -> + FlexLowerP pack diag (sh0::+sh1) a +stackLower a0 = + case packTag a0 of + Layout.Packed -> ArrMatrix.lift3 Packed.stackLower a0 + Layout.Unpacked -> ($a0) $ + ArrMatrix.liftUnpacked3 $ \a b c -> + FullBasic.stackMosaic + a (Vector.zero $ Layout.inverse $ Array.shape b) + b c (#%%%) :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexLower diag sh0 a -> - (General sh1 sh0 a, FlexLower diag sh1 a) -> - FlexLower diag (sh0:+:sh1) a + FlexLowerP pack diag sh0 a -> + (General sh1 sh0 a, FlexLowerP pack diag sh1 a) -> + FlexLowerP pack diag (sh0::+sh1) a (#%%%) = uncurry . stackLower stackUpper :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexUpper diag sh0 a -> + FlexUpperP pack diag sh0 a -> General sh0 sh1 a -> - FlexUpper diag sh1 a -> - FlexUpper diag (sh0:+:sh1) a -stackUpper = ArrMatrix.lift3 Basic.stackUpper + FlexUpperP pack diag sh1 a -> + FlexUpperP pack diag (sh0::+sh1) a +stackUpper a0 = + case packTag a0 of + Layout.Packed -> ArrMatrix.lift3 Packed.stackUpper a0 + Layout.Unpacked -> ($a0) $ + ArrMatrix.liftUnpacked3 $ \a b c -> + FullBasic.stackMosaic a b + (Vector.zero $ Layout.inverse $ Array.shape b) c (%%%#) :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - (FlexUpper diag sh0 a, General sh0 sh1 a) -> - FlexUpper diag sh1 a -> - FlexUpper diag (sh0:+:sh1) a + (FlexUpperP pack diag sh0 a, General sh0 sh1 a) -> + FlexUpperP pack diag sh1 a -> + FlexUpperP pack diag (sh0::+sh1) a (%%%#) = uncurry stackUpper -stackSymmetric :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexSymmetric diag sh0 a -> - General sh0 sh1 a -> - FlexSymmetric diag sh1 a -> - FlexSymmetric diag (sh0:+:sh1) a -stackSymmetric = ArrMatrix.lift3 Basic.stackSymmetric -(#%%%#) :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - (FlexSymmetric diag sh0 a, General sh0 sh1 a) -> - FlexSymmetric diag sh1 a -> - FlexSymmetric diag (sh0:+:sh1) a -(#%%%#) = uncurry stackSymmetric - - -splitDiagonal :: - (MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - FlexDiagonal diag (sh0:+:sh1) a -> - (FlexDiagonal diag sh0 a, FlexDiagonal diag sh1 a) -splitDiagonal a = (takeTopLeft a, takeBottomRight a) - splitLower :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexLower diag (sh0:+:sh1) a -> - (FlexLower diag sh0 a, General sh1 sh0 a, FlexLower diag sh1 a) + FlexLowerP pack diag (sh0::+sh1) a -> + (FlexLowerP pack diag sh0 a, General sh1 sh0 a, FlexLowerP pack diag sh1 a) splitLower a = (takeTopLeft a, takeBottomLeft a, takeBottomRight a) splitUpper :: - (MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexUpper diag (sh0:+:sh1) a -> - (FlexUpper diag sh0 a, General sh0 sh1 a, FlexUpper diag sh1 a) + FlexUpperP pack diag (sh0::+sh1) a -> + (FlexUpperP pack diag sh0 a, General sh0 sh1 a, FlexUpperP pack diag sh1 a) splitUpper a = (takeTopLeft a, takeTopRight a, takeBottomRight a) -splitSymmetric :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexSymmetric diag (sh0:+:sh1) a -> - (FlexSymmetric diag sh0 a, General sh0 sh1 a, FlexSymmetric diag sh1 a) -splitSymmetric a = (takeTopLeft a, takeTopRight a, takeBottomRight a) - takeTopLeft :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag up (sh0:+:sh1) a -> - Triangular lo diag up sh0 a -takeTopLeft = ArrMatrix.lift1 Basic.takeTopLeft + TriangularP pack lo diag up (sh0::+sh1) a -> + TriangularP pack lo diag up sh0 a +takeTopLeft a = + case packTag a of + Layout.Unpacked -> ArrUnpacked.takeTopLeft a + Layout.Packed -> + case uploTag a of + MatrixShape.Lower -> ArrMatrix.lift1 Packed.takeTopLeft a + MatrixShape.Upper -> ArrMatrix.lift1 Packed.takeTopLeft a takeBottomLeft :: - (MatrixShape.TriDiag diag, MatrixShape.Content up, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular MatrixShape.Filled diag up (sh0:+:sh1) a -> - General sh1 sh0 a -takeBottomLeft = ArrMatrix.lift1 Basic.takeBottomLeft + FlexLowerP pack diag (sh0::+sh1) a -> General sh1 sh0 a +takeBottomLeft a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeBottomLeft a + Layout.Unpacked -> ArrUnpacked.takeBottomLeft a takeTopRight :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag MatrixShape.Filled (sh0:+:sh1) a -> - General sh0 sh1 a -takeTopRight = ArrMatrix.lift1 Basic.takeTopRight + FlexUpperP pack diag (sh0::+sh1) a -> General sh0 sh1 a +takeTopRight a = + case packTag a of + Layout.Packed -> ArrMatrix.lift1 Packed.takeTopRight a + Layout.Unpacked -> ArrUnpacked.takeTopRight a takeBottomRight :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag up (sh0:+:sh1) a -> - Triangular lo diag up sh1 a -takeBottomRight = ArrMatrix.lift1 Basic.takeBottomRight + TriangularP pack lo diag up (sh0::+sh1) a -> + TriangularP pack lo diag up sh1 a +takeBottomRight a = + case packTag a of + Layout.Unpacked -> ArrUnpacked.takeBottomRight a + Layout.Packed -> + case uploTag a of + MatrixShape.Lower -> ArrMatrix.lift1 Packed.takeBottomRight a + MatrixShape.Upper -> ArrMatrix.lift1 Packed.takeBottomRight a +uploTag :: + (MatrixShape.UpLo lo up) => + TriangularP pack lo diag up sh a -> MatrixShape.UpLoSingleton lo up +uploTag _ = MatrixShape.autoUplo + + multiplyVector :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -> Vector sh a -multiplyVector = Basic.multiplyVector . ArrMatrix.toVector + TriangularP pack lo diag up sh a -> Vector sh a -> Vector sh a +multiplyVector a = + case uploTag a of + MatrixShape.Upper -> + Basic.multiplyVector (diagTag a) $ ArrMatrix.toVector a + MatrixShape.Lower -> + Basic.multiplyVector (diagTag a) $ ArrMatrix.toVector a -{- | -Include symmetric matrices. -However, symmetric matrices do not preserve unit diagonals. --} square :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo (Tri.PowerDiag lo up diag) up sh a -square = ArrMatrix.lift1 Basic.square + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Shape.C sh, Class.Floating a) => + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a +square a = + case uploTag a of + MatrixShape.Upper -> ArrMatrix.lift1 (Mosaic.square $ diagTag a) a + MatrixShape.Lower -> ArrMatrix.lift1 (Mosaic.square $ diagTag a) a multiply :: - (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular lo diag up sh a -> - Triangular lo diag up sh a -multiply = ArrMatrix.lift2 Basic.multiply + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a +multiply a = + case uploTag a of + MatrixShape.Upper -> ArrMatrix.lift2 (Basic.multiply $ diagTag a) a + MatrixShape.Lower -> ArrMatrix.lift2 (Basic.multiply $ diagTag a) a multiplyFull :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, - Class.Floating a) => - Triangular lo diag up height a -> - Full vert horiz height width a -> - Full vert horiz height width a -multiplyFull = ArrMatrix.lift2 Basic.multiplyFull + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Class.Floating a) => + TriangularP pack lo diag up height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull a = + case uploTag a of + MatrixShape.Upper -> ArrMatrix.lift2 (Basic.multiplyFull $ diagTag a) a + MatrixShape.Lower -> ArrMatrix.lift2 (Basic.multiplyFull $ diagTag a) a solve :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Triangular lo diag up sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve = ArrMatrix.lift2 Linear.solve + TriangularP pack lo diag up sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve a = + case uploTag a of + MatrixShape.Upper -> ArrMatrix.lift2 (Linear.solve $ diagTag a) a + MatrixShape.Lower -> ArrMatrix.lift2 (Linear.solve $ diagTag a) a inverse :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo (Basic.PowerDiag lo up diag) up sh a -inverse = ArrMatrix.lift1 Linear.inverse + TriangularP pack lo diag up sh a -> + TriangularP pack lo diag up sh a +inverse a = + case uploTag a of + MatrixShape.Upper -> ArrMatrix.lift1 (Linear.inverse $ diagTag a) a + MatrixShape.Lower -> ArrMatrix.lift1 (Linear.inverse $ diagTag a) a determinant :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (Layout.Packing pack, MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> a -determinant = Linear.determinant . ArrMatrix.toVector + TriangularP pack lo diag up sh a -> a +determinant a = + case diagTag a of + MatrixShape.Unit -> Scalar.one + MatrixShape.Arbitrary -> + case uploTag a of + MatrixShape.Upper -> Linear.determinant $ ArrMatrix.toVector a + MatrixShape.Lower -> Linear.determinant $ ArrMatrix.toVector a eigenvalues :: - (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -eigenvalues = Eigen.values . ArrMatrix.toVector + (Layout.Packing pack, MatrixShape.DiagUpLo lo up, + Shape.C sh, Class.Floating a) => + TriangularP pack lo diag up sh a -> Vector sh a +eigenvalues = OmniMatrix.takeDiagonal {- | @(vr,d,vlAdj) = eigensystem a@ @@ -461,9 +528,33 @@ and the above property does not hold. -} eigensystem :: - (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo NonUnit up sh a -> - (Triangular lo NonUnit up sh a, Vector sh a, Triangular lo NonUnit up sh a) -eigensystem = - mapTriple (ArrMatrix.lift0, id, ArrMatrix.lift0) . - Eigen.decompose . ArrMatrix.toVector + (Layout.Packing pack, MatrixShape.DiagUpLo lo up, + Shape.C sh, Class.Floating a) => + TriangularP pack lo Arbitrary up sh a -> + (TriangularP pack lo Arbitrary up sh a, Vector sh a, + TriangularP pack lo Arbitrary up sh a) +eigensystem a = + let (vr,vl) = + getEigensystem + (MatrixShape.switchDiagUpLo + (Eigensystem $ + (\eye -> (eye, Matrix.transpose eye)) . + OmniMatrix.identityFromShape . + Omni.uncheckedDiagonal Layout.ColumnMajor . + Omni.squareSize . ArrMatrix.shape) + (Eigensystem $ + mapPair (ArrMatrix.lift0, ArrMatrix.lift0) . + Eigen.decompose . ArrMatrix.toVector) + (Eigensystem $ + mapPair (ArrMatrix.lift0, ArrMatrix.lift0) . + Eigen.decompose . ArrMatrix.toVector)) + a + in (vr, eigenvalues a, vl) + +newtype Eigensystem pack sh a lo up = + Eigensystem { + getEigensystem :: + TriangularP pack lo Arbitrary up sh a -> + (TriangularP pack lo Arbitrary up sh a, + TriangularP pack lo Arbitrary up sh a) + } diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs b/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs --- a/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular/Basic.hs @@ -1,28 +1,10 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Triangular.Basic ( - Triangular, MatrixShape.UpLo, - Diagonal, - Upper, FlexUpper, UnitUpper, - Lower, FlexLower, UnitLower, - Symmetric, FlexSymmetric, - fromList, autoFromList, - relaxUnitDiagonal, strictNonUnitDiagonal, - identity, - diagonal, - takeDiagonal, - transpose, - adjoint, - - stackDiagonal, - stackLower, - stackUpper, - stackSymmetric, - takeTopLeft, - takeTopRight, - takeBottomLeft, - takeBottomRight, + Triangular, TriangularP, + Layout.UpLo, + Upper, + Lower, toSquare, takeLower, @@ -30,461 +12,135 @@ fromLowerRowMajor, toLowerRowMajor, fromUpperRowMajor, toUpperRowMajor, - forceOrder, adaptOrder, - - add, sub, + forceOrder, - Tri.PowerDiag, - Tri.PowerContentDiag, multiplyVector, - square, power, multiply, multiplyFull, ) where -import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric -import qualified Numeric.LAPACK.Matrix.Triangular.Private as Tri -import qualified Numeric.LAPACK.Matrix.Private as Matrix -import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Mosaic.Unpacked as Unpacked +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Vector.Private as VectorPriv -import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Triangular.Private - (Triangular, FlexDiagonal, diagonalPointers, diagonalPointerPairs, - pack, packRect, unpack, unpackZero, unpackToTemp, uncheck, recheck) -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Mosaic.Private + (Triangular, Lower, Upper, + withPacking, noLabel, applyFuncPair, triArg) +import Numeric.LAPACK.Matrix.Mosaic.Packed (forceOrder) +import Numeric.LAPACK.Matrix.Mosaic.Generic (unpackDirty, repack) +import Numeric.LAPACK.Matrix.Shape.Omni (TriDiag, DiagSingleton, charFromTriDiag) +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor,ColumnMajor), - flipOrder, transposeFromOrder, uploFromOrder, uploOrder, - Unit(Unit), NonUnit(NonUnit), charFromTriDiag) -import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) -import Numeric.LAPACK.Matrix.Private (Full, Square, ShapeInt, shapeInt) + transposeFromOrder, uploFromOrder, uploOrder) +import Numeric.LAPACK.Matrix.Private (Full, Square) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (zero, one) -import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) -import Numeric.LAPACK.Private (fill, copyBlock) +import Numeric.LAPACK.Private (copyBlock) -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.BLAS.FFI.Real as BlasReal import qualified Numeric.BLAS.FFI.Generic as BlasGen import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape ((:+:)((:+:))) -import Foreign.C.Types (CChar, CInt) import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable, poke, peek) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) -import Data.Function.HT (powerAssociative) -import Data.Foldable (forM_) -import Data.Tuple.HT (double) - -type Lower sh = FlexLower NonUnit sh -type Upper sh = FlexUpper NonUnit sh -type Symmetric sh = FlexSymmetric NonUnit sh -type Diagonal sh = FlexDiagonal NonUnit sh - -type UnitLower sh = FlexLower Unit sh -type UnitUpper sh = FlexUpper Unit sh - -type FlexLower diag sh = Array (MatrixShape.LowerTriangular diag sh) -type FlexUpper diag sh = Array (MatrixShape.UpperTriangular diag sh) -type FlexSymmetric diag sh = Array (MatrixShape.FlexSymmetric diag sh) - -transpose :: - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag) => - Triangular lo diag up sh a -> Triangular up diag lo sh a -transpose (Array sh a) = - Array (MatrixShape.triangularTranspose sh) a - -adjoint :: - (MatrixShape.Content lo, MatrixShape.Content up, - MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular up diag lo sh a -adjoint = Vector.conjugate . transpose +type TriangularP pack uplo sh = Array (Layout.TriangularP pack uplo sh) -fromList :: - (MatrixShape.Content lo, MatrixShape.Content up, Shape.C sh, Storable a) => - Order -> sh -> [a] -> Triangular lo NonUnit up sh a -fromList order sh = - CheckedArray.fromList - (MatrixShape.Triangular NonUnit MatrixShape.autoUplo order sh) +toSquare :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Triangular uplo sh a -> Square sh a +toSquare + (Array + (Layout.Mosaic Layout.Packed Layout.NoMirror uplo order sh) + a) = + Array.unsafeCreate (Layout.square order sh) $ \bPtr -> + withForeignPtr a $ \aPtr -> + Mos.unpackZero (uploOrder uplo order) (Shape.size sh) aPtr bPtr +unpack :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Triangular uplo sh a -> Unpacked.Triangular uplo sh a +unpack (Array (Layout.Mosaic Layout.Packed mirror uplo order sh) a) = + Array.unsafeCreate + (Layout.Mosaic Layout.Unpacked mirror uplo order sh) $ + \bPtr -> + withForeignPtr a $ \aPtr -> + Mos.unpackZero (uploOrder uplo order) (Shape.size sh) aPtr bPtr -autoFromList :: - (MatrixShape.Content lo, MatrixShape.Content up, Storable a) => - Order -> [a] -> Triangular lo NonUnit up ShapeInt a -autoFromList order xs = - let n = length xs - triSize = MatrixShape.triangleExtent "Triangular.autoFromList" n - uplo = MatrixShape.autoUplo - size = MatrixShape.caseDiagUpLoSym uplo n triSize triSize triSize - in Array.fromList - (MatrixShape.Triangular - MatrixShape.autoDiag uplo order (shapeInt size)) - xs +unpackGen :: + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + TriangularP pack uplo sh a -> Unpacked.Triangular uplo sh a +unpackGen a = + case Layout.mosaicPack $ Array.shape a of + Layout.Unpacked -> a + Layout.Packed -> unpack a -toSquare :: - (MatrixShape.Content lo, MatrixShape.Content up, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Square sh a -toSquare (Array (MatrixShape.Triangular _diag uplo order sh) a) = - Array.unsafeCreateWithSize (MatrixShape.square order sh) $ \size bPtr -> - let n = Shape.size sh - in withForeignPtr a $ \aPtr -> - MatrixShape.caseDiagUpLoSym uplo - (do - fill zero size bPtr - evalContT $ do - nPtr <- Call.cint n - incxPtr <- Call.cint 1 - incyPtr <- Call.cint (n+1) - liftIO $ BlasGen.copy nPtr aPtr incxPtr bPtr incyPtr) - (unpackZero order n aPtr bPtr) - (unpackZero (flipOrder order) n aPtr bPtr) - (Symmetric.unpack NonConjugated order n aPtr bPtr) - takeLower :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> Lower height a -takeLower = - Tri.takeLower (MatrixShape.NonUnit, const $ const $ const $ return ()) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> Lower height a +takeLower = Mos.fromLowerPart Mos.leaveDiagonal Layout.NoMirror takeUpper :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> Upper width a -takeUpper (Array (MatrixShape.Full order extent) a) = + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert Extent.Small height width a -> Upper width a +takeUpper (Array (Layout.Full order extent) a) = let (height,width) = Extent.dimensions extent m = Shape.size height n = Shape.size width k = case order of RowMajor -> n; ColumnMajor -> m in Array.unsafeCreate - (MatrixShape.Triangular MatrixShape.NonUnit - MatrixShape.upper order width) $ \bPtr -> - withForeignPtr a $ \aPtr -> packRect order n k aPtr bPtr + (Layout.Mosaic Layout.Packed + Layout.NoMirror Layout.Upper order width) $ \bPtr -> + withForeignPtr a $ \aPtr -> Mos.packRect order n k aPtr bPtr fromLowerRowMajor :: (Shape.C sh, Class.Floating a) => Array (Shape.Triangular Shape.Lower sh) a -> Lower sh a fromLowerRowMajor = - Array.mapShape - (MatrixShape.Triangular MatrixShape.NonUnit MatrixShape.lower RowMajor . - Shape.triangularSize) + Array.mapShape (Layout.lowerTriangular RowMajor . Shape.triangularSize) fromUpperRowMajor :: (Shape.C sh, Class.Floating a) => Array (Shape.Triangular Shape.Upper sh) a -> Upper sh a fromUpperRowMajor = - Array.mapShape - (MatrixShape.Triangular MatrixShape.NonUnit MatrixShape.upper RowMajor . - Shape.triangularSize) + Array.mapShape (Layout.upperTriangular RowMajor . Shape.triangularSize) toLowerRowMajor :: (Shape.C sh, Class.Floating a) => Lower sh a -> Array (Shape.Triangular Shape.Lower sh) a toLowerRowMajor = - Array.mapShape (Shape.Triangular Shape.Lower . MatrixShape.triangularSize) + Array.mapShape (Shape.Triangular Shape.Lower . Layout.mosaicSize) . - forceOrder MatrixShape.RowMajor + forceOrder Layout.RowMajor toUpperRowMajor :: (Shape.C sh, Class.Floating a) => Upper sh a -> Array (Shape.Triangular Shape.Upper sh) a toUpperRowMajor = - Array.mapShape (Shape.Triangular Shape.Upper . MatrixShape.triangularSize) + Array.mapShape (Shape.Triangular Shape.Upper . Layout.mosaicSize) . - forceOrder MatrixShape.RowMajor - -{- -This is not maximally efficient. -It fills up a whole square. -This wastes memory but enables more regular memory access patterns. -Additionally, it fills unused parts of the square with zero or mirrored values. --} -forceOrder :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Order -> Triangular lo diag up sh a -> Triangular lo diag up sh a -forceOrder newOrder = - Tri.getMap $ - MatrixShape.switchDiagUpLoSym - (Tri.Map $ - Array.mapShape (\sh -> sh{MatrixShape.triangularOrder = newOrder})) - (forceOrderMap newOrder takeUpper) - (forceOrderMap newOrder takeLower) - (forceOrderMap newOrder $ - Array.mapShape - (\sh -> sh{MatrixShape.triangularUplo = MatrixShape.autoUplo}) - . - takeUpper) - -forceOrderMap :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Order -> - (Square sh a -> Triangular lo NonUnit up sh a) -> - Tri.Map diag sh sh a lo up -forceOrderMap newOrder f = Tri.Map $ \a -> - if MatrixShape.triangularOrder (Array.shape a) == newOrder - then a - else uncheckedRelaxNonUnitDiagonal $ - f $ Basic.forceOrder newOrder $ toSquare a - -uncheckedRelaxNonUnitDiagonal :: - (MatrixShape.TriDiag diag) => - Triangular lo NonUnit up sh a -> Triangular lo diag up sh a -uncheckedRelaxNonUnitDiagonal = - Array.mapShape (\sh -> sh{MatrixShape.triangularDiag = MatrixShape.autoDiag}) - -adaptOrder :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo diag up sh a -> - Triangular lo diag up sh a -adaptOrder x = forceOrder (MatrixShape.triangularOrder $ Array.shape x) - -add, sub :: - (MatrixShape.Content lo, MatrixShape.Content up, - Eq lo, Eq up, Eq sh, Shape.C sh, Class.Floating a) => - Triangular lo NonUnit up sh a -> - Triangular lo NonUnit up sh a -> - Triangular lo NonUnit up sh a -add x y = Vector.add (adaptOrder y x) y -sub x y = Vector.sub (adaptOrder y x) y - - -identity :: - (MatrixShape.Content lo, MatrixShape.Content up, - Shape.C sh, Class.Floating a) => - Order -> sh -> Triangular lo Unit up sh a -identity order sh = - let (realOrder, uplo) = autoUploOrder order - in Array.unsafeCreateWithSize (MatrixShape.Triangular Unit uplo order sh) $ - \size aPtr -> do - let n = Shape.size sh - let fillTriangle = do - fill zero size aPtr - mapM_ (flip poke one) (diagonalPointers realOrder n aPtr) - MatrixShape.caseDiagUpLoSym uplo - (fill one n aPtr) - fillTriangle - fillTriangle - fillTriangle - -diagonal, diagonalAux :: - (MatrixShape.Content lo, MatrixShape.Content up, - Shape.C sh, Class.Floating a) => - Order -> Vector sh a -> Triangular lo NonUnit up sh a -diagonal order x@(Array sh xPtr) = - let uplo = MatrixShape.autoUplo - in MatrixShape.caseDiagUpLoSym uplo - (Array (MatrixShape.Triangular NonUnit uplo order sh) xPtr) - (diagonalAux order x) - (diagonalAux order x) - (diagonalAux order x) - -diagonalAux order (Array sh x) = - let (realOrder, uplo) = autoUploOrder order - in Array.unsafeCreateWithSize - (MatrixShape.Triangular NonUnit uplo order sh) $ - \size aPtr -> do - let n = Shape.size sh - fill zero size aPtr - withForeignPtr x $ \xPtr -> - forM_ (diagonalPointerPairs realOrder n xPtr aPtr) $ - \(srcPtr,dstPtr) -> poke dstPtr =<< peek srcPtr - - -takeDiagonal, takeDiagonalAux :: - (MatrixShape.Content lo, MatrixShape.Content up, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -takeDiagonal a@(Array (MatrixShape.Triangular _diag uplo _order sh) aPtr) = - MatrixShape.caseDiagUpLoSym uplo - (Array sh aPtr) - (takeDiagonalAux a) - (takeDiagonalAux a) - (takeDiagonalAux a) - -takeDiagonalAux (Array (MatrixShape.Triangular _diag uplo order sh) a) = - Array.unsafeCreate sh $ \xPtr -> - withForeignPtr a $ \aPtr -> - mapM_ - (\(dstPtr,srcPtr) -> poke dstPtr =<< peek srcPtr) - (diagonalPointerPairs (uploOrder uplo order) (Shape.size sh) xPtr aPtr) - -relaxUnitDiagonal :: - (MatrixShape.TriDiag diag) => - Triangular lo Unit up sh a -> Triangular lo diag up sh a -relaxUnitDiagonal = Array.mapShape MatrixShape.relaxUnitDiagonal - -strictNonUnitDiagonal :: - (MatrixShape.TriDiag diag) => - Triangular lo diag up sh a -> Triangular lo NonUnit up sh a -strictNonUnitDiagonal = Array.mapShape MatrixShape.strictNonUnitDiagonal - - -liftDiagonal :: - (Vector sh0 a -> Vector sh1 a) -> - FlexDiagonal diag sh0 a -> FlexDiagonal diag sh1 a -liftDiagonal f (Array (MatrixShape.Triangular diag uplo order sh0) a) = - Array.mapShape (MatrixShape.Triangular diag uplo order) $ f $ Array sh0 a - -stackDiagonal :: - (MatrixShape.TriDiag diag, Shape.C sh0, Shape.C sh1, Class.Floating a) => - FlexDiagonal diag sh0 a -> - FlexDiagonal diag sh1 a -> - FlexDiagonal diag (sh0:+:sh1) a -stackDiagonal a = liftDiagonal (Vector.append $ takeDiagonal a) - -{- -It does not make much sense to put -'stackLower', 'stackUpper', 'stackSymmetric' in one function -because in 'stackLower' and 'stackUpper' -the height and width of matrix b is swapped. --} -stackLower :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexLower diag sh0 a -> - Matrix.General sh1 sh0 a -> - FlexLower diag sh1 a -> - FlexLower diag (sh0:+:sh1) a -stackLower a b c = - transpose $ - stackAux "LowerTriangular" (transpose a) (Basic.transpose b) (transpose c) - -stackUpper :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexUpper diag sh0 a -> - Matrix.General sh0 sh1 a -> - FlexUpper diag sh1 a -> - FlexUpper diag (sh0:+:sh1) a -stackUpper = stackAux "UpperTriangular" - -stackSymmetric :: - (MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - FlexSymmetric diag sh0 a -> - Matrix.General sh0 sh1 a -> - FlexSymmetric diag sh1 a -> - FlexSymmetric diag (sh0:+:sh1) a -stackSymmetric = stackAux "Symmetric" - -stackAux :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, - Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Class.Floating a) => - String -> - Triangular lo diag MatrixShape.Filled sh0 a -> - Matrix.General sh0 sh1 a -> - Triangular lo diag MatrixShape.Filled sh1 a -> - Triangular lo diag MatrixShape.Filled (sh0:+:sh1) a -stackAux name a b c = - let order = MatrixShape.fullOrder $ Array.shape b - in Tri.stack name - (\sh -> - (Array.shape a) { - MatrixShape.triangularOrder = order, - MatrixShape.triangularSize = sh}) - (forceOrder order a) b (forceOrder order c) - -takeTopLeft :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag up (sh0:+:sh1) a -> - Triangular lo diag up sh0 a -takeTopLeft = - Tri.getMap $ - MatrixShape.switchDiagUpLoSym - (Tri.Map $ liftDiagonal Vector.takeLeft) - (Tri.Map $ takeTopLeftAux) - (Tri.Map $ transpose . takeTopLeftAux . transpose) - (Tri.Map $ takeTopLeftAux) - -takeTopLeftAux :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag MatrixShape.Filled (sh0:+:sh1) a -> - Triangular lo diag MatrixShape.Filled sh0 a -takeTopLeftAux = - Tri.takeTopLeft - (\(MatrixShape.Triangular diag uplo order sh@(sh0:+:_sh1)) -> - (MatrixShape.Triangular diag uplo order sh0, (order,sh))) - -takeBottomLeft :: - (MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular MatrixShape.Filled diag up (sh0:+:sh1) a -> - Matrix.General sh1 sh0 a -takeBottomLeft = Basic.transpose . takeTopRight . transpose - -takeTopRight :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag MatrixShape.Filled (sh0:+:sh1) a -> - Matrix.General sh0 sh1 a -takeTopRight = - Tri.takeTopRight - (\(MatrixShape.Triangular _diag _uplo order sh) -> (order,sh)) - -takeBottomRight :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag up (sh0:+:sh1) a -> - Triangular lo diag up sh1 a -takeBottomRight = - Tri.getMap $ - MatrixShape.switchDiagUpLoSym - (Tri.Map $ liftDiagonal Vector.takeRight) - (Tri.Map $ takeBottomRightAux) - (Tri.Map $ transpose . takeBottomRightAux . transpose) - (Tri.Map $ takeBottomRightAux) - -takeBottomRightAux :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, - Shape.C sh0, Shape.C sh1, Class.Floating a) => - Triangular lo diag MatrixShape.Filled (sh0:+:sh1) a -> - Triangular lo diag MatrixShape.Filled sh1 a -takeBottomRightAux = - Tri.takeBottomRight - (\(MatrixShape.Triangular diag uplo order sh@(_sh0:+:sh1)) -> - (MatrixShape.Triangular diag uplo order sh1, (order,sh))) + forceOrder Layout.RowMajor multiplyVector :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -> Vector sh a -multiplyVector = - Tri.getMultiplyRight $ - MatrixShape.switchDiagUpLoSym - (Tri.MultiplyRight $ Vector.mul . takeDiagonal) - (Tri.MultiplyRight multiplyVectorTriangular) - (Tri.MultiplyRight multiplyVectorTriangular) - (Tri.MultiplyRight multiplyVectorTriangular) - -multiplyVectorTriangular :: - (MatrixShape.UpLoSym lo up, MatrixShape.TriDiag diag, + (Layout.UpLo uplo, TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -> Vector sh a -multiplyVectorTriangular - (Array (MatrixShape.Triangular diag uplo order shA) a) (Array shX x) = + DiagSingleton diag -> + TriangularP pack uplo sh a -> Vector sh a -> Vector sh a +multiplyVector diag + (Array (Layout.Mosaic pack_ Layout.NoMirror uplo order shA) a) + (Array shX x) = Array.unsafeCreate shX $ \yPtr -> do Call.assert "Triangular.multiplyVector: width shapes mismatch" (shA == shX) let n = Shape.size shA @@ -495,257 +151,30 @@ nPtr <- Call.cint n aPtr <- ContT $ withForeignPtr a xPtr <- ContT $ withForeignPtr x - alphaPtr <- Call.number one - betaPtr <- Call.number zero - incxPtr <- Call.cint 1 incyPtr <- Call.cint 1 - let runTPMV = do - copyBlock n xPtr yPtr - BlasGen.tpmv uploPtr transPtr diagPtr nPtr aPtr yPtr incyPtr - liftIO $ - MatrixShape.caseUpLoSym uplo - runTPMV - runTPMV - (spmv uploPtr nPtr alphaPtr aPtr xPtr incxPtr betaPtr yPtr incyPtr) - - -newtype SPMV a = - SPMV { - getSPMV :: - Ptr CChar -> Ptr CInt -> Ptr a -> Ptr a -> - Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () - } - -spmv :: Class.Floating a => - Ptr CChar -> Ptr CInt -> Ptr a -> Ptr a -> - Ptr a -> Ptr CInt -> Ptr a -> Ptr a -> Ptr CInt -> IO () -spmv = - getSPMV $ - Class.switchFloating - (SPMV BlasReal.spmv) (SPMV BlasReal.spmv) - (SPMV LapackComplex.spmv) (SPMV LapackComplex.spmv) - - -square :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo (Tri.PowerDiag lo up diag) up sh a -square = - Tri.getPower $ - MatrixShape.switchDiagUpLoSym - (Tri.Power squareDiagonal) - (Tri.Power squareTriangular) - (Tri.Power squareTriangular) - (Tri.Power $ squareSymmetric . strictNonUnitDiagonal) - - -squareDiagonal :: - (MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - FlexDiagonal diag sh a -> FlexDiagonal diag sh a -squareDiagonal = - getMapDiag $ - MatrixShape.switchTriDiag - (MapDiag id) - (MapDiag $ - VectorPriv.recheck . uncurry Vector.mul . double . VectorPriv.uncheck) - -newtype MapDiag lo up sh a diag = - MapDiag { - getMapDiag :: - Triangular lo diag up sh a -> - Triangular lo diag up sh a - } - -squareTriangular :: - (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular lo diag up sh a -squareTriangular - (Array shape@(MatrixShape.Triangular diag uplo order sh) a) = - Array.unsafeCreate shape $ \bpPtr -> do - let n = Shape.size sh - evalContT $ do - sidePtr <- Call.char 'L' - let realOrder = uploOrder uplo order - uploPtr <- Call.char $ uploFromOrder realOrder - transPtr <- Call.char 'N' - diagPtr <- Call.char $ charFromTriDiag diag - nPtr <- Call.cint n - ldPtr <- Call.leadingDim n - aPtr <- unpackToTemp (unpack realOrder) n a - bPtr <- unpackToTemp (unpackZero realOrder) n a - alphaPtr <- Call.number one - liftIO $ do - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr - pack realOrder n bPtr bpPtr - -squareSymmetric :: - (Shape.C sh, Class.Floating a) => Symmetric sh a -> Symmetric sh a -squareSymmetric (Array shape@(MatrixShape.Triangular _diag _uplo order sh) a) = - Array.unsafeCreate shape $ - Symmetric.square NonConjugated order (Shape.size sh) a - - -{- -Requires frequent unpacking and packing of triangles. --} -power :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Int -> - Triangular lo diag up sh a -> - Triangular lo (Tri.PowerDiag lo up diag) up sh a -power n = - Tri.getPower $ - MatrixShape.switchDiagUpLoSym - (Tri.Power $ Array.map (^n)) - (Tri.Power $ powerTriangular (fromIntegral n)) - (Tri.Power $ powerTriangular (fromIntegral n)) - (Tri.Power $ powerSymmetric (fromIntegral n) . strictNonUnitDiagonal) - -powerTriangular :: - (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Integer -> Triangular lo diag up sh a -> Triangular lo diag up sh a -powerTriangular n a@(Array (MatrixShape.Triangular _diag _uplo order sh) _) = - recheck $ - powerAssociative multiplyTriangular - (relaxUnitDiagonal $ identity order $ Unchecked sh) - (uncheck a) - n - -powerSymmetric :: - (Shape.C sh, Class.Floating a) => Integer -> Symmetric sh a -> Symmetric sh a -powerSymmetric n a0@(Array (MatrixShape.Triangular _diag _uplo order sh) _) = - recheck $ - powerAssociative - (\a b -> - Tri.fromUpperPart - (MatrixShape.Triangular NonUnit MatrixShape.autoUplo) $ - multiplyFullTriangular a $ toSquare b) - (relaxUnitDiagonal $ identity order $ Unchecked sh) - (uncheck a0) - n + liftIO $ copyBlock n xPtr yPtr + withPacking pack_ $ + applyFuncPair (noLabel BlasGen.tpmv) (noLabel BlasGen.trmv) + uploPtr transPtr diagPtr nPtr (triArg aPtr n) yPtr incyPtr multiply :: - (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, - Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular lo diag up sh a -> - Triangular lo diag up sh a -multiply = - getMultiply $ - MatrixShape.switchDiagUpLo - (Multiply $ liftDiagonal . Vector.mul . takeDiagonal) - (Multiply multiplyTriangular) - (Multiply multiplyTriangular) - -newtype Multiply diag sh a lo up = - Multiply { - getMultiply :: - Triangular lo diag up sh a -> - Triangular lo diag up sh a -> Triangular lo diag up sh a - } - -multiplyTriangular :: - (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, + (Layout.Packing pack, Layout.UpLo uplo, TriDiag diag, Shape.C sh, Eq sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo diag up sh a -> Triangular lo diag up sh a -multiplyTriangular - (Array (MatrixShape.Triangular diag uploA orderA shA) a) - (Array shapeB@(MatrixShape.Triangular _diag uploB orderB shB) b) = - Array.unsafeCreate shapeB $ \cpPtr -> do - Call.assert "Triangular.multiply: width shapes mismatch" (shA == shB) - let n = Shape.size shA - evalContT $ do - let (side,trans) = - case orderB of - ColumnMajor -> ('L', orderA) - RowMajor -> ('R', flipOrder orderA) - sidePtr <- Call.char side - let realOrderA = uploOrder uploA orderA - let realOrderB = uploOrder uploB orderB - uploPtr <- Call.char $ uploFromOrder realOrderA - transPtr <- Call.char $ transposeFromOrder trans - diagPtr <- Call.char $ charFromTriDiag diag - nPtr <- Call.cint n - ldPtr <- Call.leadingDim n - aPtr <- unpackToTemp (unpack realOrderA) n a - bPtr <- unpackToTemp (unpackZero realOrderB) n b - alphaPtr <- Call.number one - liftIO $ do - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - nPtr nPtr alphaPtr aPtr ldPtr bPtr ldPtr - pack realOrderB n bPtr cpPtr - + DiagSingleton diag -> + TriangularP pack uplo sh a -> + TriangularP pack uplo sh a -> + TriangularP pack uplo sh a +multiply diag a b = + repack $ Unpacked.multiplyCompatible diag (unpackDirty a) (unpackGen b) multiplyFull :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, - Class.Floating a) => - Triangular lo diag up height a -> - Full vert horiz height width a -> - Full vert horiz height width a -multiplyFull = - Tri.getMultiplyRight $ - MatrixShape.switchDiagUpLoSym - (Tri.MultiplyRight $ Basic.scaleRows . takeDiagonal) - (Tri.MultiplyRight multiplyFullTriangular) - (Tri.MultiplyRight multiplyFullTriangular) - (Tri.MultiplyRight multiplyFullTriangular) - -multiplyFullTriangular :: - (MatrixShape.UpLoSym lo up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, + (Layout.UpLo uplo, TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => - Triangular lo diag up height a -> - Full vert horiz height width a -> - Full vert horiz height width a -multiplyFullTriangular - (Array (MatrixShape.Triangular diag uploA orderA shA) a) - (Array shapeB@(MatrixShape.Full orderB extentB) b) = - Array.unsafeCreateWithSize shapeB $ \size cPtr -> do - let (height,width) = Extent.dimensions extentB - Call.assert "Triangular.multiplyFull: shapes mismatch" (shA == height) - let m0 = Shape.size height - let n0 = Shape.size width - evalContT $ do - let (side,trans,(m,n)) = - case orderB of - ColumnMajor -> ('L', orderA, (m0,n0)) - RowMajor -> ('R', flipOrder orderA, (n0,m0)) - sidePtr <- Call.char side - let realOrderA = uploOrder uploA orderA - uploPtr <- Call.char $ uploFromOrder realOrderA - transPtr <- Call.char $ transposeFromOrder trans - diagPtr <- Call.char $ charFromTriDiag diag - mPtr <- Call.cint m - nPtr <- Call.cint n - alphaPtr <- Call.number one - aPtr <- unpackToTemp (unpack realOrderA) m0 a - ldaPtr <- Call.leadingDim m0 - betaPtr <- Call.number zero - bPtr <- ContT $ withForeignPtr b - ldbPtr <- Call.leadingDim m - let runTRMM = do - copyBlock size bPtr cPtr - BlasGen.trmm sidePtr uploPtr transPtr diagPtr - mPtr nPtr alphaPtr aPtr ldaPtr cPtr ldbPtr - liftIO $ - MatrixShape.caseUpLoSym uploA - runTRMM - runTRMM - (BlasGen.symm sidePtr uploPtr - mPtr nPtr alphaPtr aPtr ldaPtr bPtr ldbPtr betaPtr cPtr ldbPtr) - - -autoUploOrder :: - (MatrixShape.Content lo, MatrixShape.Content up) => Order -> (Order, (lo,up)) -autoUploOrder order = - case MatrixShape.autoUplo of - uplo -> (uploOrder uplo order, uplo) + DiagSingleton diag -> + TriangularP pack uplo height a -> + Full meas vert horiz height width a -> + Full meas vert horiz height width a +multiplyFull diag = Unpacked.multiplyFull diag . unpackDirty diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs b/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs --- a/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular/Eigen.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Triangular.Eigen ( values, decompose, ) where -import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Triangular -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import Numeric.LAPACK.Matrix.Triangular.Private - (unpackZero, pack, unpackToTemp, fillTriangle, +import qualified Numeric.LAPACK.Matrix.Mosaic.Basic as Mosaic +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Mosaic.Private + (unpackZero, unpackToTemp, fillTriangle, forPointers, rowMajorPointers) -import Numeric.LAPACK.Matrix.Triangular.Basic (Triangular) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(ColumnMajor,RowMajor), caseLoUp, uploOrder, NonUnit(NonUnit)) +import Numeric.LAPACK.Matrix.Triangular.Basic (TriangularP) +import Numeric.LAPACK.Matrix.Layout.Private + (Order(ColumnMajor,RowMajor), uploOrder) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (zero) -import Numeric.LAPACK.Private (lacgv, withInfo, errorCodeMsg) +import Numeric.LAPACK.Private (copyToColumnMajorTemp, withInfo, errorCodeMsg) import qualified Numeric.LAPACK.FFI.Complex as LapackComplex import qualified Numeric.LAPACK.FFI.Real as LapackReal @@ -27,87 +27,74 @@ import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape (triangleSize) import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr) -import Control.Monad.Trans.Cont (evalContT) +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) import Data.Complex (Complex) -import Data.Tuple.HT (swap) +import Data.Tuple.HT (swap, mapPair) values :: - (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Vector sh a -values = Triangular.takeDiagonal + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + TriangularP pack uplo sh a -> Vector sh a +values = Mosaic.takeDiagonal decompose :: - (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo NonUnit up sh a -> - (Triangular lo NonUnit up sh a, Vector sh a, Triangular lo NonUnit up sh a) -decompose a = - let (vr,vl) = - flip getDecompose a $ - MatrixShape.switchDiagUpLo - (Decompose $ - (\eye -> (eye, Triangular.transpose eye)) . - Triangular.relaxUnitDiagonal . - Triangular.identity ColumnMajor . - MatrixShape.triangularSize . Array.shape) - (Decompose decomposeTriangular) - (Decompose decomposeTriangular) - in (vr, values a, vl) - -newtype Decompose sh a lo up = - Decompose { - getDecompose :: - Triangular lo NonUnit up sh a -> - (Triangular lo NonUnit up sh a, Triangular lo NonUnit up sh a) - } - -decomposeTriangular :: - (MatrixShape.UpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo NonUnit up sh a -> - (Triangular lo NonUnit up sh a, Triangular lo NonUnit up sh a) -decomposeTriangular (Array (MatrixShape.Triangular _diag uplo order sh) a) = + (Layout.UpLo uplo, Layout.Packing vpack, + Shape.C sh, Class.Floating a) => + TriangularP pack uplo sh a -> + (TriangularP vpack uplo sh a, TriangularP vpack uplo sh a) +decompose (Array (Layout.Mosaic packing mirror uplo order sh) a) = let triShape ord = - MatrixShape.Triangular NonUnit uplo (uploOrder uplo ord) sh + Layout.Mosaic + Layout.Unpacked mirror uplo (uploOrder uplo ord) sh n = Shape.size sh - n2 = n*n - triSize = triangleSize n - in caseLoUp uplo id swap $ - Array.unsafeCreateWithSizeAndResult (triShape RowMajor) $ \_ vlpPtr -> - ArrayIO.unsafeCreate (triShape ColumnMajor) $ \vrpPtr -> + in swapUpper uplo $ + mapPair (Vector.conjugate . Mosaic.repack, Mosaic.repack) $ + Array.unsafeCreateWithSizeAndResult (triShape RowMajor) $ \_ vlPtr -> + ArrayIO.unsafeCreate (triShape ColumnMajor) $ \vrPtr -> evalContT $ do sidePtr <- Call.char 'B' howManyPtr <- Call.char 'A' let selectPtr = nullPtr - let unpk = - case uploOrder uplo order of - ColumnMajor -> unpackZero ColumnMajor - RowMajor -> unpackZeroRowMajor - aPtr <- unpackToTemp unpk n a + aPtr <- toColumnMajorTemp packing (uploOrder uplo order) n a ldaPtr <- Call.leadingDim n - vlPtr <- Call.allocaArray n2 - vrPtr <- Call.allocaArray n2 mmPtr <- Call.cint n mPtr <- Call.alloca liftIO $ withInfo errorCodeMsg "trevc" $ trevc sidePtr howManyPtr selectPtr n aPtr ldaPtr vlPtr ldaPtr vrPtr ldaPtr mmPtr mPtr - sizePtr <- Call.cint triSize - incPtr <- Call.cint 1 - liftIO $ do - pack ColumnMajor n vrPtr vrpPtr - pack RowMajor n vlPtr vlpPtr - lacgv sizePtr vlpPtr incPtr +swapUpper :: Layout.UpLoSingleton uplo -> (a,a) -> (a,a) +swapUpper uplo = + case uplo of + Layout.Lower -> id + Layout.Upper -> swap + +toColumnMajorTemp :: + (Class.Floating a) => + Layout.PackingSingleton pack -> Order -> + Int -> ForeignPtr a -> ContT () IO (Ptr a) +toColumnMajorTemp packing order n a = + case packing of + Layout.Packed -> + let unpk = + case order of + ColumnMajor -> unpackZero ColumnMajor + RowMajor -> unpackZeroRowMajor + in unpackToTemp unpk n a + Layout.Unpacked -> + case order of + ColumnMajor -> ContT $ withForeignPtr a + RowMajor -> copyToColumnMajorTemp order n n a unpackZeroRowMajor :: Class.Floating a => Int -> Ptr a -> Ptr a -> IO () unpackZeroRowMajor n packedPtr fullPtr = do diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs b/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs --- a/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs +++ b/src/Numeric/LAPACK/Matrix/Triangular/Linear.hs @@ -1,24 +1,21 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Matrix.Triangular.Linear ( solve, inverse, determinant, ) where -import qualified Numeric.LAPACK.Matrix.Banded.Linear as BandedLin -import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded -import qualified Numeric.LAPACK.Matrix.Symmetric.Private as Symmetric -import qualified Numeric.LAPACK.Matrix.Triangular.Private as Tri -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Linear.Private (solver, withInfo) -import Numeric.LAPACK.Matrix.Triangular.Basic - (Triangular, Symmetric, PowerDiag, takeDiagonal, strictNonUnitDiagonal) -import Numeric.LAPACK.Matrix.Shape.Private - (transposeFromOrder, uploFromOrder, uploOrder, charFromTriDiag) -import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) +import Numeric.LAPACK.Linear.Private (solver, diagonalMsg) +import Numeric.LAPACK.Matrix.Mosaic.Private + (withPackingLinear, label, applyFuncPair, triArg) +import Numeric.LAPACK.Matrix.Mosaic.Basic (takeDiagonal) +import Numeric.LAPACK.Matrix.Shape.Omni (TriDiag, DiagSingleton, charFromTriDiag) +import Numeric.LAPACK.Matrix.Layout.Private + (transposeFromOrder, uploFromOrder, uploOrder) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Private (copyBlock, copyToTemp) @@ -29,132 +26,63 @@ import qualified Data.Array.Comfort.Storable.Unchecked as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape (triangleSize) -import System.IO.Unsafe (unsafePerformIO) - import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (peek) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) + +type Triangular pack uplo sh = + Array (Layout.Mosaic pack Layout.NoMirror uplo sh) + + solve :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, + (Layout.UpLo uplo, TriDiag diag, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Triangular lo diag up sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solve = - Tri.getMultiplyRight $ - MatrixShape.switchDiagUpLoSym - (Tri.MultiplyRight $ BandedLin.solve . Banded.fromDiagonal) - (Tri.MultiplyRight solveTriangular) - (Tri.MultiplyRight solveTriangular) - (Tri.MultiplyRight $ solveSymmetric . strictNonUnitDiagonal) + DiagSingleton diag -> + Triangular pack uplo sh a -> + Full meas vert horiz sh nrhs a -> Full meas vert horiz sh nrhs a +solve diag + (Array + shape@(Layout.Mosaic pack Layout.NoMirror uplo orderA shA) + a) = -solveTriangular :: - (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, - Extent.C vert, Extent.C horiz, - Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Triangular lo diag up sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solveTriangular (Array (MatrixShape.Triangular diag uplo orderA shA) a) = solver "Triangular.solve" shA $ \n nPtr nrhsPtr xPtr ldxPtr -> do uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo orderA transPtr <- Call.char $ transposeFromOrder orderA diagPtr <- Call.char $ charFromTriDiag diag - apPtr <- copyToTemp (triangleSize n) a - liftIO $ - withInfo "tptrs" $ - LapackGen.tptrs uploPtr transPtr diagPtr - nPtr nrhsPtr apPtr xPtr ldxPtr - -solveSymmetric :: - (Extent.C vert, Extent.C horiz, - Shape.C sh, Eq sh, Shape.C nrhs, Class.Floating a) => - Symmetric sh a -> - Full vert horiz sh nrhs a -> Full vert horiz sh nrhs a -solveSymmetric (Array (MatrixShape.Triangular _diag _uplo orderA shA) a) = - Symmetric.solve "Symmetric.solve" NonConjugated orderA shA a + aPtr <- copyToTemp (Shape.size shape) a + withPackingLinear diagonalMsg pack $ + applyFuncPair + (label "tptrs" LapackGen.tptrs) (label "trtrs" LapackGen.trtrs) + uploPtr transPtr diagPtr nPtr nrhsPtr + (triArg aPtr n) xPtr ldxPtr inverse :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> - Triangular lo (PowerDiag lo up diag) up sh a -inverse = - Tri.getPower $ - MatrixShape.switchDiagUpLoSym - (Tri.Power inverseDiagonal) - (Tri.Power inverseTriangular) - (Tri.Power inverseTriangular) - (Tri.Power $ inverseSymmetric . strictNonUnitDiagonal) - -inverseDiagonal :: - (MatrixShape.TriDiag diag, Shape.C sh, Class.Floating a) => - Tri.FlexDiagonal diag sh a -> Tri.FlexDiagonal diag sh a -inverseDiagonal a = - MatrixShape.caseTriDiag - (MatrixShape.triangularDiag $ Array.shape a) - a (Vector.recip a) - -inverseTriangular :: - (MatrixShape.UpLo lo up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> Triangular lo diag up sh a -inverseTriangular (Array shape@(MatrixShape.Triangular diag uplo order sh) a) = - Array.unsafeCreateWithSize shape $ \triSize bPtr -> + (Layout.UpLo uplo, TriDiag diag, Shape.C sh, Class.Floating a) => + DiagSingleton diag -> + Triangular pack uplo sh a -> Triangular pack uplo sh a +inverse diag + (Array shape@(Layout.Mosaic pack Layout.NoMirror uplo order sh) a) + = Array.unsafeCreateWithSize shape $ \triSize bPtr -> evalContT $ do uploPtr <- Call.char $ uploFromOrder $ uploOrder uplo order diagPtr <- Call.char $ charFromTriDiag diag - nPtr <- Call.cint $ Shape.size sh + let n = Shape.size sh + nPtr <- Call.cint n aPtr <- ContT $ withForeignPtr a - liftIO $ do - copyBlock triSize aPtr bPtr - withInfo "tptri" $ LapackGen.tptri uploPtr diagPtr nPtr bPtr - -inverseSymmetric :: - (Shape.C sh, Class.Floating a) => Symmetric sh a -> Symmetric sh a -inverseSymmetric (Array shape@(MatrixShape.Triangular _diag _uplo order sh) a) = - Array.unsafeCreateWithSize shape $ - Symmetric.inverse NonConjugated order (Shape.size sh) a + liftIO $ copyBlock triSize aPtr bPtr + withPackingLinear diagonalMsg pack $ + applyFuncPair + (label "tptri" LapackGen.tptri) (label "trtri" LapackGen.trtri) + uploPtr diagPtr nPtr (triArg bPtr n) determinant :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> a -determinant = - Tri.getMultiplyRight $ - MatrixShape.switchDiagUpLoSym - (Tri.MultiplyRight determinantTriangular) - (Tri.MultiplyRight determinantTriangular) - (Tri.MultiplyRight determinantTriangular) - (Tri.MultiplyRight $ determinantSymmetric . strictNonUnitDiagonal) - -determinantTriangular :: - (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> a -determinantTriangular = product . Array.toList . takeDiagonal - -determinantSymmetric :: - (Shape.C sh, Class.Floating a) => Symmetric sh a -> a -determinantSymmetric (Array (MatrixShape.Triangular _diag _uplo order sh) a) = - unsafePerformIO $ - Symmetric.determinant NonConjugated - peekBlockDeterminant order (Shape.size sh) a - -peekBlockDeterminant :: - (Class.Floating a) => (Ptr a, Maybe (Ptr a, Ptr a)) -> IO a -peekBlockDeterminant (a0Ptr,ext) = do - a0 <- peek a0Ptr - case ext of - Nothing -> return a0 - Just (a1Ptr,bPtr) -> do - a1 <- peek a1Ptr - b <- peek bPtr - return (a0*a1 - b*b) + (Layout.UpLo uplo, Shape.C sh, Class.Floating a) => + Triangular pack uplo sh a -> a +determinant = Vector.product . takeDiagonal diff --git a/src/Numeric/LAPACK/Matrix/Triangular/Private.hs b/src/Numeric/LAPACK/Matrix/Triangular/Private.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Matrix/Triangular/Private.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ConstraintKinds #-} -module Numeric.LAPACK.Matrix.Triangular.Private where - -import qualified Numeric.LAPACK.Matrix.Private as Matrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor,ColumnMajor), flipOrder, uploFromOrder, - Empty, Filled, NonUnit) -import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated)) -import Numeric.LAPACK.Matrix.Private (Full) -import Numeric.LAPACK.Scalar (zero) -import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) -import Numeric.LAPACK.Private - (pointerSeq, copyBlock, copyCondConjugateToTemp, - pokeCInt, fill, withInfo, errorCodeMsg) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import Data.Array.Comfort.Shape ((:+:)((:+:))) - -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array (advancePtr) -import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) - -import Data.Foldable (forM_) - - -diagonalPointers :: (Storable a) => Order -> Int -> Ptr a -> [Ptr a] -diagonalPointers order n aPtr = - take n $ scanl advancePtr aPtr $ - case order of - RowMajor -> iterate pred n - ColumnMajor -> iterate succ 2 - -diagonalPointerPairs :: - (Storable a, Storable b) => - Order -> Int -> Ptr a -> Ptr b -> [(Ptr a, Ptr b)] -diagonalPointerPairs order n aPtr bPtr = - zip (pointerSeq 1 aPtr) $ diagonalPointers order n bPtr - - -columnMajorPointers :: - (Storable a) => Int -> Ptr a -> Ptr a -> [(Int, ((Ptr a, Ptr a), Ptr a))] -columnMajorPointers n fullPtr packedPtr = - let ds = iterate succ 1 - in take n $ zip ds $ - zip - (zip (pointerSeq 1 fullPtr) (pointerSeq n fullPtr)) - (scanl advancePtr packedPtr ds) - -rowMajorPointers :: - (Storable a) => Int -> Ptr a -> Ptr a -> [(Int, (Ptr a, Ptr a))] -rowMajorPointers n fullPtr packedPtr = - let ds = iterate pred n - in take n $ zip ds $ - zip (pointerSeq (n+1) fullPtr) (scanl advancePtr packedPtr ds) - - -forPointers :: [(Int, a)] -> (Ptr CInt -> a -> IO ()) -> IO () -forPointers xs act = - alloca $ \nPtr -> - forM_ xs $ \(d,ptrs) -> do - pokeCInt nPtr d - act nPtr ptrs - - -copyTriangleToTemp :: - Class.Floating a => - Conjugation -> Order -> Int -> ForeignPtr a -> ContT r IO (Ptr a) -copyTriangleToTemp conj order = - copyCondConjugateToTemp $ - case order of - RowMajor -> conj - ColumnMajor -> NonConjugated - - -unpackToTemp :: - Storable a => - (Int -> Ptr a -> Ptr a -> IO ()) -> - Int -> ForeignPtr a -> ContT r IO (Ptr a) -unpackToTemp f n a = do - apPtr <- ContT $ withForeignPtr a - aPtr <- Call.allocaArray (n*n) - liftIO $ f n apPtr aPtr - return aPtr - - -unpack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -unpack order n packedPtr fullPtr = - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - ldaPtr <- Call.leadingDim n - liftIO $ withInfo errorCodeMsg "tpttr" $ - LapackGen.tpttr uploPtr nPtr packedPtr fullPtr ldaPtr - -pack :: Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -pack order n = packRect order n n - -packRect :: Class.Floating a => Order -> Int -> Int -> Ptr a -> Ptr a -> IO () -packRect order n ld fullPtr packedPtr = - evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - ldaPtr <- Call.leadingDim ld - liftIO $ withInfo errorCodeMsg "trttp" $ - LapackGen.trttp uploPtr nPtr fullPtr ldaPtr packedPtr - - -unpackZero, _unpackZero :: - Class.Floating a => Order -> Int -> Ptr a -> Ptr a -> IO () -_unpackZero order n packedPtr fullPtr = do - fill zero (n*n) fullPtr - unpack order n packedPtr fullPtr - -unpackZero order n packedPtr fullPtr = do - fillTriangle zero (flipOrder order) n fullPtr - unpack order n packedPtr fullPtr - -fillTriangle :: Class.Floating a => a -> Order -> Int -> Ptr a -> IO () -fillTriangle z order n aPtr = evalContT $ do - uploPtr <- Call.char $ uploFromOrder order - nPtr <- Call.cint n - zPtr <- Call.number z - liftIO $ LapackGen.laset uploPtr nPtr nPtr zPtr zPtr aPtr nPtr - - - -uncheck :: Triangular lo diag up sh a -> Triangular lo diag up (Unchecked sh) a -uncheck = - Array.mapShape $ - \(MatrixShape.Triangular diag uplo order sh) -> - MatrixShape.Triangular diag uplo order (Unchecked sh) - -recheck :: Triangular lo diag up (Unchecked sh) a -> Triangular lo diag up sh a -recheck = - Array.mapShape $ - \(MatrixShape.Triangular diag uplo order (Unchecked sh)) -> - MatrixShape.Triangular diag uplo order sh - - -stack :: - (Box.Box sh0, Box.HeightOf sh0 ~ height, Shape.C height, Eq height, - Box.Box sh1, Box.WidthOf sh1 ~ width, Shape.C width, Eq width, - Shape.C sh2, Class.Floating a) => - String -> (height:+:width -> sh2) -> - Array sh0 a -> Matrix.General height width a -> Array sh1 a -> Array sh2 a -stack name consShape - (Array sha a) (Array (MatrixShape.Full order extent) b) (Array shc c) = - let (height,width) = Extent.dimensions extent - in Array.unsafeCreate (consShape (height :+: width)) $ \xPtr -> do - Call.assert (name++".stack: height shapes mismatch") $ - height == Box.height sha - Call.assert (name++".stack: width shapes mismatch") $ - width == Box.width shc - let m = Shape.size height - let n = Shape.size width - withForeignPtr a $ \aPtr -> copyTriangleA copyBlock order m n aPtr xPtr - withForeignPtr b $ \bPtr -> copyRectangle copyBlock order m n bPtr xPtr - withForeignPtr c $ \cPtr -> copyTriangleC copyBlock order m n cPtr xPtr - -takeTopRight :: - (Shape.C sh, Shape.C height, Shape.C width, Class.Floating a) => - (sh -> (MatrixShape.Order, height:+:width)) -> - Array sh a -> Matrix.General height width a -takeTopRight getShapes (Array sh x) = - let (order, height:+:width) = getShapes sh - in Array.unsafeCreate (MatrixShape.general order height width) $ \bPtr -> do - let m = Shape.size height - let n = Shape.size width - withForeignPtr x $ copyRectangle (flip . copyBlock) order m n bPtr - -takeTopLeft :: - (Shape.C sh, Shape.C sha, Shape.C height, Shape.C width, Class.Floating a) => - (sh -> (sha, (MatrixShape.Order, height:+:width))) -> - Array sh a -> Array sha a -takeTopLeft getShapes (Array sh x) = - let (sha, (order, height:+:width)) = getShapes sh - in Array.unsafeCreate sha $ \aPtr -> do - let m = Shape.size height - let n = Shape.size width - withForeignPtr x $ copyTriangleA (flip . copyBlock) order m n aPtr - -takeBottomRight :: - (Shape.C sh, Shape.C shc, Shape.C height, Shape.C width, Class.Floating a) => - (sh -> (shc, (MatrixShape.Order, height:+:width))) -> - Array sh a -> Array shc a -takeBottomRight getShapes (Array sh x) = - let (shc, (order, height:+:width)) = getShapes sh - in Array.unsafeCreate shc $ \cPtr -> do - let m = Shape.size height - let n = Shape.size width - withForeignPtr x $ copyTriangleC (flip . copyBlock) order m n cPtr - -{-# INLINE copyTriangleA #-} -copyTriangleA :: - (Class.Floating a) => - (Int -> Ptr a -> Ptr a -> IO ()) -> - Order -> Int -> Int -> Ptr a -> Ptr a -> IO () -copyTriangleA copy order m n aPtr xPtr = - case order of - ColumnMajor -> copy (Shape.triangleSize m) aPtr xPtr - RowMajor -> - forM_ (zip (iterate pred m) $ - zip (diagonalPointers order m aPtr) - (diagonalPointers order (m+n) xPtr)) $ - \(k,(aiPtr,xiPtr)) -> copy k aiPtr xiPtr - -{-# INLINE copyTriangleC #-} -copyTriangleC :: - (Class.Floating a) => - (Int -> Ptr a -> Ptr a -> IO ()) -> - Order -> Int -> Int -> Ptr a -> Ptr a -> IO () -copyTriangleC copy order m n cPtr xPtr = - case order of - RowMajor -> - let triSize = Shape.triangleSize n - in copy triSize cPtr - (advancePtr xPtr $ Shape.triangleSize (m+n) - triSize) - ColumnMajor -> - forM_ (zip (iterate succ 0) $ - zip (diagonalPointers order n cPtr) - (drop m $ diagonalPointers order (m+n) xPtr)) $ - \(k,(aiPtr,xiPtr)) -> - copy (k+1) (advancePtr aiPtr (-k)) (advancePtr xiPtr (-k)) - -{-# INLINE copyRectangle #-} -copyRectangle :: - (Class.Floating a) => - (Int -> Ptr a -> Ptr a -> IO ()) -> - Order -> Int -> Int -> Ptr a -> Ptr a -> IO () -copyRectangle copy order m n bPtr xPtr = - case order of - RowMajor -> - forM_ (take m $ zip (iterate pred m) $ - zip (pointerSeq n bPtr) (diagonalPointers order (m+n) xPtr)) $ - \(k,(biPtr,xiPtr)) -> copy n biPtr (advancePtr xiPtr k) - ColumnMajor -> - forM_ (take n $ zip (iterate succ m) $ - zip (pointerSeq m bPtr) - (drop m $ diagonalPointers order (m+n) xPtr)) $ - \(k,(biPtr,xiPtr)) -> copy m biPtr (advancePtr xiPtr (-k)) - - - -type Triangular lo diag up sh = Array (MatrixShape.Triangular lo diag up sh) - -type FlexDiagonal diag sh = - Triangular MatrixShape.Empty diag MatrixShape.Empty sh - -newtype MultiplyRight diag sh a b lo up = - MultiplyRight {getMultiplyRight :: Triangular lo diag up sh a -> b} - -newtype Map diag sh0 sh1 a lo up = - Map {getMap :: Triangular lo diag up sh0 a -> Triangular lo diag up sh1 a} - -newtype Power diag sh a lo up = - Power { - getPower :: - Triangular lo diag up sh a -> - Triangular lo (PowerDiag lo up diag) up sh a - } - -type family PowerDiag lo up diag -type instance PowerDiag Empty up diag = diag -type instance PowerDiag Filled Empty diag = diag -type instance PowerDiag Filled Filled diag = NonUnit - -type PowerContentDiag lo diag up = - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - PowerDiag lo up diag ~ diag, PowerDiag up lo diag ~ diag) - - -fromBanded :: - (Class.Floating a) => - Int -> Order -> Int -> ForeignPtr a -> Int -> Ptr a -> IO () -fromBanded k order n a bSize bPtr = - withForeignPtr a $ \aPtr -> do - fill zero bSize bPtr - let lda = k+1 - let pointers = - zip [0..] $ zip (pointerSeq lda aPtr) $ - diagonalPointers order n bPtr - case order of - ColumnMajor -> - forM_ pointers $ \(i,(xPtr,yPtr)) -> - let j = min i k - in copyBlock (j+1) (advancePtr xPtr (k-j)) (advancePtr yPtr (-j)) - RowMajor -> - forM_ pointers $ \(i,(xPtr,yPtr)) -> - copyBlock (min lda (n-i)) xPtr yPtr - - -type FlexLower diag sh = Array (MatrixShape.LowerTriangular diag sh) - -takeLower :: - (MatrixShape.TriDiag diag, - Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - (diag, Order -> Int -> Ptr a -> IO ()) -> - Full Extent.Small horiz height width a -> FlexLower diag height a -takeLower (diag, fillDiag) (Array (MatrixShape.Full order extent) a) = - let (height,width) = Extent.dimensions extent - m = Shape.size height - n = Shape.size width - k = case order of RowMajor -> n; ColumnMajor -> m - in Array.unsafeCreate - (MatrixShape.Triangular diag MatrixShape.lower order height) $ \lPtr -> - withForeignPtr a $ \aPtr -> do - let dstOrder = flipOrder order - packRect dstOrder m k aPtr lPtr - fillDiag dstOrder m lPtr - - -fromUpperPart :: - (Extent.C vert, Shape.C height, Shape.C width, Shape.C shape, - Class.Floating a) => - (Order -> width -> shape) -> - Full vert Extent.Small height width a -> Array shape a -fromUpperPart shape (Array (MatrixShape.Full order extent) a) = - let (height,width) = Extent.dimensions extent - m = Shape.size height - n = Shape.size width - k = case order of RowMajor -> n; ColumnMajor -> m - in Array.unsafeCreate (shape order width) $ \bPtr -> - withForeignPtr a $ \aPtr -> packRect order n k aPtr bPtr diff --git a/src/Numeric/LAPACK/Matrix/Type.hs b/src/Numeric/LAPACK/Matrix/Type.hs --- a/src/Numeric/LAPACK/Matrix/Type.hs +++ b/src/Numeric/LAPACK/Matrix/Type.hs @@ -1,11 +1,21 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} module Numeric.LAPACK.Matrix.Type where import qualified Numeric.LAPACK.Matrix.Plain.Format as ArrFormat import qualified Numeric.LAPACK.Output as Output import qualified Numeric.LAPACK.Permutation.Private as Perm -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import Numeric.LAPACK.Matrix.Layout.Private (Empty, Filled) +import Numeric.LAPACK.Matrix.Extent.Private (Extent, Shape, Small) import Numeric.LAPACK.Output (Output) import qualified Numeric.Netlib.Class as Class @@ -16,35 +26,96 @@ import qualified Data.Array.Comfort.Shape as Shape +import Data.Function.HT (Id) import Data.Monoid (Monoid, mempty, mappend) import Data.Semigroup (Semigroup, (<>)) -data family Matrix typ a +data family + Matrix typ extraLower extraUpper lower upper meas vert horiz height width a +type Quadratic typ extraLower extraUpper lower upper sh = + QuadraticMeas typ extraLower extraUpper lower upper Shape sh sh +type QuadraticMeas typ extraLower extraUpper lower upper meas = + Matrix typ extraLower extraUpper lower upper meas Small Small -data Scale shape -data instance Matrix (Scale shape) a = Scale shape a +asQuadratic :: + Id (QuadraticMeas typ extraLower extraUpper lower upper meas height width a) +asQuadratic = id -newtype instance Matrix (Perm.Permutation sh) a = - Permutation (Perm.Permutation sh) - deriving (Show) +data Product fuse +data instance + Matrix (Product fuse) xl xu lower upper meas vert horiz height width a where + Product :: + (Omni.MultipliedBands lowerA lowerB ~ lowerC, + Omni.MultipliedBands lowerB lowerA ~ lowerC, + Omni.MultipliedBands upperA upperB ~ upperC, + Omni.MultipliedBands upperB upperA ~ upperC) => + Matrix typA xlA xuA lowerA upperA meas vert horiz height fuse a -> + Matrix typB xlB xuB lowerB upperB meas vert horiz fuse width a -> + Matrix (Product fuse) + (typA,lowerA,lowerB,xlA,xlB) (typB,upperB,upperA,xuB,xuA) + lowerC upperC meas vert horiz height width a -instance (NFData typ, DeepSeq.NFData a) => DeepSeq.NFData (Matrix typ a) where +data Scale +data instance + Matrix Scale xl xu lower upper meas vert horiz height width a where + Scale :: sh -> a -> Quadratic Scale () () Empty Empty sh a + +deriving instance + (Shape.C height, Show height, Show a) => + Show (Matrix Scale xl xu lower upper meas vert horiz height width a) + + +data Identity +data instance + Matrix Identity xl xu lower upper meas vert horiz height width a where + Identity :: + (Extent.Measure meas) => + Extent meas Small Small height width -> + QuadraticMeas Identity () () Empty Empty meas height width a + + +data Permutation +data instance + Matrix Permutation xl xu lower upper meas vert horiz height width a where + Permutation :: + Perm.Permutation sh -> Quadratic Permutation () () lower upper sh a + +deriving instance + (Shape.C height, Show height) => + Show (Matrix Permutation xl xu lower upper meas vert horiz height width a) + +deriving instance + (Shape.C height, Eq height) => + Eq (Matrix Permutation xl xu lower upper meas vert horiz height width a) + + +instance + (NFData typ, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + DeepSeq.NFData height, DeepSeq.NFData width, DeepSeq.NFData a) => + DeepSeq.NFData (Matrix typ xl xu lower upper meas vert horiz height width a) + where rnf = rnf class NFData typ where - rnf :: (DeepSeq.NFData a) => Matrix typ a -> () + rnf :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + DeepSeq.NFData height, DeepSeq.NFData width, DeepSeq.NFData a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> () instance - (FormatMatrix typ, Class.Floating a) => - Hyper.Display (Matrix typ a) where + (FormatMatrix typ, Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Class.Floating a) => + Hyper.Display + (Matrix typ xl xu lower upper meas vert horiz height width a) where display = Output.hyper . formatMatrix ArrFormat.deflt @@ -54,54 +125,78 @@ because it allows us to align the components of complex numbers. -} formatMatrix :: - (Class.Floating a, Output out) => String -> Matrix typ a -> out + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C width, Shape.C height, Class.Floating a, Output out) => + String -> + Matrix typ xl xu lower upper meas vert horiz height width a -> + out -instance (Shape.C sh) => FormatMatrix (Scale sh) where +instance FormatMatrix Scale where formatMatrix fmt (Scale shape a) = - ArrFormat.formatDiagonal fmt MatrixShape.RowMajor shape $ + ArrFormat.formatDiagonal fmt Layout.RowMajor shape $ replicate (Shape.size shape) a -instance (Shape.C sh) => FormatMatrix (Perm.Permutation sh) where +instance FormatMatrix Permutation where formatMatrix _fmt (Permutation perm) = Perm.format perm -instance (MultiplySame typ, Class.Floating a) => Semigroup (Matrix typ a) where +instance + (MultiplySame typ xl xu, MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, height ~ width, Class.Floating a) => + Semigroup (Matrix typ xl xu lower upper meas vert horiz height width a) + where (<>) = multiplySame -class MultiplySame typ where +class (Box typ) => MultiplySame typ xl xu where multiplySame :: - (Class.Floating a) => Matrix typ a -> Matrix typ a -> Matrix typ a + (matrix ~ Matrix typ xl xu lower upper meas vert horiz sh sh a, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C sh, Eq sh, Class.Floating a) => + matrix -> matrix -> matrix -instance (Eq shape) => MultiplySame (Scale shape) where +instance (xl ~ (), xu ~ ()) => MultiplySame Scale xl xu where multiplySame = scaleWithCheck "Scale.multiplySame" height (\a (Scale shape b) -> Scale shape $ a*b) -instance (Shape.C sh, Eq sh) => MultiplySame (Perm.Permutation sh) where +instance (xl ~ (), xu ~ ()) => MultiplySame Permutation xl xu where multiplySame (Permutation a) (Permutation b) = Permutation $ Perm.multiply b a instance - (MultiplySame typ, StaticIdentity typ, Class.Floating a) => - Monoid (Matrix typ a) where + (MultiplySame typ xl xu, StaticIdentity typ xl xu lower upper, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, + meas ~ Shape, vert ~ Small, horiz ~ Small, + Shape.Static height, Eq height, height ~ width, Class.Floating a) => + Monoid (Matrix typ xl xu lower upper meas vert horiz height width a) where mappend = (<>) mempty = staticIdentity -class StaticIdentity typ where - staticIdentity :: (Class.Floating a) => Matrix typ a +class StaticIdentity typ xl xu lower upper where + staticIdentity :: + (Shape.Static sh, Class.Floating a) => + Quadratic typ xl xu lower upper sh a -instance (Shape.Static shape) => StaticIdentity (Scale shape) where +instance + (xl ~ (), xu ~ (), lower ~ Empty, upper ~ Empty) => + StaticIdentity Scale xl xu lower upper where staticIdentity = Scale Shape.static 1 -instance (Shape.Static sh) => StaticIdentity (Perm.Permutation sh) where +instance + (xl ~ (), xu ~ (), lower ~ Filled, upper ~ Filled) => + StaticIdentity Permutation xl xu lower upper where staticIdentity = Permutation $ Perm.identity Shape.static scaleWithCheck :: (Eq shape) => String -> (b -> shape) -> - (a -> b -> c) -> Matrix (Scale shape) a -> b -> c + (a -> b -> c) -> + Matrix Scale xl xu lower upper meas vert horiz shape shape a -> + b -> c scaleWithCheck name getSize f (Scale shape a) b = if shape == getSize b then f a b @@ -109,26 +204,131 @@ class Box typ where - type HeightOf typ - type WidthOf typ - height :: Matrix typ a -> HeightOf typ - width :: Matrix typ a -> WidthOf typ + extent :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + Extent.Extent meas vert horiz height width + height :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Matrix typ xl xu lower upper meas vert horiz height width a -> height + height = Extent.height . extent + width :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Matrix typ xl xu lower upper meas vert horiz height width a -> width + width = Extent.width . extent -instance Box (Scale sh) where - type HeightOf (Scale sh) = sh - type WidthOf (Scale sh) = sh +instance Box Scale where + extent (Scale shape _) = Extent.square shape height (Scale shape _) = shape width (Scale shape _) = shape -instance Box (Perm.Permutation sh) where - type HeightOf (Perm.Permutation sh) = sh - type WidthOf (Perm.Permutation sh) = sh +instance Box Identity where + extent (Identity extent_) = extent_ + +instance Box Permutation where + extent (Permutation perm) = Extent.square $ Perm.size perm height (Permutation perm) = Perm.size perm width (Permutation perm) = Perm.size perm +{- ToDo: requires parameters xl and xu for Box class + +instance (Eq fuse) => Box (Product fuse) where + extent (Product a b) = + fromMaybe (error "Matrix.Product: shapes mismatch") $ + Extent.fuse (extent a) (extent b) +-} + +squareSize :: (Box typ) => Quadratic typ xl xu lower upper sh a -> sh +squareSize = height + indices :: - (Box typ, - HeightOf typ ~ height, Shape.Indexed height, - WidthOf typ ~ width, Shape.Indexed width) => - Matrix typ a -> [(Shape.Index height, Shape.Index width)] + (Box typ, Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.Indexed height, Shape.Indexed width) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + [(Shape.Index height, Shape.Index width)] indices sh = Shape.indices (height sh, width sh) + + +class (Box typ) => ToQuadratic typ where + heightToQuadratic :: + (Extent.Measure meas) => + QuadraticMeas typ xl xu lower upper meas height width a -> + Quadratic typ xl xu lower upper height a + widthToQuadratic :: + (Extent.Measure meas) => + QuadraticMeas typ xl xu lower upper meas height width a -> + Quadratic typ xl xu lower upper width a + +instance ToQuadratic Scale where + heightToQuadratic (Scale shape a) = Scale shape a + widthToQuadratic (Scale shape a) = Scale shape a + +instance ToQuadratic Identity where + heightToQuadratic (Identity extent_) = + Identity $ Extent.square $ Extent.height extent_ + widthToQuadratic (Identity extent_) = + Identity $ Extent.square $ Extent.width extent_ + +instance ToQuadratic Permutation where + heightToQuadratic (Permutation perm) = Permutation perm + widthToQuadratic (Permutation perm) = Permutation perm + + +class (Box typ) => MapExtent typ xl xu lower upper where + mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + ExtentStrict.Map measA vertA horizA measB vertB horizB height width -> + Matrix typ xl xu lower upper measA vertA horizA height width a -> + Matrix typ xl xu lower upper measB vertB horizB height width a + + +class (Box typ) => Transpose typ where + transpose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C width, Shape.C height, Class.Floating a) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + Matrix typ xu xl upper lower meas horiz vert width height a + +instance Transpose Scale where + transpose (Scale shape a) = Scale shape a + +instance Transpose Identity where + transpose (Identity extent_) = Identity $ Extent.transpose extent_ + +instance Transpose Permutation where + transpose (Permutation perm) = Permutation $ Perm.transpose perm + +{- +instance (Shape.C fuse, Eq fuse) => Transpose (Product fuse) where + transpose (Product a b) = Product (transpose b) (transpose a) +-} + + +swapMultiply :: + (Transpose typA, Transpose typB) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + (Shape.C heightA, Shape.C widthA) => + (Shape.C heightB, Shape.C widthB) => + (Class.Floating a) => + (matrix -> + Matrix typA xuA xlA upperA lowerA measA horizA vertA widthA heightA a -> + Matrix typB xuB xlB upperB lowerB measB horizB vertB widthB heightB a) -> + Matrix typA xlA xuA lowerA upperA measA vertA horizA heightA widthA a -> + matrix -> + Matrix typB xlB xuB lowerB upperB measB vertB horizB heightB widthB a +swapMultiply multiplyTrans a b = + transpose $ multiplyTrans b $ transpose a + +powerStrips :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + (MatrixShape.PowerStripSingleton lower, MatrixShape.PowerStripSingleton upper) +powerStrips _ = (MatrixShape.powerStripSingleton, MatrixShape.powerStripSingleton) + +strips :: + (MatrixShape.Strip lower, MatrixShape.Strip upper) => + Matrix typ xl xu lower upper meas vert horiz height width a -> + (MatrixShape.StripSingleton lower, MatrixShape.StripSingleton upper) +strips _ = (MatrixShape.stripSingleton, MatrixShape.stripSingleton) diff --git a/src/Numeric/LAPACK/Orthogonal.hs b/src/Numeric/LAPACK/Orthogonal.hs --- a/src/Numeric/LAPACK/Orthogonal.hs +++ b/src/Numeric/LAPACK/Orthogonal.hs @@ -12,24 +12,26 @@ determinant, determinantAbsolute, complement, - affineSpanFromKernel, - affineKernelFromSpan, + affineFrameFromFiber, + affineFiberFromFrame, householder, householderTall, ) where import qualified Numeric.LAPACK.Orthogonal.Householder as HH -import qualified Numeric.LAPACK.Orthogonal.Plain as Plain +import qualified Numeric.LAPACK.Orthogonal.Basic as Plain import qualified Numeric.LAPACK.Matrix.Multiply as Multiply import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Basic as Basic import qualified Numeric.LAPACK.Matrix.Type as Matrix import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Shape as ExtShape import Numeric.LAPACK.Matrix.Array (Full, General, Tall, Wide, Square) import Numeric.LAPACK.Matrix.Private (ShapeInt) import Numeric.LAPACK.Vector (Vector, (|-|)) @@ -49,11 +51,11 @@ Precondition: @a@ must have full rank and @height a >= width a@. -} leastSquares :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - Full horiz Extent.Small height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a + Full meas horiz Extent.Small height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a leastSquares = ArrMatrix.lift2 Plain.leastSquares {- | @@ -64,11 +66,11 @@ Precondition: @a@ must have full rank and @height a <= width a@. -} minimumNorm :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - Full Extent.Small vert height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a + Full meas Extent.Small vert height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a minimumNorm = ArrMatrix.lift2 Plain.minimumNorm @@ -81,12 +83,12 @@ but you must specify the reciprocal condition of the rank-truncated matrix. -} leastSquaresMinimumNormRCond :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => RealOf a -> - Full horiz vert height width a -> - Full vert horiz height nrhs a -> - (Int, Full vert horiz width nrhs a) + Full meas horiz vert height width a -> + Full meas vert horiz height nrhs a -> + (Int, Full meas vert horiz width nrhs a) leastSquaresMinimumNormRCond rcond a b = mapSnd ArrMatrix.lift0 $ Plain.leastSquaresMinimumNormRCond @@ -94,11 +96,11 @@ pseudoInverseRCond :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => RealOf a -> - Full vert horiz height width a -> - (Int, Full horiz vert width height a) + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) pseudoInverseRCond rcond = mapSnd (ArrMatrix.lift0 . Basic.recheck) . Plain.pseudoInverseRCond rcond . @@ -117,7 +119,7 @@ project b d x = x |-| - ArrMatrix.unliftColumn MatrixShape.ColumnMajor + ArrMatrix.unliftColumn Layout.ColumnMajor (minimumNorm b) (Multiply.matrixVector b x |-| d) @@ -169,18 +171,19 @@ means that @q@ is unitary and @r@ is upper triangular and @a = multiply q r@. -} householder :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - (Square height a, Full vert horiz height width a) + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + (Square height a, Unpacked.UpperTrapezoid meas vert horiz height width a) householder a = let hh = HH.fromMatrix a in (HH.extractQ hh, HH.extractR hh) householderTall :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> - (Full vert Extent.Small height width a, Triangular.Upper width a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + Full meas vert Extent.Small height width a -> + (Full meas vert Extent.Small height width a, Triangular.Upper width a) householderTall a = let hh = HH.fromMatrix a in (HH.tallExtractQ hh, HH.tallExtractR hh) @@ -196,9 +199,9 @@ > determinantAbsolute a = sqrt (Herm.determinant (Herm.gramian a)) -} determinantAbsolute :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> RealOf a + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> RealOf a determinantAbsolute = Plain.determinantAbsolute . ArrMatrix.toVector @@ -218,7 +221,7 @@ {- | -> affineSpanFromKernel a b == (c,d) +> affineFrameFromFiber a b == (c,d) Means: An affine subspace is given implicitly by {x : a#*|x == b}. @@ -226,30 +229,37 @@ Matrix @a@ must have full rank, otherwise the explicit representation will miss dimensions and we cannot easily determine the origin @d@ as a minimum norm solution. + +The computation is like + +> c = complement $ adjoint a +> d = minimumNorm a b + +but the QR decomposition of 'a' is computed only once. -} -affineSpanFromKernel :: +affineFrameFromFiber :: (Shape.C width, Eq width, Shape.C height, Eq height, Class.Floating a) => Wide height width a -> Vector height a -> (Tall width ShapeInt a, Vector width a) -affineSpanFromKernel a b = +affineFrameFromFiber a b = let qr = HH.fromMatrix $ ArrMatrix.lift1 Basic.adjoint a in (ArrMatrix.lift0 $ Plain.extractComplement qr, - ArrMatrix.unliftColumn MatrixShape.ColumnMajor (HH.minimumNorm qr) b) + ArrMatrix.unliftColumn Layout.ColumnMajor (HH.minimumNorm qr) b) {- | -This conversion is somehow inverse to 'affineSpanFromKernel'. +This conversion is somehow inverse to 'affineFrameFromFiber'. However, it is not precisely inverse in either direction. -This is because both 'affineSpanFromKernel' and 'affineKernelFromSpan' +This is because both 'affineFrameFromFiber' and 'affineFiberFromFrame' accept non-orthogonal matrices but always return orthogonal ones. -In @affineKernelFromSpan c d@, +In @affineFiberFromFrame c d@, matrix @c@ should have full rank, otherwise the implicit representation will miss dimensions. -} -affineKernelFromSpan :: +affineFiberFromFrame :: (Shape.C width, Eq width, Shape.C height, Eq height, Class.Floating a) => Tall height width a -> Vector height a -> (Wide ShapeInt height a, Vector ShapeInt a) -affineKernelFromSpan c d = +affineFiberFromFrame c d = let a = Basic.adjoint $ Plain.complement $ ArrMatrix.toVector c in (ArrMatrix.lift0 a, Basic.multiplyVector a d) diff --git a/src/Numeric/LAPACK/Orthogonal/Basic.hs b/src/Numeric/LAPACK/Orthogonal/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/LAPACK/Orthogonal/Basic.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Orthogonal.Basic ( + leastSquares, + minimumNorm, + leastSquaresMinimumNormRCond, + pseudoInverseRCond, + + leastSquaresConstraint, + gaussMarkovLinearModel, + + determinantAbsolute, + complement, + extractComplement, + ) where + +import qualified Numeric.LAPACK.Orthogonal.Plain as HH + +import qualified Numeric.LAPACK.Matrix.Square.Basic as Square +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Basic as Basic +import qualified Numeric.LAPACK.Vector as Vector +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor,ColumnMajor)) +import Numeric.LAPACK.Matrix.Private + (Full, General, Tall, Wide, ShapeInt, shapeInt) +import Numeric.LAPACK.Vector (Vector) +import Numeric.LAPACK.Scalar (RealOf, zero, absolute) +import Numeric.LAPACK.Private + (lacgv, peekCInt, + copySubMatrix, copyToTemp, + copyToColumnMajorTemp, copyToSubColumnMajor, + withAutoWorkspaceInfo, rankMsg, errorCodeMsg, createHigherArray) + +import qualified Numeric.LAPACK.FFI.Generic as LapackGen +import qualified Numeric.LAPACK.FFI.Complex as LapackComplex +import qualified Numeric.LAPACK.FFI.Real as LapackReal +import qualified Numeric.Netlib.Utility as Call +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as ArrayIO +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) + +import System.IO.Unsafe (unsafePerformIO) + +import Foreign.Marshal.Array (pokeArray) +import Foreign.C.Types (CInt, CChar) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr) + +import Control.Monad.Trans.Cont (ContT(ContT), evalContT) +import Control.Monad.IO.Class (liftIO) + +import Data.Complex (Complex) +import Data.Tuple.HT (mapSnd) + + +leastSquares :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Full meas horiz Extent.Small height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +leastSquares + (Array shapeA@(Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = + + case Extent.fuse (Extent.weakenWide $ Extent.transpose extentA) extentB of + Nothing -> error "leastSquares: height shapes mismatch" + Just extent -> + Array.unsafeCreate (Layout.Full ColumnMajor extent) $ \xPtr -> do + + let widthA = Extent.width extentA + let (height,widthB) = Extent.dimensions extentB + let (m,n) = Layout.dimensions shapeA + let lda = m + let nrhs = Shape.size widthB + let ldb = Shape.size height + let ldx = Shape.size widthA + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + nrhsPtr <- Call.cint nrhs + (transPtr,aPtr) <- adjointA orderA (m*n) a + ldaPtr <- Call.leadingDim lda + ldbPtr <- Call.leadingDim ldb + bPtr <- copyToColumnMajorTemp orderB ldb nrhs b + liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ + LapackGen.gels transPtr + mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr + liftIO $ copySubMatrix ldx nrhs ldb bPtr ldx xPtr + +minimumNorm :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + Full meas Extent.Small vert height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +minimumNorm + (Array shapeA@(Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = + + case Extent.fuse (Extent.weakenTall $ Extent.transpose extentA) extentB of + Nothing -> error "minimumNorm: height shapes mismatch" + Just extent -> + Array.unsafeCreate (Layout.Full ColumnMajor extent) $ \xPtr -> do + + let widthA = Extent.width extentA + let (height,widthB) = Extent.dimensions extentB + let (m,n) = Layout.dimensions shapeA + let lda = m + let nrhs = Shape.size widthB + let ldb = Shape.size height + let ldx = Shape.size widthA + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + nrhsPtr <- Call.cint nrhs + (transPtr,aPtr) <- adjointA orderA (m*n) a + ldaPtr <- Call.leadingDim lda + bPtr <- ContT $ withForeignPtr b + ldxPtr <- Call.leadingDim ldx + liftIO $ copyToSubColumnMajor orderB ldb nrhs bPtr ldx xPtr + liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ + LapackGen.gels transPtr + mPtr nPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr + + +adjointA :: + Class.Floating a => + Order -> Int -> ForeignPtr a -> ContT r IO (Ptr CChar, Ptr a) +adjointA order size a = do + aPtr <- copyToTemp size a + trans <- + case order of + RowMajor -> do + sizePtr <- Call.cint size + incPtr <- Call.cint 1 + liftIO $ lacgv sizePtr aPtr incPtr + return $ HH.invChar a + ColumnMajor -> return 'N' + transPtr <- Call.char trans + return (transPtr, aPtr) + + +leastSquaresMinimumNormRCond :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => + RealOf a -> + Full meas horiz vert height width a -> + Full meas vert horiz height nrhs a -> + (Int, Full meas vert horiz width nrhs a) +leastSquaresMinimumNormRCond rcond + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = + case Extent.fuse (Extent.transpose extentA) extentB of + Nothing -> error "leastSquaresMinimumNormRCond: height shapes mismatch" + Just extent -> + let widthA = Extent.width extentA + (height,widthB) = Extent.dimensions extentB + shapeX = Layout.Full ColumnMajor extent + m = Shape.size height + n = Shape.size widthA + nrhs = Shape.size widthB + in if m == 0 + then (0, Vector.zero shapeX) + else + if nrhs == 0 + then + (fst $ unsafePerformIO $ + case Vector.zero height of + Array _ b1 -> + leastSquaresMinimumNormIO rcond + (Layout.general ColumnMajor widthA ()) + orderA a orderB b1 m n 1, + Vector.zero shapeX) + else + unsafePerformIO $ + leastSquaresMinimumNormIO rcond shapeX + orderA a orderB b m n nrhs + +leastSquaresMinimumNormIO :: + (Shape.C sh, Class.Floating a) => + RealOf a -> sh -> + Order -> ForeignPtr a -> + Order -> ForeignPtr a -> + Int -> Int -> Int -> IO (Int, Array sh a) +leastSquaresMinimumNormIO rcond shapeX orderA a orderB b m n nrhs = + createHigherArray shapeX m n nrhs $ \(tmpPtr,ldtmp) -> do + + let lda = m + evalContT $ do + aPtr <- copyToColumnMajorTemp orderA m n a + ldaPtr <- Call.leadingDim lda + ldtmpPtr <- Call.leadingDim ldtmp + bPtr <- ContT $ withForeignPtr b + liftIO $ copyToSubColumnMajor orderB m nrhs bPtr ldtmp tmpPtr + jpvtPtr <- Call.allocaArray n + liftIO $ pokeArray jpvtPtr (replicate n 0) + rankPtr <- Call.alloca + gelsy m n nrhs aPtr ldaPtr tmpPtr ldtmpPtr jpvtPtr rcond rankPtr + liftIO $ peekCInt rankPtr + + +type GELSY_ r ar a = + Int -> Int -> Int -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> + Ptr CInt -> ar -> Ptr CInt -> ContT r IO () + +newtype GELSY r a = GELSY {getGELSY :: GELSY_ r (RealOf a) a} + +gelsy :: (Class.Floating a) => GELSY_ r (RealOf a) a +gelsy = + getGELSY $ + Class.switchFloating + (GELSY gelsyReal) + (GELSY gelsyReal) + (GELSY gelsyComplex) + (GELSY gelsyComplex) + +gelsyReal :: (Class.Real a) => GELSY_ r a a +gelsyReal m n nrhs aPtr ldaPtr bPtr ldbPtr jpvtPtr rcond rankPtr = do + mPtr <- Call.cint m + nPtr <- Call.cint n + nrhsPtr <- Call.cint nrhs + rcondPtr <- Call.real rcond + liftIO $ withAutoWorkspaceInfo errorCodeMsg "gelsy" $ + LapackReal.gelsy mPtr nPtr nrhsPtr + aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr + +gelsyComplex :: (Class.Real a) => GELSY_ r a (Complex a) +gelsyComplex m n nrhs aPtr ldaPtr bPtr ldbPtr jpvtPtr rcond rankPtr = do + mPtr <- Call.cint m + nPtr <- Call.cint n + nrhsPtr <- Call.cint nrhs + rcondPtr <- Call.real rcond + rworkPtr <- Call.allocaArray (2*n) + liftIO $ + withAutoWorkspaceInfo errorCodeMsg "gelsy" $ \workPtr lworkPtr infoPtr -> + LapackComplex.gelsy mPtr nPtr nrhsPtr + aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr + workPtr lworkPtr rworkPtr infoPtr + + +pseudoInverseRCond :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + RealOf a -> + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) +pseudoInverseRCond rcond a = + case Basic.caseTallWide a of + Left _ -> + mapSnd Basic.transpose $ + leastSquaresMinimumNormRCond rcond (Basic.transpose a) $ + Square.toFull $ Square.identity $ + Layout.fullWidth $ Array.shape a + Right _ -> + leastSquaresMinimumNormRCond rcond a $ + Square.toFull $ Square.identity $ + Layout.fullHeight $ Array.shape a + + +leastSquaresConstraint :: + (Shape.C height, Eq height, + Shape.C width, Eq width, + Shape.C constraints, Eq constraints, Class.Floating a) => + General height width a -> Vector height a -> + Wide constraints width a -> Vector constraints a -> + Vector width a +leastSquaresConstraint + (Array (Layout.Full orderA extentA) a) c + (Array (Layout.Full orderB extentB) b) d = + + let sameShape name shape0 shape1 = + if shape0 == shape1 + then shape0 + else error $ "leastSquaresConstraint: " ++ name ++ " shapes mismatch" + width = sameShape "width" (Extent.width extentA) (Extent.width extentB) + in + Array.unsafeCreate width $ \xPtr -> do + + let height = sameShape "height" (Extent.height extentA) (Array.shape c) + let constraints = + sameShape "constraints" (Extent.height extentB) (Array.shape d) + let m = Shape.size height + let n = Shape.size width + let p = Shape.size constraints + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + pPtr <- Call.cint p + aPtr <- copyToColumnMajorTemp orderA m n a + ldaPtr <- Call.leadingDim m + bPtr <- copyToColumnMajorTemp orderB p n b + ldbPtr <- Call.leadingDim p + cPtr <- copyToTemp m (Array.buffer c) + dPtr <- copyToTemp p (Array.buffer d) + liftIO $ withAutoWorkspaceInfo rankMsg "gglse" $ + LapackGen.gglse + mPtr nPtr pPtr aPtr ldaPtr bPtr ldbPtr cPtr dPtr xPtr + +gaussMarkovLinearModel :: + (Shape.C height, Eq height, + Shape.C width, Eq width, + Shape.C opt, Eq opt, Class.Floating a) => + Tall height width a -> General height opt a -> Vector height a -> + (Vector width a, Vector opt a) +gaussMarkovLinearModel + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) d = + + let width = Extent.width extentA in + let opt = Extent.width extentB in + Array.unsafeCreateWithSizeAndResult width $ \m xPtr -> do + ArrayIO.unsafeCreateWithSize opt $ \p yPtr -> do + + let sameHeight shape0 shape1 = + if shape0 == shape1 + then shape0 + else error $ "gaussMarkovLinearModel: height shapes mismatch" + height = + sameHeight (Array.shape d) $ + sameHeight (Extent.height extentA) (Extent.height extentB) + let n = Shape.size height + evalContT $ do + mPtr <- Call.cint m + nPtr <- Call.cint n + pPtr <- Call.cint p + aPtr <- copyToColumnMajorTemp orderA n m a + ldaPtr <- Call.leadingDim n + bPtr <- copyToColumnMajorTemp orderB n p b + ldbPtr <- Call.leadingDim n + dPtr <- copyToTemp n (Array.buffer d) + liftIO $ withAutoWorkspaceInfo rankMsg "ggglm" $ + LapackGen.ggglm + nPtr mPtr pPtr aPtr ldaPtr bPtr ldbPtr dPtr xPtr yPtr + + +determinantAbsolute :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, + Class.Floating a) => + Full meas vert horiz height width a -> RealOf a +determinantAbsolute = + absolute . + either (HH.determinantR . HH.fromMatrix) (const zero) . + Basic.caseTallWide + + +complement :: + (Shape.C height, Shape.C width, Class.Floating a) => + Tall height width a -> Tall height ShapeInt a +complement = extractComplement . HH.fromMatrix + +extractComplement :: + (Shape.C height, Shape.C width, Class.Floating a) => + HH.Tall height width a -> Tall height ShapeInt a +extractComplement qr = + Basic.dropColumns + (Shape.size $ Layout.splitWidth $ Array.shape $ HH.split_ qr) $ + Basic.mapWidth (shapeInt . Shape.size) $ Square.toFull $ + HH.extractQ qr diff --git a/src/Numeric/LAPACK/Orthogonal/Householder.hs b/src/Numeric/LAPACK/Orthogonal/Householder.hs --- a/src/Numeric/LAPACK/Orthogonal/Householder.hs +++ b/src/Numeric/LAPACK/Orthogonal/Householder.hs @@ -1,13 +1,14 @@ module Numeric.LAPACK.Orthogonal.Householder ( - Basic.Householder, - Basic.General, - Basic.Tall, - Basic.Wide, - Basic.Square, - Basic.mapExtent, + Plain.Householder, + Plain.General, + Plain.Tall, + Plain.Wide, + Plain.Square, + Plain.LiberalSquare, + mapExtent, fromMatrix, - Basic.determinant, - Basic.determinantAbsolute, + Plain.determinant, + Plain.determinantAbsolute, leastSquares, minimumNorm, @@ -25,12 +26,15 @@ tallSolveR, ) where -import qualified Numeric.LAPACK.Orthogonal.Private as Basic +import qualified Numeric.LAPACK.Orthogonal.Plain as Plain +import qualified Numeric.LAPACK.Matrix.Array.Unpacked as Unpacked import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Modifier as Mod -import Numeric.LAPACK.Orthogonal.Private (Householder) -import Numeric.LAPACK.Matrix.Array.Triangular (Upper) +import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Orthogonal.Plain (Householder) +import Numeric.LAPACK.Matrix.Array.Mosaic (Upper) import Numeric.LAPACK.Matrix.Array (Full, Square) import Numeric.LAPACK.Matrix.Modifier (Transposition, Conjugation) @@ -39,21 +43,30 @@ import qualified Data.Array.Comfort.Shape as Shape +mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Householder measA vertA horizA height width a -> + Householder measB vertB horizB height width a +mapExtent = Plain.mapExtent . ExtentStrict.apply + + fromMatrix :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - Householder vert horiz height width a -fromMatrix = Basic.fromMatrix . ArrMatrix.toVector + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + Householder meas vert horiz height width a +fromMatrix = Plain.fromMatrix . ArrMatrix.toVector leastSquares :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => - Householder horiz Extent.Small height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -leastSquares = ArrMatrix.lift1 . Basic.leastSquares + Householder meas horiz Extent.Small height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +leastSquares = ArrMatrix.lift1 . Plain.leastSquares {- | @ @@ -63,84 +76,91 @@ @ -} minimumNorm :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => - Householder vert Extent.Small width height a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -minimumNorm = ArrMatrix.lift1 . Basic.minimumNorm + Householder meas vert Extent.Small width height a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +minimumNorm = ArrMatrix.lift1 . Plain.minimumNorm extractQ :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Householder vert horiz height width a -> Square height a -extractQ = ArrMatrix.lift0 . Basic.extractQ + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + Householder meas vert horiz height width a -> Square height a +extractQ = ArrMatrix.lift0 . Plain.extractQ tallExtractQ :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Householder vert Extent.Small height width a -> - Full vert Extent.Small height width a -tallExtractQ = ArrMatrix.lift0 . Basic.tallExtractQ + (Extent.Measure meas, Extent.C vert, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + Householder meas vert Extent.Small height width a -> + Full meas vert Extent.Small height width a +tallExtractQ = ArrMatrix.lift0 . Plain.tallExtractQ tallMultiplyQ :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Householder vert Extent.Small height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -tallMultiplyQ = ArrMatrix.lift1 . Basic.tallMultiplyQ + Householder meas vert Extent.Small height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +tallMultiplyQ = ArrMatrix.lift1 . Plain.tallMultiplyQ tallMultiplyQAdjoint :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Householder horiz Extent.Small fuse height a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -tallMultiplyQAdjoint = ArrMatrix.lift1 . Basic.tallMultiplyQAdjoint + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + Householder meas horiz Extent.Small fuse height a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +tallMultiplyQAdjoint = ArrMatrix.lift1 . Plain.tallMultiplyQAdjoint multiplyQ :: - (Extent.C vertA, Extent.C horizA, Shape.C widthA, - Extent.C vertB, Extent.C horizB, Shape.C widthB, - Shape.C height, Eq height, Class.Floating a) => + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, Shape.C widthA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB, Shape.C widthB, + ExtShape.Permutable height, Eq height, Class.Floating a) => Transposition -> Conjugation -> - Householder vertA horizA height widthA a -> - Full vertB horizB height widthB a -> - Full vertB horizB height widthB a + Householder measA vertA horizA height widthA a -> + Full measB vertB horizB height widthB a -> + Full measB vertB horizB height widthB a multiplyQ transposed conjugated = - ArrMatrix.lift1 . Basic.multiplyQ transposed conjugated + ArrMatrix.lift1 . Plain.multiplyQ transposed conjugated extractR :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Householder vert horiz height width a -> - Full vert horiz height width a -extractR = ArrMatrix.lift0 . Basic.extractR + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Shape.C width, Class.Floating a) => + Householder meas vert horiz height width a -> + Unpacked.UpperTrapezoid meas vert horiz height width a +extractR = ArrMatrix.liftUnpacked0 . Plain.extractR tallExtractR :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Householder vert Extent.Small height width a -> Upper width a -tallExtractR = ArrMatrix.lift0 . Basic.tallExtractR + (Extent.Measure meas, Extent.C vert, + Shape.C height, ExtShape.Permutable width, Class.Floating a) => + Householder meas vert Extent.Small height width a -> Upper width a +tallExtractR = ArrMatrix.lift0 . Plain.tallExtractR tallMultiplyR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + ExtShape.Permutable height, Eq height, Shape.C heightA, Shape.C widthB, Class.Floating a) => Transposition -> - Householder vertA Extent.Small heightA height a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a -tallMultiplyR transposed = ArrMatrix.lift1 . Basic.tallMultiplyR transposed + Householder measA vertA Extent.Small heightA height a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a +tallMultiplyR transposed = ArrMatrix.lift1 . Plain.tallMultiplyR transposed tallSolveR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, ExtShape.Permutable width, Eq width, Shape.C nrhs, + Class.Floating a) => Transposition -> Conjugation -> - Householder vertA Extent.Small height width a -> - Full vert horiz width nrhs a -> Full vert horiz width nrhs a + Householder measA vertA Extent.Small height width a -> + Full meas vert horiz width nrhs a -> Full meas vert horiz width nrhs a tallSolveR transposed conjugated = - ArrMatrix.lift1 . Basic.tallSolveR transposed conjugated + ArrMatrix.lift1 . Plain.tallSolveR transposed conjugated diff --git a/src/Numeric/LAPACK/Orthogonal/Plain.hs b/src/Numeric/LAPACK/Orthogonal/Plain.hs --- a/src/Numeric/LAPACK/Orthogonal/Plain.hs +++ b/src/Numeric/LAPACK/Orthogonal/Plain.hs @@ -1,39 +1,42 @@ {-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.Orthogonal.Plain ( - leastSquares, - minimumNorm, - leastSquaresMinimumNormRCond, - pseudoInverseRCond, - - leastSquaresConstraint, - gaussMarkovLinearModel, - - determinantAbsolute, - complement, - extractComplement, - ) where - -import qualified Numeric.LAPACK.Orthogonal.Private as HH +{-# LANGUAGE GADTs #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +module Numeric.LAPACK.Orthogonal.Plain where -import qualified Numeric.LAPACK.Matrix.Square.Basic as Square -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Divide as Divide +import qualified Numeric.LAPACK.Matrix.Multiply as Multiply +import qualified Numeric.LAPACK.Matrix.Type as Matrix +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Banded.Basic as Banded import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor,ColumnMajor)) -import Numeric.LAPACK.Matrix.Private - (Full, General, Tall, Wide, ShapeInt, shapeInt) -import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (RealOf, zero, absolute) +import qualified Numeric.LAPACK.Matrix.Private as MatrixPriv +import qualified Numeric.LAPACK.Matrix.Layout as LayoutPub +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Extent.Strict as ExtentStrict +import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Split as Split +import Numeric.LAPACK.Output ((/+/)) +import Numeric.LAPACK.Matrix.Plain.Format (formatArray) +import Numeric.LAPACK.Matrix.Type (Matrix, FormatMatrix(formatMatrix)) +import Numeric.LAPACK.Matrix.Triangular.Basic (Upper) +import Numeric.LAPACK.Matrix.Layout.Private + (Order(RowMajor, ColumnMajor), sideSwapFromOrder) +import Numeric.LAPACK.Matrix.Extent.Private (Extent) +import Numeric.LAPACK.Matrix.Modifier + (Transposition(NonTransposed, Transposed), + Conjugation(NonConjugated, Conjugated)) +import Numeric.LAPACK.Matrix.Private (Full) +import Numeric.LAPACK.Scalar (RealOf, zero, isZero, absolute, conjugate) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked), deconsUnchecked) import Numeric.LAPACK.Private - (lacgv, peekCInt, - copySubMatrix, copyToTemp, - copyToColumnMajorTemp, copyToSubColumnMajor, - withAutoWorkspaceInfo, rankMsg, errorCodeMsg, createHigherArray) + (fill, copySubMatrix, copyBlock, conjugateToTemp, caseRealComplexFunc, + withAutoWorkspaceInfo, errorCodeMsg) import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.LAPACK.FFI.Complex as LapackComplex -import qualified Numeric.LAPACK.FFI.Real as LapackReal import qualified Numeric.Netlib.Utility as Call import qualified Numeric.Netlib.Class as Class @@ -42,321 +45,527 @@ import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) -import System.IO.Unsafe (unsafePerformIO) - -import Foreign.Marshal.Array (pokeArray) -import Foreign.C.Types (CInt, CChar) +import Foreign.Marshal.Array (advancePtr) import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable) import Control.Monad.Trans.Cont (ContT(ContT), evalContT) import Control.Monad.IO.Class (liftIO) +import Control.Monad (when) +import Control.Applicative (liftA2) -import Data.Complex (Complex) -import Data.Tuple.HT (mapSnd) +import qualified Data.List as List +import Data.Monoid ((<>)) -leastSquares :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - Full horiz Extent.Small height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -leastSquares - (Array shapeA@(MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = +data Hh - case Extent.fuse (Extent.generalizeWide $ Extent.transpose extentA) extentB of - Nothing -> error "leastSquares: height shapes mismatch" - Just extent -> - Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \xPtr -> do +data instance Matrix Hh xl xu lower upper meas vert horiz height width a where + Householder :: + Banded.RectangularDiagonal meas vert horiz height width a -> + SplitArray meas vert horiz height width a -> + HouseholderFlex lower upper meas vert horiz height width a - let widthA = Extent.width extentA - let (height,widthB) = Extent.dimensions extentB - let (m,n) = MatrixShape.dimensions shapeA - let lda = m - let nrhs = Shape.size widthB - let ldb = Shape.size height - let ldx = Shape.size widthA - evalContT $ do - mPtr <- Call.cint m - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - (transPtr,aPtr) <- adjointA orderA (m*n) a - ldaPtr <- Call.leadingDim lda - ldbPtr <- Call.leadingDim ldb - bPtr <- copyToColumnMajorTemp orderB ldb nrhs b - liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ - LapackGen.gels transPtr - mPtr nPtr nrhsPtr aPtr ldaPtr bPtr ldbPtr - liftIO $ copySubMatrix ldx nrhs ldb bPtr ldx xPtr +deriving instance + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Storable a, + Show height, Show width, Show a) => + Show (Matrix Hh xl xu lower upper meas vert horiz height width a) -minimumNorm :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - Full Extent.Small vert height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -minimumNorm - (Array shapeA@(MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = +type SplitArray meas vert horiz height width a = + Split.Split Layout.Reflector meas vert horiz height width a - case Extent.fuse (Extent.generalizeTall $ Extent.transpose extentA) extentB of - Nothing -> error "minimumNorm: height shapes mismatch" - Just extent -> - Array.unsafeCreate (MatrixShape.Full ColumnMajor extent) $ \xPtr -> do +split_ :: + Matrix Hh xl xu lower upper meas vert horiz height width a -> + SplitArray meas vert horiz height width a +split_ (Householder _tau split) = split - let widthA = Extent.width extentA - let (height,widthB) = Extent.dimensions extentB - let (m,n) = MatrixShape.dimensions shapeA - let lda = m - let nrhs = Shape.size widthB - let ldb = Shape.size height - let ldx = Shape.size widthA +type HouseholderFlex = Matrix Hh () () +type Householder = HouseholderFlex Layout.Filled Layout.Filled +type General height width = + Householder Extent.Size Extent.Big Extent.Big height width +type Tall height width = + Householder Extent.Size Extent.Big Extent.Small height width +type Wide height width = + Householder Extent.Size Extent.Small Extent.Big height width +type LiberalSquare height width = SquareMeas Extent.Size height width +type Square sh = SquareMeas Extent.Shape sh sh +type SquareMeas meas height width = + Householder meas Extent.Small Extent.Small height width + + +mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + ExtentPriv.Map measA vertA horizA measB vertB horizB height width -> + HouseholderFlex lower upper measA vertA horizA height width a -> + HouseholderFlex lower upper measB vertB horizB height width a +mapExtent f (Householder tau split) = + Householder (Banded.mapExtent f tau) $ Split.mapExtent f split + +mapHeight :: + (Extent.C vert, Extent.C horiz) => + (heightA -> heightB) -> + HouseholderFlex lower upper Extent.Size vert horiz heightA width a -> + HouseholderFlex lower upper Extent.Size vert horiz heightB width a +mapHeight f (Householder tau split) = + Householder (Banded.mapHeight f tau) (Split.mapHeight f split) + +mapWidth :: + (Extent.C vert, Extent.C horiz) => + (widthA -> widthB) -> + HouseholderFlex lower upper Extent.Size vert horiz height widthA a -> + HouseholderFlex lower upper Extent.Size vert horiz height widthB a +mapWidth f (Householder tau split) = + Householder (Banded.mapWidth f tau) (Split.mapWidth f split) + +uncheck :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + HouseholderFlex lower upper meas vert horiz height width a -> + HouseholderFlex lower upper meas vert horiz + (Unchecked height) (Unchecked width) a +uncheck (Householder tau split) = + Householder + (Banded.mapExtentSizes (ExtentPriv.mapWrap Unchecked Unchecked) tau) + (Split.uncheck split) + + +caseTallWide :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Householder meas vert horiz height width a -> + Either (Tall height width a) (Wide height width a) +caseTallWide (Householder tau (Array shape a)) = + let consHouse taub b newShape = + Householder + (Array.mapShape + (\bandShape -> + bandShape{Layout.bandedExtent = Layout.splitExtent newShape}) + taub) $ + Array newShape b + in either (Left . consHouse tau a) (Right . consHouse tau a) $ + Layout.caseTallWideSplit shape + + +instance FormatMatrix Hh where + formatMatrix fmt (Householder tau m) = + formatArray fmt (Array.mapShape (Shape.ZeroBased . Shape.size) tau) + /+/ + formatArray fmt m + +fromMatrix :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + Householder meas vert horiz height width a +fromMatrix (Array shape@(Layout.Full order extent) a) = + uncurry Householder $ + Array.unsafeCreateWithSizeAndResult + (snd $ Layout.rectangularDiagonal extent) $ \_ tauPtr -> + ArrayIO.unsafeCreate + (Layout.Split Layout.Reflector order extent) $ \qrPtr -> + evalContT $ do + let (m,n) = Layout.dimensions shape mPtr <- Call.cint m nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - (transPtr,aPtr) <- adjointA orderA (m*n) a - ldaPtr <- Call.leadingDim lda - bPtr <- ContT $ withForeignPtr b - ldxPtr <- Call.leadingDim ldx - liftIO $ copyToSubColumnMajor orderB ldb nrhs bPtr ldx xPtr - liftIO $ withAutoWorkspaceInfo rankMsg "gels" $ - LapackGen.gels transPtr - mPtr nPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr + aPtr <- ContT $ withForeignPtr a + ldaPtr <- Call.leadingDim m + liftIO $ do + copyBlock (m*n) aPtr qrPtr + case order of + RowMajor -> + withAutoWorkspaceInfo errorCodeMsg "gelqf" $ + LapackGen.gelqf mPtr nPtr qrPtr ldaPtr tauPtr + ColumnMajor -> + withAutoWorkspaceInfo errorCodeMsg "geqrf" $ + LapackGen.geqrf mPtr nPtr qrPtr ldaPtr tauPtr +determinantR :: + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Householder meas vert Extent.Small height width a -> a +determinantR = Split.determinantR . split_ -adjointA :: - Class.Floating a => - Order -> Int -> ForeignPtr a -> ContT r IO (Ptr CChar, Ptr a) -adjointA order size a = do - aPtr <- copyToTemp size a - trans <- - case order of - RowMajor -> do - sizePtr <- Call.cint size - incPtr <- Call.cint 1 - liftIO $ lacgv sizePtr aPtr incPtr - return $ HH.invChar a - ColumnMajor -> return 'N' - transPtr <- Call.char trans - return (transPtr, aPtr) +{- +For complex numbers LAPACK uses not exactly reflections, +i.e. the determinants of the primitive transformations are not necessarily -1. +It holds: det(I-tau*v*v^H) = 1-tau*v^H*v + because of https://en.wikipedia.org/wiki/Sylvester's_determinant_theorem + simple proof from: https://en.wikipedia.org/wiki/Matrix_determinant_lemma + I 0 . I+u*vt u . I 0 = I+u*vt u . I 0 = I u + vt 1 0 1 -vt 1 vt+vt*u*vt vt*u+1 -vt 1 0 vt*u+1 -leastSquaresMinimumNormRCond :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => - RealOf a -> - Full horiz vert height width a -> - Full vert horiz height nrhs a -> - (Int, Full vert horiz width nrhs a) -leastSquaresMinimumNormRCond rcond - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = - case Extent.fuse (Extent.transpose extentA) extentB of - Nothing -> error "leastSquaresMinimumNormRCond: height shapes mismatch" - Just extent -> - let widthA = Extent.width extentA - (height,widthB) = Extent.dimensions extentB - shapeX = MatrixShape.Full ColumnMajor extent - m = Shape.size height - n = Shape.size widthA - nrhs = Shape.size widthB - in if m == 0 - then (0, Vector.zero shapeX) - else - if nrhs == 0 - then - (fst $ unsafePerformIO $ - case Vector.zero height of - Array _ b1 -> - leastSquaresMinimumNormIO rcond - (MatrixShape.general ColumnMajor widthA ()) - orderA a orderB b1 m n 1, - Vector.zero shapeX) - else - unsafePerformIO $ - leastSquaresMinimumNormIO rcond shapeX - orderA a orderB b m n nrhs +We already know: + v^H*v is real and greater or equal to 1, because v[i] = 1, + and determinant has absolute value 1. -leastSquaresMinimumNormIO :: +Let k = v^H*v. +For which real k lies 1-tau*k on the unit circle? + + (1-taur*k)^2 + (taui*k)^2 = 1 + 1-2*taur*k+(taur^2+taui^2)*k^2 = 1 + (taur^2 + taui^2)*k^2 - 2*taur*k = 0 (k/=0) + (taur^2 + taui^2)*k - 2*taur = 0 + k = 2*taur / (taur^2 + taui^2) + + 1-tau*k + = (taur^2 + taui^2 - tau*2*taur) / (taur^2 + taui^2) + = (taur^2 + taui^2 - 2*(taur+i*taui)*taur) / (taur^2 + taui^2) + = (-taur^2 + taui^2 - 2*(i*taui)*taur) / (taur^2 + taui^2) + = -(taur + i*taui)^2 / (taur^2 + taui^2) +-} +determinant :: (Shape.C sh, Class.Floating a) => - RealOf a -> sh -> - Order -> ForeignPtr a -> - Order -> ForeignPtr a -> - Int -> Int -> Int -> IO (Int, Array sh a) -leastSquaresMinimumNormIO rcond shapeX orderA a orderB b m n nrhs = - createHigherArray shapeX m n nrhs $ \(tmpPtr,ldtmp) -> do + HouseholderFlex lower upper Extent.Shape Extent.Small Extent.Small sh sh a -> + a +determinant (Householder tau split) = + List.foldl' (*) (Split.determinantR split) $ + (case Layout.splitOrder $ Array.shape split of + RowMajor -> map conjugate + ColumnMajor -> id) $ + map (negate.(^(2::Int)).signum) $ + filter (not . isZero) $ Array.toList tau - let lda = m - evalContT $ do - aPtr <- copyToColumnMajorTemp orderA m n a - ldaPtr <- Call.leadingDim lda - ldtmpPtr <- Call.leadingDim ldtmp - bPtr <- ContT $ withForeignPtr b - liftIO $ copyToSubColumnMajor orderB m nrhs bPtr ldtmp tmpPtr - jpvtPtr <- Call.allocaArray n - liftIO $ pokeArray jpvtPtr (replicate n 0) - rankPtr <- Call.alloca - gelsy m n nrhs aPtr ldaPtr tmpPtr ldtmpPtr jpvtPtr rcond rankPtr - liftIO $ peekCInt rankPtr +determinantAbsolute :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, + Class.Floating a) => + Householder meas vert horiz height width a -> RealOf a +determinantAbsolute = + absolute . either determinantR (const zero) . caseTallWide -type GELSY_ r ar a = - Int -> Int -> Int -> Ptr a -> Ptr CInt -> Ptr a -> Ptr CInt -> - Ptr CInt -> ar -> Ptr CInt -> ContT r IO () +leastSquares :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, + Class.Floating a) => + HouseholderFlex lower upper meas horiz Extent.Small height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +leastSquares qr = + case Matrix.extent qr of + ExtentPriv.Square _ -> leastSquaresAux qr + ExtentPriv.Separate _ _ -> + Basic.mapHeight deconsUnchecked . + leastSquaresAux (mapWidth Unchecked qr) -newtype GELSY r a = GELSY {getGELSY :: GELSY_ r (RealOf a) a} +leastSquaresAux :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, + Class.Floating a) => + HouseholderFlex lower upper meas horiz Extent.Small height width a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +leastSquaresAux qr = + tallSolveR NonTransposed NonConjugated qr . tallMultiplyQAdjoint qr -gelsy :: (Class.Floating a) => GELSY_ r (RealOf a) a -gelsy = - getGELSY $ - Class.switchFloating - (GELSY gelsyReal) - (GELSY gelsyReal) - (GELSY gelsyComplex) - (GELSY gelsyComplex) +minimumNorm :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C nrhs, + Class.Floating a) => + HouseholderFlex lower upper meas vert Extent.Small width height a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +minimumNorm qr = + case Matrix.extent qr of + ExtentPriv.Square _ -> minimumNormAux qr + ExtentPriv.Separate _ _ -> + Basic.mapHeight deconsUnchecked . + minimumNormAux (mapHeight Unchecked qr) -gelsyReal :: (Class.Real a) => GELSY_ r a a -gelsyReal m n nrhs aPtr ldaPtr bPtr ldbPtr jpvtPtr rcond rankPtr = do - mPtr <- Call.cint m - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - rcondPtr <- Call.real rcond - liftIO $ withAutoWorkspaceInfo errorCodeMsg "gelsy" $ - LapackReal.gelsy mPtr nPtr nrhsPtr - aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr +minimumNormAux :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, + Class.Floating a) => + HouseholderFlex lower upper meas vert Extent.Small width height a -> + Full meas vert horiz height nrhs a -> + Full meas vert horiz width nrhs a +minimumNormAux qr = tallMultiplyQ qr . tallSolveR Transposed Conjugated qr -gelsyComplex :: (Class.Real a) => GELSY_ r a (Complex a) -gelsyComplex m n nrhs aPtr ldaPtr bPtr ldbPtr jpvtPtr rcond rankPtr = do - mPtr <- Call.cint m - nPtr <- Call.cint n - nrhsPtr <- Call.cint nrhs - rcondPtr <- Call.real rcond - rworkPtr <- Call.allocaArray (2*n) - liftIO $ - withAutoWorkspaceInfo errorCodeMsg "gelsy" $ \workPtr lworkPtr infoPtr -> - LapackComplex.gelsy mPtr nPtr nrhsPtr - aPtr ldaPtr bPtr ldbPtr jpvtPtr rcondPtr rankPtr - workPtr lworkPtr rworkPtr infoPtr +takeRows :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => + Extent meas Extent.Small horiz height fuse -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +takeRows extentA (Array (Layout.Full order extentB) b) = + case Extent.fuse (ExtentPriv.weakenWide extentA) extentB of + Nothing -> error "Householder.takeRows: heights mismatch" + Just extentC -> + Basic.takeSub + (Extent.height extentB) 0 b (Layout.Full order extentC) +addRows :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => + Extent meas vert Extent.Small height fuse -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +addRows extentA (Array shapeB@(Layout.Full order extentB) b) = + case Extent.fuse (ExtentPriv.weakenTall extentA) extentB of + Nothing -> error "Householder.addRows: heights mismatch" + Just extentC -> + Array.unsafeCreateWithSize (Layout.Full order extentC) $ + \cSize cPtr -> + withForeignPtr b $ \bPtr -> + case order of + RowMajor -> do + let bSize = Shape.size shapeB + copyBlock bSize bPtr cPtr + fill zero (cSize - bSize) (advancePtr cPtr bSize) + ColumnMajor -> do + let n = Shape.size $ Extent.width extentB + mb = Shape.size $ Extent.height extentB + mc = Shape.size $ Extent.height extentC + copySubMatrix mb n mb bPtr mc cPtr + evalContT $ do + uploPtr <- Call.char 'A' + mPtr <- Call.cint (mc-mb) + nPtr <- Call.cint n + ldcPtr <- Call.leadingDim mc + zPtr <- Call.number zero + liftIO $ + LapackGen.laset uploPtr mPtr nPtr zPtr zPtr + (advancePtr cPtr mb) ldcPtr -pseudoInverseRCond :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => - RealOf a -> - Full vert horiz height width a -> - (Int, Full horiz vert width height a) -pseudoInverseRCond rcond a = - case Basic.caseTallWide a of - Left _ -> - mapSnd Basic.transpose $ - leastSquaresMinimumNormRCond rcond (Basic.transpose a) $ - Square.toFull $ Square.identity $ - MatrixShape.fullWidth $ Array.shape a - Right _ -> - leastSquaresMinimumNormRCond rcond a $ - Square.toFull $ Square.identity $ - MatrixShape.fullHeight $ Array.shape a +extractQ :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Householder meas vert horiz height width a -> MatrixPriv.Square height a +extractQ + (Householder tau (Array (Layout.Split _ order extent) qr)) = + extractQAux tau (Extent.width extent) order + (Extent.square $ Extent.height extent) qr -leastSquaresConstraint :: - (Shape.C height, Eq height, - Shape.C width, Eq width, - Shape.C constraints, Eq constraints, Class.Floating a) => - General height width a -> Vector height a -> - Wide constraints width a -> Vector constraints a -> - Vector width a -leastSquaresConstraint - (Array (MatrixShape.Full orderA extentA) a) c - (Array (MatrixShape.Full orderB extentB) b) d = +tallExtractQ :: + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Householder meas vert Extent.Small height width a -> + Full meas vert Extent.Small height width a +tallExtractQ + (Householder tau (Array (Layout.Split _ order extent) qr)) = + extractQAux tau (Extent.width extent) order extent qr - let sameShape name shape0 shape1 = - if shape0 == shape1 - then shape0 - else error $ "leastSquaresConstraint: " ++ name ++ " shapes mismatch" - width = sameShape "width" (Extent.width extentA) (Extent.width extentB) - in - Array.unsafeCreate width $ \xPtr -> do - let height = sameShape "height" (Extent.height extentA) (Array.shape c) - let constraints = - sameShape "constraints" (Extent.height extentB) (Array.shape d) +extractQAux :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Shape.C height, Shape.C width, Shape.C widthQR, + Class.Floating a) => + Banded.RectangularDiagonal measA vertA horizA height widthQR a -> + widthQR -> + Order -> Extent meas vert horiz height width -> ForeignPtr a -> + Full meas vert horiz height width a +extractQAux (Array widthTau tau) widthQR order extent qr = + Array.unsafeCreate (Layout.Full order extent) $ \qPtr -> do + + let (height,width) = Extent.dimensions extent let m = Shape.size height let n = Shape.size width - let p = Shape.size constraints + let k = Shape.size widthTau evalContT $ do mPtr <- Call.cint m nPtr <- Call.cint n - pPtr <- Call.cint p - aPtr <- copyToColumnMajorTemp orderA m n a - ldaPtr <- Call.leadingDim m - bPtr <- copyToColumnMajorTemp orderB p n b - ldbPtr <- Call.leadingDim p - cPtr <- copyToTemp m (Array.buffer c) - dPtr <- copyToTemp p (Array.buffer d) - liftIO $ withAutoWorkspaceInfo rankMsg "gglse" $ - LapackGen.gglse - mPtr nPtr pPtr aPtr ldaPtr bPtr ldbPtr cPtr dPtr xPtr + kPtr <- Call.cint k + qrPtr <- ContT $ withForeignPtr qr + tauPtr <- ContT $ withForeignPtr tau + case order of + RowMajor -> do + ldaPtr <- Call.leadingDim n + liftIO $ do + copySubMatrix k m (Shape.size widthQR) qrPtr n qPtr + withAutoWorkspaceInfo errorCodeMsg "unglq" $ + LapackGen.unglq nPtr mPtr kPtr qPtr ldaPtr tauPtr + ColumnMajor -> do + ldaPtr <- Call.leadingDim m + liftIO $ do + copyBlock (m*k) qrPtr qPtr + withAutoWorkspaceInfo errorCodeMsg "ungqr" $ + LapackGen.ungqr mPtr nPtr kPtr qPtr ldaPtr tauPtr -gaussMarkovLinearModel :: - (Shape.C height, Eq height, - Shape.C width, Eq width, - Shape.C opt, Eq opt, Class.Floating a) => - Tall height width a -> General height opt a -> Vector height a -> - (Vector width a, Vector opt a) -gaussMarkovLinearModel - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) d = - let width = Extent.width extentA in - let opt = Extent.width extentB in - Array.unsafeCreateWithSizeAndResult width $ \m xPtr -> do - ArrayIO.unsafeCreateWithSize opt $ \p yPtr -> do +tallMultiplyQ :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, + Class.Floating a) => + HouseholderFlex lower upper meas vert Extent.Small height fuse a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +tallMultiplyQ qr = + multiplyQ NonTransposed NonConjugated qr . addRows (Matrix.extent qr) - let sameHeight shape0 shape1 = - if shape0 == shape1 - then shape0 - else error $ "gaussMarkovLinearModel: height shapes mismatch" - height = - sameHeight (Array.shape d) $ - sameHeight (Extent.height extentA) (Extent.height extentB) - let n = Shape.size height +tallMultiplyQAdjoint :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => + HouseholderFlex lower upper meas horiz Extent.Small fuse height a -> + Full meas vert horiz fuse width a -> + Full meas vert horiz height width a +tallMultiplyQAdjoint qr = + takeRows (Extent.transpose $ Matrix.extent qr) . + multiplyQ Transposed Conjugated qr + + +multiplyQ :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, Shape.C widthA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB, Shape.C widthB, + Shape.C height, Eq height, Class.Floating a) => + Transposition -> Conjugation -> + HouseholderFlex lower upper measA vertA horizA height widthA a -> + Full measB vertB horizB height widthB a -> + Full measB vertB horizB height widthB a +multiplyQ transposed conjugated + (Householder + (Array widthTau tau) + (Array shapeA@(Layout.Split _ orderA extentA) qr)) + (Array shapeB@(Layout.Full orderB extentB) b) = + + Array.unsafeCreateWithSize shapeB $ \cSize cPtr -> do + + let (heightA,widthA) = Extent.dimensions extentA + let (height,width) = Extent.dimensions extentB + Call.assert "Householder.multiplyQ: height shapes mismatch" + (heightA == height) + + let (side,(m,n)) = + sideSwapFromOrder orderB (Shape.size height, Shape.size width) + evalContT $ do + sidePtr <- Call.char side mPtr <- Call.cint m nPtr <- Call.cint n - pPtr <- Call.cint p - aPtr <- copyToColumnMajorTemp orderA n m a - ldaPtr <- Call.leadingDim n - bPtr <- copyToColumnMajorTemp orderB n p b - ldbPtr <- Call.leadingDim n - dPtr <- copyToTemp n (Array.buffer d) - liftIO $ withAutoWorkspaceInfo rankMsg "ggglm" $ - LapackGen.ggglm - nPtr mPtr pPtr aPtr ldaPtr bPtr ldbPtr dPtr xPtr yPtr + let k = Shape.size widthTau + kPtr <- Call.cint k + transPtr <- + Call.char $ adjointFromTranspose qr $ + transposed <> if orderA==orderB then NonTransposed else Transposed + (qrPtr,tauPtr) <- + if (orderA==orderB) + == + (transposed==NonTransposed && conjugated==NonConjugated + || + transposed==Transposed && conjugated==Conjugated) + then + liftA2 (,) + (ContT $ withForeignPtr qr) + (ContT $ withForeignPtr tau) + else + liftA2 (,) + (conjugateToTemp (Shape.size shapeA) qr) + (conjugateToTemp k tau) + bPtr <- ContT $ withForeignPtr b + ldcPtr <- Call.leadingDim m + liftIO $ copyBlock cSize bPtr cPtr + case orderA of + ColumnMajor -> do + ldaPtr <- Call.leadingDim $ Shape.size heightA + liftIO $ withAutoWorkspaceInfo errorCodeMsg "unmqr" $ + LapackGen.unmqr sidePtr transPtr + mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr + RowMajor -> do + ldaPtr <- Call.leadingDim $ Shape.size widthA + -- work-around for https://github.com/Reference-LAPACK/lapack/issues/260 + liftIO $ when (k>0) $ + withAutoWorkspaceInfo errorCodeMsg "unmlq" $ + LapackGen.unmlq sidePtr transPtr + mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr +adjointFromTranspose :: (Class.Floating a) => f a -> Transposition -> Char +adjointFromTranspose qr Transposed = invChar qr +adjointFromTranspose _ NonTransposed = 'N' -determinantAbsolute :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> RealOf a -determinantAbsolute = - absolute . - either (HH.determinantR . HH.fromMatrix) (const zero) . - Basic.caseTallWide +invChar :: (Class.Floating a) => f a -> Char +invChar f = caseRealComplexFunc f 'T' 'C' -complement :: - (Shape.C height, Shape.C width, Class.Floating a) => - Tall height width a -> Tall height ShapeInt a -complement = extractComplement . HH.fromMatrix +extractR :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + HouseholderFlex lower upper meas vert horiz height width a -> + Full meas vert horiz height width a +extractR = Split.extractTriangle (Right Layout.Triangle) . split_ -extractComplement :: - (Shape.C height, Shape.C width, Class.Floating a) => - HH.Tall height width a -> Tall height ShapeInt a -extractComplement qr = - Basic.dropColumns - (Shape.size $ MatrixShape.splitWidth $ Array.shape $ HH.split_ qr) $ - Basic.mapWidth (shapeInt . Shape.size) $ Square.toFull $ - HH.extractQ qr +tallExtractR :: + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Householder meas vert Extent.Small height width a -> Upper width a +tallExtractR = Split.tallExtractR . split_ + +tallMultiplyR :: + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, + Shape.C heightA, Shape.C widthB, Class.Floating a) => + Transposition -> + HouseholderFlex lower upper measA vertA Extent.Small heightA height a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a +tallMultiplyR transposed = Split.tallMultiplyR transposed . split_ + +tallSolveR :: + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => + Transposition -> Conjugation -> + HouseholderFlex lower upper measA vertA Extent.Small height width a -> + Full meas vert horiz width nrhs a -> Full meas vert horiz width nrhs a +tallSolveR transposed conjugated = + Split.tallSolveR transposed conjugated . split_ + + +instance Matrix.Box Hh where + extent = Layout.splitExtent . Array.shape . split_ + +instance Matrix.ToQuadratic Hh where + heightToQuadratic (Householder tau split) = + Householder + (Array.mapShape (layoutTauSquare . Layout.bandedHeight) tau) + (Split.heightToQuadratic split) + widthToQuadratic (Householder tau split) = + Householder + (Array.mapShape (layoutTauSquare . Layout.bandedWidth) tau) + (Split.widthToQuadratic split) + +layoutTauSquare :: sh -> Layout.Diagonal sh +layoutTauSquare = LayoutPub.diagonal Layout.ColumnMajor + +instance (xl ~ (), xu ~ ()) => Matrix.MapExtent Hh xl xu lower upper where + mapExtent = mapExtent . ExtentStrict.apply + +instance (xl ~ (), xu ~ ()) => Multiply.MultiplyVector Hh xl xu where + matrixVector qr x = + Array.mapShape deconsUnchecked $ + Basic.unliftColumn Layout.ColumnMajor + (multiplyQ NonTransposed NonConjugated $ uncheck qr) $ + Array.mapShape Unchecked $ + Basic.multiplyVector (extractR qr) x + vectorMatrix x qr = + Basic.multiplyVector (Basic.transpose $ extractR qr) $ + Basic.unliftColumn Layout.ColumnMajor + (multiplyQ Transposed NonConjugated qr) x + +instance (xl ~ (), xu ~ ()) => Multiply.MultiplySquare Hh xl xu where + squareFull qr = + ArrMatrix.lift1 $ + multiplyQ NonTransposed NonConjugated qr . + tallMultiplyR NonTransposed qr + + fullSquare = flip $ \qr -> + ArrMatrix.lift1 $ + Basic.transpose . + tallMultiplyR Transposed qr . + multiplyQ Transposed NonConjugated qr . + Basic.transpose + +instance (xl ~ (), xu ~ ()) => Divide.Determinant Hh xl xu where + determinant = determinant + +instance (xl ~ (), xu ~ ()) => Divide.Solve Hh xl xu where + solveRight = ArrMatrix.lift1 . leastSquares . mapExtent ExtentPriv.fromSquare + solveLeft = + flip $ \a -> ArrMatrix.lift1 $ + Basic.adjoint . + minimumNorm (mapExtent ExtentPriv.fromSquare a) . + Basic.adjoint diff --git a/src/Numeric/LAPACK/Orthogonal/Private.hs b/src/Numeric/LAPACK/Orthogonal/Private.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/Orthogonal/Private.hs +++ /dev/null @@ -1,482 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE EmptyDataDecls #-} -module Numeric.LAPACK.Orthogonal.Private where - -import qualified Numeric.LAPACK.Matrix.Divide as Divide -import qualified Numeric.LAPACK.Matrix.Multiply as Multiply -import qualified Numeric.LAPACK.Matrix.Type as Type -import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Basic as Basic -import qualified Numeric.LAPACK.Matrix.Private as Matrix -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Extent.Private as ExtentPriv -import qualified Numeric.LAPACK.Matrix.Extent as Extent -import qualified Numeric.LAPACK.Split as Split -import qualified Numeric.LAPACK.Shape as ExtShape -import Numeric.LAPACK.Output ((/+/)) -import Numeric.LAPACK.Matrix.Plain.Format (formatArray) -import Numeric.LAPACK.Matrix.Type (FormatMatrix(formatMatrix)) -import Numeric.LAPACK.Matrix.Triangular.Basic (Upper) -import Numeric.LAPACK.Matrix.Shape.Private - (Order(RowMajor, ColumnMajor), sideSwapFromOrder) -import Numeric.LAPACK.Matrix.Extent.Private (Extent) -import Numeric.LAPACK.Matrix.Modifier - (Transposition(NonTransposed, Transposed), - Conjugation(NonConjugated, Conjugated)) -import Numeric.LAPACK.Matrix.Private (Full) -import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (RealOf, zero, isZero, absolute, conjugate) -import Numeric.LAPACK.Private - (fill, copySubMatrix, copyBlock, conjugateToTemp, caseRealComplexFunc, - withAutoWorkspaceInfo, errorCodeMsg) - -import qualified Numeric.LAPACK.FFI.Generic as LapackGen -import qualified Numeric.Netlib.Utility as Call -import qualified Numeric.Netlib.Class as Class - -import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as ArrayIO -import qualified Data.Array.Comfort.Storable.Unchecked as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable.Unchecked (Array(Array)) - -import Foreign.Marshal.Array (advancePtr) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) - -import Control.Monad.Trans.Cont (ContT(ContT), evalContT) -import Control.Monad.IO.Class (liftIO) -import Control.Monad (when) -import Control.Applicative (liftA2) - -import qualified Data.List as List -import Data.Monoid ((<>)) - - -data Hh vert horiz height width - -data instance Type.Matrix (Hh vert horiz height width) a = - Householder { - tau_ :: Vector (ExtShape.Min height width) a, - split_ :: - Array - (MatrixShape.Split MatrixShape.Reflector vert horiz height width) a - } deriving (Show) - -type Householder vert horiz height width = - Type.Matrix (Hh vert horiz height width) -type General height width = Householder Extent.Big Extent.Big height width -type Tall height width = Householder Extent.Big Extent.Small height width -type Wide height width = Householder Extent.Small Extent.Big height width -type Square sh = Householder Extent.Small Extent.Small sh sh - - -extent_ :: - Householder vert horiz height width a -> - Extent vert horiz height width -extent_ = MatrixShape.splitExtent . Array.shape . split_ - -mapExtent :: - (Extent.C vertA, Extent.C horizA) => - (Extent.C vertB, Extent.C horizB) => - Extent.Map vertA horizA vertB horizB height width -> - Householder vertA horizA height width a -> - Householder vertB horizB height width a -mapExtent f (Householder tau split) = - Householder tau $ Array.mapShape (MatrixShape.splitMapExtent f) split - -caseTallWide :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Householder vert horiz height width a -> - Either (Tall height width a) (Wide height width a) -caseTallWide (Householder tau (Array shape a)) = - either - (Left . Householder tau . flip Array a) - (Right . Householder tau . flip Array a) $ - MatrixShape.caseTallWideSplit shape - - -instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - FormatMatrix (Hh vert horiz height width) where - formatMatrix fmt (Householder tau m) = - formatArray fmt (Array.mapShape (Shape.ZeroBased . Shape.size) tau) - /+/ - formatArray fmt m - -fromMatrix :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - Householder vert horiz height width a -fromMatrix (Array shape@(MatrixShape.Full order extent) a) = - uncurry Householder $ - Array.unsafeCreateWithSizeAndResult - (uncurry ExtShape.Min $ Extent.dimensions extent) $ \_ tauPtr -> - ArrayIO.unsafeCreate - (MatrixShape.Split MatrixShape.Reflector order extent) $ \qrPtr -> - - evalContT $ do - let (m,n) = MatrixShape.dimensions shape - mPtr <- Call.cint m - nPtr <- Call.cint n - aPtr <- ContT $ withForeignPtr a - ldaPtr <- Call.leadingDim m - liftIO $ do - copyBlock (m*n) aPtr qrPtr - case order of - RowMajor -> - withAutoWorkspaceInfo errorCodeMsg "gelqf" $ - LapackGen.gelqf mPtr nPtr qrPtr ldaPtr tauPtr - ColumnMajor -> - withAutoWorkspaceInfo errorCodeMsg "geqrf" $ - LapackGen.geqrf mPtr nPtr qrPtr ldaPtr tauPtr - -determinantR :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Householder vert Extent.Small height width a -> a -determinantR = Split.determinantR . split_ - -{- -For complex numbers LAPACK uses not exactly reflections, -i.e. the determinants of the primitive transformations are not necessarily -1. - -It holds: det(I-tau*v*v^H) = 1-tau*v^H*v - because of https://en.wikipedia.org/wiki/Sylvester's_determinant_theorem - simple proof from: https://en.wikipedia.org/wiki/Matrix_determinant_lemma - I 0 . I+u*vt u . I 0 = I+u*vt u . I 0 = I u - vt 1 0 1 -vt 1 vt+vt*u*vt vt*u+1 -vt 1 0 vt*u+1 - -We already know: - v^H*v is real and greater or equal to 1, because v[i] = 1, - and determinant has absolute value 1. - -Let k = v^H*v. -For which real k lies 1-tau*k on the unit circle? - - (1-taur*k)^2 + (taui*k)^2 = 1 - 1-2*taur*k+(taur^2+taui^2)*k^2 = 1 - (taur^2 + taui^2)*k^2 - 2*taur*k = 0 (k/=0) - (taur^2 + taui^2)*k - 2*taur = 0 - k = 2*taur / (taur^2 + taui^2) - - 1-tau*k - = (taur^2 + taui^2 - tau*2*taur) / (taur^2 + taui^2) - = (taur^2 + taui^2 - 2*(taur+i*taui)*taur) / (taur^2 + taui^2) - = (-taur^2 + taui^2 - 2*(i*taui)*taur) / (taur^2 + taui^2) - = -(taur + i*taui)^2 / (taur^2 + taui^2) --} -determinant :: - (Shape.C sh, Class.Floating a) => - Square sh a -> a -determinant (Householder tau split) = - List.foldl' (*) (Split.determinantR split) $ - (case MatrixShape.splitOrder $ Array.shape split of - RowMajor -> map conjugate - ColumnMajor -> id) $ - map (negate.(^(2::Int)).signum) $ - filter (not . isZero) $ Array.toList tau - -determinantAbsolute :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Householder vert horiz height width a -> RealOf a -determinantAbsolute = - absolute . either determinantR (const zero) . caseTallWide - - -leastSquares :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, - Class.Floating a) => - Householder horiz Extent.Small height width a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -leastSquares qr = - tallSolveR NonTransposed NonConjugated qr . tallMultiplyQAdjoint qr - -minimumNorm :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width, Shape.C nrhs, - Class.Floating a) => - Householder vert Extent.Small width height a -> - Full vert horiz height nrhs a -> - Full vert horiz width nrhs a -minimumNorm qr = tallMultiplyQ qr . tallSolveR Transposed Conjugated qr - -takeRows :: - (Extent.C vert, Extent.C horiz, - Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => - Extent Extent.Small horiz height fuse -> - Full vert horiz fuse width a -> - Full vert horiz height width a -takeRows extentA (Array (MatrixShape.Full order extentB) b) = - case Extent.fuse (ExtentPriv.generalizeWide extentA) extentB of - Nothing -> error "Householder.takeRows: heights mismatch" - Just extentC -> - Basic.takeSub - (Extent.height extentB) 0 b (MatrixShape.Full order extentC) - -addRows :: - (Extent.C vert, Extent.C horiz, - Eq fuse, Shape.C fuse, Shape.C height, Shape.C width, Class.Floating a) => - Extent vert Extent.Small height fuse -> - Full vert horiz fuse width a -> - Full vert horiz height width a -addRows extentA (Array shapeB@(MatrixShape.Full order extentB) b) = - case Extent.fuse (ExtentPriv.generalizeTall extentA) extentB of - Nothing -> error "Householder.addRows: heights mismatch" - Just extentC -> - Array.unsafeCreateWithSize (MatrixShape.Full order extentC) $ - \cSize cPtr -> - withForeignPtr b $ \bPtr -> - case order of - RowMajor -> do - let bSize = Shape.size shapeB - copyBlock bSize bPtr cPtr - fill zero (cSize - bSize) (advancePtr cPtr bSize) - ColumnMajor -> do - let n = Shape.size $ Extent.width extentB - mb = Shape.size $ Extent.height extentB - mc = Shape.size $ Extent.height extentC - copySubMatrix mb n mb bPtr mc cPtr - evalContT $ do - uploPtr <- Call.char 'A' - mPtr <- Call.cint (mc-mb) - nPtr <- Call.cint n - ldcPtr <- Call.leadingDim mc - zPtr <- Call.number zero - liftIO $ - LapackGen.laset uploPtr mPtr nPtr zPtr zPtr - (advancePtr cPtr mb) ldcPtr - - -extractQ :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Householder vert horiz height width a -> Matrix.Square height a -extractQ - (Householder tau (Array (MatrixShape.Split _ order extent) qr)) = - extractQAux tau (Extent.width extent) order - (Extent.square $ Extent.height extent) qr - -tallExtractQ :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Householder vert Extent.Small height width a -> - Full vert Extent.Small height width a -tallExtractQ - (Householder tau (Array (MatrixShape.Split _ order extent) qr)) = - extractQAux tau (Extent.width extent) order extent qr - - -extractQAux :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Shape.C widthQR, - Class.Floating a) => - Vector (ExtShape.Min height widthQR) a -> widthQR -> - Order -> Extent vert horiz height width -> ForeignPtr a -> - Full vert horiz height width a -extractQAux (Array widthTau tau) widthQR order extent qr = - Array.unsafeCreate (MatrixShape.Full order extent) $ \qPtr -> do - - let (height,width) = Extent.dimensions extent - let m = Shape.size height - let n = Shape.size width - let k = Shape.size widthTau - evalContT $ do - mPtr <- Call.cint m - nPtr <- Call.cint n - kPtr <- Call.cint k - qrPtr <- ContT $ withForeignPtr qr - tauPtr <- ContT $ withForeignPtr tau - case order of - RowMajor -> do - ldaPtr <- Call.leadingDim n - liftIO $ do - copySubMatrix k m (Shape.size widthQR) qrPtr n qPtr - withAutoWorkspaceInfo errorCodeMsg "unglq" $ - LapackGen.unglq nPtr mPtr kPtr qPtr ldaPtr tauPtr - ColumnMajor -> do - ldaPtr <- Call.leadingDim m - liftIO $ do - copyBlock (m*k) qrPtr qPtr - withAutoWorkspaceInfo errorCodeMsg "ungqr" $ - LapackGen.ungqr mPtr nPtr kPtr qPtr ldaPtr tauPtr - - -tallMultiplyQ :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Shape.C fuse, Eq fuse, - Class.Floating a) => - Householder vert Extent.Small height fuse a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -tallMultiplyQ qr = - multiplyQ NonTransposed NonConjugated qr . addRows (extent_ qr) - -tallMultiplyQAdjoint :: - (Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Shape.C fuse, Eq fuse, Class.Floating a) => - Householder horiz Extent.Small fuse height a -> - Full vert horiz fuse width a -> - Full vert horiz height width a -tallMultiplyQAdjoint qr = - takeRows (Extent.transpose $ extent_ qr) . - multiplyQ Transposed Conjugated qr - - -multiplyQ :: - (Extent.C vertA, Extent.C horizA, Shape.C widthA, - Extent.C vertB, Extent.C horizB, Shape.C widthB, - Shape.C height, Eq height, Class.Floating a) => - Transposition -> Conjugation -> - Householder vertA horizA height widthA a -> - Full vertB horizB height widthB a -> - Full vertB horizB height widthB a -multiplyQ transposed conjugated - (Householder - (Array widthTau tau) - (Array shapeA@(MatrixShape.Split _ orderA extentA) qr)) - (Array shapeB@(MatrixShape.Full orderB extentB) b) = - - Array.unsafeCreateWithSize shapeB $ \cSize cPtr -> do - - let (heightA,widthA) = Extent.dimensions extentA - let (height,width) = Extent.dimensions extentB - Call.assert "Householder.multiplyQ: height shapes mismatch" - (heightA == height) - - let (side,(m,n)) = - sideSwapFromOrder orderB (Shape.size height, Shape.size width) - - evalContT $ do - sidePtr <- Call.char side - mPtr <- Call.cint m - nPtr <- Call.cint n - let k = Shape.size widthTau - kPtr <- Call.cint k - transPtr <- - Call.char $ adjointFromTranspose qr $ - transposed <> if orderA==orderB then NonTransposed else Transposed - (qrPtr,tauPtr) <- - if (orderA==orderB) - == - (transposed==NonTransposed && conjugated==NonConjugated - || - transposed==Transposed && conjugated==Conjugated) - then - liftA2 (,) - (ContT $ withForeignPtr qr) - (ContT $ withForeignPtr tau) - else - liftA2 (,) - (conjugateToTemp (Shape.size shapeA) qr) - (conjugateToTemp k tau) - bPtr <- ContT $ withForeignPtr b - ldcPtr <- Call.leadingDim m - liftIO $ copyBlock cSize bPtr cPtr - case orderA of - ColumnMajor -> do - ldaPtr <- Call.leadingDim $ Shape.size heightA - liftIO $ withAutoWorkspaceInfo errorCodeMsg "unmqr" $ - LapackGen.unmqr sidePtr transPtr - mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr - RowMajor -> do - ldaPtr <- Call.leadingDim $ Shape.size widthA - -- work-around for https://github.com/Reference-LAPACK/lapack/issues/260 - liftIO $ when (k>0) $ - withAutoWorkspaceInfo errorCodeMsg "unmlq" $ - LapackGen.unmlq sidePtr transPtr - mPtr nPtr kPtr qrPtr ldaPtr tauPtr cPtr ldcPtr - -adjointFromTranspose :: (Class.Floating a) => f a -> Transposition -> Char -adjointFromTranspose qr Transposed = invChar qr -adjointFromTranspose _ NonTransposed = 'N' - -invChar :: (Class.Floating a) => f a -> Char -invChar f = caseRealComplexFunc f 'T' 'C' - - -extractR :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Householder vert horiz height width a -> - Full vert horiz height width a -extractR = Split.extractTriangle (Right MatrixShape.Triangle) . split_ - -tallExtractR :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Householder vert Extent.Small height width a -> Upper width a -tallExtractR = Split.tallExtractR . split_ - -tallMultiplyR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, - Shape.C heightA, Shape.C widthB, Class.Floating a) => - Transposition -> - Householder vertA Extent.Small heightA height a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a -tallMultiplyR transposed = Split.tallMultiplyR transposed . split_ - -tallSolveR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, - Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => - Transposition -> Conjugation -> - Householder vertA Extent.Small height width a -> - Full vert horiz width nrhs a -> Full vert horiz width nrhs a -tallSolveR transposed conjugated = - Split.tallSolveR transposed conjugated . split_ - - -instance - (Extent.C vert, Extent.C horiz) => - Type.Box (Hh vert horiz height width) where - type HeightOf (Hh vert horiz height width) = height - type WidthOf (Hh vert horiz height width) = width - height = MatrixShape.splitHeight . Array.shape . split_ - width = MatrixShape.splitWidth . Array.shape . split_ - -instance - (Extent.C vert, Extent.C horiz, - Shape.C height, Eq height, Shape.C width, Eq width) => - Multiply.MultiplyVector (Hh vert horiz height width) where - matrixVector qr x = - Basic.unliftColumn MatrixShape.ColumnMajor - (multiplyQ NonTransposed NonConjugated qr) $ - Basic.multiplyVector (extractR qr) x - vectorMatrix x qr = - Basic.multiplyVector (Basic.transpose $ extractR qr) $ - Basic.unliftColumn MatrixShape.ColumnMajor - (multiplyQ Transposed NonConjugated qr) x - -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Multiply.MultiplySquare (Hh vert horiz height width) where - - squareFull qr = - ArrMatrix.lift1 $ - multiplyQ NonTransposed NonConjugated qr . - tallMultiplyR NonTransposed qr - - fullSquare = flip $ \qr -> - ArrMatrix.lift1 $ - Basic.transpose . - tallMultiplyR Transposed qr . - multiplyQ Transposed NonConjugated qr . - Basic.transpose - -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Divide.Determinant (Hh vert horiz height width) where - determinant = determinant - -instance - (vert ~ Extent.Small, horiz ~ Extent.Small, - Shape.C height, height ~ width) => - Divide.Solve (Hh vert horiz height width) where - solveRight = ArrMatrix.lift1 . leastSquares . mapExtent Extent.fromSquare - solveLeft = - flip $ \a -> ArrMatrix.lift1 $ - Basic.adjoint . - minimumNorm (mapExtent Extent.fromSquare a) . - Basic.adjoint diff --git a/src/Numeric/LAPACK/Permutation.hs b/src/Numeric/LAPACK/Permutation.hs --- a/src/Numeric/LAPACK/Permutation.hs +++ b/src/Numeric/LAPACK/Permutation.hs @@ -32,9 +32,9 @@ toMatrix = ArrMatrix.lift0 . Plain.toMatrix apply :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Mod.Inversion -> Permutation height -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a apply inverted = ArrMatrix.lift1 . Plain.apply inverted diff --git a/src/Numeric/LAPACK/Permutation/Private.hs b/src/Numeric/LAPACK/Permutation/Private.hs --- a/src/Numeric/LAPACK/Permutation/Private.hs +++ b/src/Numeric/LAPACK/Permutation/Private.hs @@ -1,16 +1,15 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Permutation.Private where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent -import qualified Numeric.LAPACK.Shape as ExtShape import qualified Numeric.LAPACK.Output as Output import Numeric.LAPACK.Output (Output, formatAligned) -import Numeric.LAPACK.Matrix.Shape.Private (Order(RowMajor, ColumnMajor)) +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor)) import Numeric.LAPACK.Matrix.Modifier (Transposition(NonTransposed,Transposed), Inversion(NonInverted,Inverted)) -import Numeric.LAPACK.Matrix.Private (Full, Square, shapeInt) +import Numeric.LAPACK.Matrix.Private (Full, Square) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (zero, one) import Numeric.LAPACK.Private (copyBlock, copyToTemp) @@ -26,7 +25,7 @@ import Data.Array.Comfort.Storable.Unchecked (Array(Array), (!)) import Foreign.C.Types (CInt) -import Foreign.ForeignPtr (withForeignPtr) +import Foreign.ForeignPtr (withForeignPtr, castForeignPtr) import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (Storable, sizeOf, alignment, poke, peek) @@ -49,11 +48,10 @@ >>> import Test.Permutation (genPerm, genPivots) >>> >>> import qualified Numeric.LAPACK.Permutation as Perm ->>> import Numeric.LAPACK.Permutation (Permutation, Inversion(NonInverted), determinant, multiply, transpose) +>>> import Numeric.LAPACK.Permutation +>>> (Permutation, determinant, multiply, transpose) >>> import Numeric.LAPACK.Matrix (ShapeInt) >>> ->>> import qualified Data.Array.Comfort.Storable as Array ->>> import Data.Eq.HT (equating) >>> import Data.Semigroup ((<>)) >>> >>> import Control.Applicative (liftA2) @@ -66,7 +64,7 @@ newtype Permutation sh = Permutation (Vector (Shape sh) (Element sh)) - deriving (Show) + deriving (Eq, Show) format :: (Shape.C sh, Output out) => Permutation sh -> out format (Permutation perm) = @@ -80,36 +78,55 @@ size :: Permutation sh -> sh size (Permutation (Array (Shape shape) _perm)) = shape +{- | +Number of elements must be maintained. +-} +mapSizeUnchecked :: (shA -> shB) -> Permutation shA -> Permutation shB +mapSizeUnchecked f (Permutation (Array (Shape shape) perm)) = + Permutation $ Array (Shape $ f shape) $ castForeignPtr perm + +{- | +Number of elements must be maintained. +-} +mapSize :: + (Shape.C shA, Shape.C shB) => + (shA -> shB) -> Permutation shA -> Permutation shB +mapSize f = mapSizeUnchecked (Layout.mapChecked "Permutation.mapSize" f) + identity :: (Shape.C sh) => sh -> Permutation sh identity shape = Permutation $ CheckedArray.sample (Shape shape) id {- | -prop> QC.forAll QC.arbitraryBoundedEnum $ \inv -> QC.forAll (QC.arbitrary >>= genPivots) $ \xs -> Array.toList xs == Array.toList (Perm.toPivots inv (Perm.fromPivots inv xs)) +prop> QC.forAll QC.arbitraryBoundedEnum $ \inv -> QC.forAll (QC.arbitrary >>= genPivots) $ \xs -> xs == Perm.toPivots inv (Perm.fromPivots inv xs) -} fromPivots :: (Shape.C sh) => Inversion -> Vector (Shape sh) (Element sh) -> Permutation sh fromPivots inverted ipiv = - fromPivotsGen inverted (Array.shape ipiv) ipiv + fromPivotsGen id inverted (Array.shape ipiv) ipiv {- We could use laswp if it would be available for CInt elements. -} fromTruncatedPivots :: - (Shape.C sh, Shape.C sh1) => - Inversion -> - Vector (ExtShape.Min sh1 (Shape sh)) (Element sh) -> Permutation sh + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width) => + (diagShape ~ Layout.RectangularDiagonal meas vert horiz height width) => + Inversion -> Vector (Shape diagShape) (Element height) -> Permutation height fromTruncatedPivots inverted ipiv = - fromPivotsGen inverted (ExtShape.minShape1 $ Array.shape ipiv) ipiv + fromPivotsGen (\(Element i) -> Element i) + inverted (Layout.bandedHeight <$> Array.shape ipiv) ipiv fromPivotsGen :: - (Shape.C sh, Shape.Indexed small, Shape.Index small ~ Element sh) => - Inversion -> Shape sh -> Vector small (Element sh) -> Permutation sh -fromPivotsGen inverted sh ipiv = + (Shape.C sh, Shape.C small) => + (Element small -> Element sh) -> + Inversion -> Shape sh -> Vector (Shape small) (Element sh) -> Permutation sh +fromPivotsGen mapIx inverted sh ipiv = Permutation $ runST (do perm <- initMutable sh $ \perm i -> MutArray.write perm i i - forM_ (indices inverted $ Array.shape ipiv) $ \i -> swap perm i (ipiv!i) + forM_ (indices inverted $ Array.shape ipiv) $ \i -> + swap perm (mapIx i) (ipiv!i) MutArray.unsafeFreeze perm) swap :: @@ -120,9 +137,7 @@ MutArray.write arr i =<< MutArray.read arr j MutArray.write arr j a -indices :: - (Shape.C sh, Shape.Indexed small, Shape.Index small ~ Element sh) => - Inversion -> small -> [Element sh] +indices :: (Shape.C sh) => Inversion -> Shape sh -> [Element sh] indices inverted sh = let numIPiv = Shape.size sh in take numIPiv $ map Element $ @@ -132,10 +147,10 @@ toPivots :: - (Shape.C sh) => Inversion -> Permutation sh -> Vector sh (Element sh) + (Shape.C sh) => Inversion -> Permutation sh -> Vector (Shape sh) (Element sh) toPivots inverted (Permutation a) = let sh = Array.shape a - in Array.reshape (deconsShape sh) $ + in Array.reshape sh $ runST (do (inv,perm) <- (case inverted of Inverted -> Tuple.swap; NonInverted -> id) @@ -194,7 +209,7 @@ {- | -prop> QC.forAll genPerm2 $ \(p0,p1) -> equating (Array.toList . Perm.toPivots NonInverted) (transpose $ multiply p0 p1) (multiply (transpose p1) (transpose p0)) +prop> QC.forAll genPerm2 $ \(p0,p1) -> transpose (multiply p0 p1) == multiply (transpose p1) (transpose p0) -} transpose :: (Shape.C sh) => Permutation sh -> Permutation sh transpose (Permutation perm) = @@ -242,7 +257,7 @@ toMatrix :: (Shape.C sh, Class.Floating a) => Permutation sh -> Square sh a toMatrix (Permutation perm) = let shape = Array.shape perm - in Array.reshape (MatrixShape.square RowMajor $ deconsShape shape) $ + in Array.reshape (Layout.square RowMajor $ deconsShape shape) $ runST (do a <- MutArray.new (shape,shape) zero forM_ (Shape.indices $ Array.shape perm) $ \k -> @@ -251,14 +266,14 @@ apply :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Class.Floating a) => Inversion -> Permutation height -> - Full vert horiz height width a -> - Full vert horiz height width a + Full meas vert horiz height width a -> + Full meas vert horiz height width a apply inverted (Permutation (Array (Shape shapeP) perm)) - (Array shape@(MatrixShape.Full order extent) a) = + (Array shape@(Layout.Full order extent) a) = Array.unsafeCreateWithSize shape $ \blockSize bPtr -> do @@ -301,24 +316,26 @@ deconsElementPtr :: Ptr (Element sh) -> Ptr CInt deconsElementPtr = castPtr +instance Functor Shape where + fmap f (Shape sh) = Shape $ f sh + instance (Shape.C sh) => Shape.C (Shape sh) where size (Shape sh) = Shape.size sh - uncheckedSize (Shape sh) = Shape.uncheckedSize sh +shapeInt :: (Shape.C sh) => sh -> Shape.OneBased Int +shapeInt = Shape.OneBased . Shape.size + instance (Shape.C sh) => Shape.Indexed (Shape sh) where type Index (Shape sh) = Element sh indices (Shape sh) = map Element $ take (Shape.size sh) [1 ..] - offset (Shape sh) (Element k) = - Shape.offset (shapeInt $ Shape.size sh) (fromIntegral k - 1) - uncheckedOffset _ (Element k) = fromIntegral k - 1 + unifiedOffset (Shape sh) (Element k) = + Shape.unifiedOffset (shapeInt sh) (fromIntegral k) inBounds (Shape sh) (Element k) = - Shape.inBounds (shapeInt $ Shape.size sh) (fromIntegral k - 1) + Shape.inBounds (shapeInt sh) (fromIntegral k) instance (Shape.C sh) => Shape.InvIndexed (Shape sh) where - indexFromOffset (Shape sh) k = - Element $ - 1 + fromIntegral (Shape.indexFromOffset (shapeInt $ Shape.size sh) k) - uncheckedIndexFromOffset _sh = Element . (1+) . fromIntegral + unifiedIndexFromOffset (Shape sh) = + fmap (Element . fromIntegral) . Shape.unifiedIndexFromOffset (shapeInt sh) instance Storable (Element sh) where {-# INLINE sizeOf #-} diff --git a/src/Numeric/LAPACK/Private.hs b/src/Numeric/LAPACK/Private.hs --- a/src/Numeric/LAPACK/Private.hs +++ b/src/Numeric/LAPACK/Private.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Private where -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), transposeFromOrder) import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) @@ -301,9 +301,9 @@ mul :: (Class.Floating a) => - Int -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () -mul n aPtr inca xPtr incx yPtr incy = evalContT $ do - transPtr <- Call.char 'N' + Conjugation -> Int -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO () +mul conj n aPtr inca xPtr incx yPtr incy = evalContT $ do + transPtr <- Call.char $ case conj of NonConjugated -> 'N'; Conjugated -> 'C' nPtr <- Call.cint n klPtr <- Call.cint 0 kuPtr <- Call.cint 0 @@ -353,7 +353,7 @@ Int -> Ptr a -> Int -> Ptr a -> Int -> IO () mulPairs n aPtr inca xPtr incx = let inca2 = 2*inca - in mul n aPtr inca2 (advancePtr aPtr inca) inca2 xPtr incx + in mul NonConjugated n aPtr inca2 (advancePtr aPtr inca) inca2 xPtr incx newtype LACGV a = LACGV {getLACGV :: Ptr CInt -> Ptr a -> Ptr CInt -> IO ()} @@ -417,11 +417,13 @@ (Class.Floating a) => Order -> Order -> Int -> Int -> Int -> ForeignPtr a -> ForeignPtr a -> Ptr a -> IO () -multiplyMatrix orderA orderB m k n a b cPtr = do +multiplyMatrix orderA orderB m k n a b cPtr = evalContT $ do let lda = case orderA of RowMajor -> k; ColumnMajor -> m let ldb = case orderB of RowMajor -> n; ColumnMajor -> k let ldc = m - evalContT $ do + if k==0 + then liftIO $ fill zero (m*n) cPtr + else do transaPtr <- Call.char $ transposeFromOrder orderA transbPtr <- Call.char $ transposeFromOrder orderB mPtr <- Call.cint m diff --git a/src/Numeric/LAPACK/Scalar.hs b/src/Numeric/LAPACK/Scalar.hs --- a/src/Numeric/LAPACK/Scalar.hs +++ b/src/Numeric/LAPACK/Scalar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Numeric.LAPACK.Scalar ( RealOf, ComplexOf, @@ -6,9 +7,19 @@ one, minusOne, isZero, + selectReal, selectFloating, + ComplexSingleton(Real,Complex), + complexSingleton, + complexSingletonOf, + complexSingletonOfFunctor, + PrecisionSingleton(Float,Double), + precisionSingleton, + precisionOf, + precisionOfFunctor, + equal, fromReal, toComplex, @@ -19,27 +30,55 @@ conjugate, ) where -import Numeric.LAPACK.Wrapper (Flip(Flip, getFlip)) - import qualified Numeric.Netlib.Class as Class import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Data.Complex as Complex import Data.Complex (Complex((:+))) -import Data.Monoid (Endo(Endo,appEndo)) type family RealOf x type instance RealOf Float = Float type instance RealOf Double = Double -type instance RealOf (Complex a) = a +type instance RealOf (Complex.Complex a) = a -type ComplexOf x = Complex (RealOf x) +type ComplexOf x = Complex.Complex (RealOf x) +data ComplexSingleton a where + Real :: (Class.Real a, RealOf a ~ a) => ComplexSingleton a + Complex :: (Class.Real a) => ComplexSingleton (Complex.Complex a) + +complexSingleton :: (Class.Floating a) => ComplexSingleton a +complexSingleton = Class.switchFloating Real Real Complex Complex + +complexSingletonOf :: (Class.Floating a) => a -> ComplexSingleton a +complexSingletonOf = const complexSingleton + +complexSingletonOfFunctor :: (Class.Floating a) => f a -> ComplexSingleton a +complexSingletonOfFunctor = const complexSingleton + +withComplexSingleton :: (Class.Floating a) => (ComplexSingleton a -> a) -> a +withComplexSingleton f = f complexSingleton + + +data PrecisionSingleton a where + Float :: PrecisionSingleton Float + Double :: PrecisionSingleton Double + +precisionSingleton :: (Class.Real a) => PrecisionSingleton a +precisionSingleton = Class.switchReal Float Double + +precisionOf :: (Class.Real a) => a -> PrecisionSingleton a +precisionOf _ = precisionSingleton + +precisionOfFunctor :: (Class.Real a) => f a -> PrecisionSingleton a +precisionOfFunctor _ = precisionSingleton + + -- move to netlib-carray:Utility or netlib-ffi:Class zero, one, minusOne :: Class.Floating a => a zero = selectFloating 0 0 0 0 @@ -47,109 +86,72 @@ minusOne = selectFloating (-1) (-1) (-1) (-1) selectReal :: (Class.Real a) => Float -> Double -> a -selectReal rf rd = - runIdentity $ Class.switchReal (Identity rf) (Identity rd) +selectReal rf rd = runIdentity $ Class.switchReal (Identity rf) (Identity rd) selectFloating :: (Class.Floating a) => - Float -> Double -> Complex Float -> Complex Double -> a + Float -> Double -> Complex.Complex Float -> Complex.Complex Double -> a selectFloating rf rd cf cd = - runIdentity $ - Class.switchFloating - (Identity rf) (Identity rd) (Identity cf) (Identity cd) + withComplexSingleton $ \sw -> + case sw of + Real -> selectReal rf rd + Complex -> Class.switchReal cf cd -newtype Equal a = Equal {getEqual :: a -> a -> Bool} - equal :: (Class.Floating a) => a -> a -> Bool -equal = - getEqual $ - Class.switchFloating (Equal (==)) (Equal (==)) (Equal (==)) (Equal (==)) +equal a b = + case complexSingletonOf a of + Real -> a==b + Complex -> a==b -isZero :: Class.Floating a => a -> Bool -isZero = - getFlip $ - Class.switchFloating - (Flip (0==)) (Flip (0==)) - (Flip (0==)) (Flip (0==)) +isZero :: (Class.Floating a) => a -> Bool +isZero = equal zero -newtype FromReal a = FromReal {getFromReal :: RealOf a -> a} - fromReal :: (Class.Floating a) => RealOf a -> a -fromReal = - getFromReal $ - Class.switchFloating - (FromReal id) - (FromReal id) - (FromReal (:+0)) - (FromReal (:+0)) - -newtype ToComplex f a = ToComplex {getToComplex :: a -> ComplexOf a} +fromReal a = + withComplexSingleton $ \sw -> + case sw of + Real -> a + Complex -> a:+0 toComplex :: (Class.Floating a) => a -> ComplexOf a -toComplex = - getToComplex $ - Class.switchFloating - (ToComplex (:+0)) - (ToComplex (:+0)) - (ToComplex id) - (ToComplex id) - -newtype ToReal a = ToReal {getToReal :: a -> RealOf a} +toComplex a = + case complexSingletonOf a of + Real -> a:+0 + Complex -> a realPart :: (Class.Floating a) => a -> RealOf a -realPart = - getToReal $ - Class.switchFloating - (ToReal id) - (ToReal id) - (ToReal Complex.realPart) - (ToReal Complex.realPart) +realPart a = + case complexSingletonOf a of + Real -> a + Complex -> Complex.realPart a absolute :: (Class.Floating a) => a -> RealOf a -absolute = - getToReal $ - Class.switchFloating - (ToReal abs) - (ToReal abs) - (ToReal Complex.magnitude) - (ToReal Complex.magnitude) +absolute a = + case complexSingletonOf a of + Real -> abs a + Complex -> Complex.magnitude a norm1 :: (Class.Floating a) => a -> RealOf a -norm1 = - getToReal $ - Class.switchFloating - (ToReal abs) - (ToReal abs) - (ToReal norm1Complex) - (ToReal norm1Complex) - -norm1Complex :: (Class.Real a) => Complex a -> a -norm1Complex (r:+i) = abs r + abs i +norm1 a = + case complexSingletonOf a of + Real -> abs a + Complex -> case a of r:+i -> abs r + abs i absoluteSquared :: (Class.Floating a) => a -> RealOf a -absoluteSquared = - getToReal $ - Class.switchFloating - (ToReal absoluteSquaredReal) - (ToReal absoluteSquaredReal) - (ToReal absoluteSquaredComplex) - (ToReal absoluteSquaredComplex) - -absoluteSquaredReal :: (Class.Real a) => a -> a -absoluteSquaredReal a = a*a - -absoluteSquaredComplex :: (Class.Real a) => Complex a -> a -absoluteSquaredComplex (r:+i) = r*r+i*i +absoluteSquared a = + case complexSingletonOf a of + Real -> a*a + Complex -> case a of r:+i -> r*r+i*i conjugate :: (Class.Floating a) => a -> a -conjugate = - appEndo $ - Class.switchFloating - (Endo id) (Endo id) (Endo Complex.conjugate) (Endo Complex.conjugate) +conjugate a = + case complexSingletonOf a of + Real -> a + Complex -> Complex.conjugate a diff --git a/src/Numeric/LAPACK/Shape.hs b/src/Numeric/LAPACK/Shape.hs --- a/src/Numeric/LAPACK/Shape.hs +++ b/src/Numeric/LAPACK/Shape.hs @@ -2,39 +2,86 @@ module Numeric.LAPACK.Shape where import qualified Data.Array.Comfort.Shape as Shape +import Data.Tagged (Tagged) +import Data.Ix (Ix) +import Control.DeepSeq (NFData, rnf) + {- | -Uses the indices of the second shape, -but the list of indices is restricted by the size of the first shape. +Class of shapes where indices still make sense if we permute elements. +We use this for all matrix factorisations +involving permutations or more generally orthogonal transformations, +e.g. eigenvalue and singular value, LU and QR decompositions. +E.g. say, we have a square matrix with dimension 'Shape.Enumeration Ordering'. +Its vector of eigenvalues has the same dimension, +but it does not make sense to access the eigenvalues +with indices like 'LT' or 'EQ'. +Thus 'Shape.Enumeration' is no instance of 'Permutable' +(and you should not add an orphan instance). + +If you want to factor a matrix with a non-permutable shape, +you should convert it temporarily to a permutable one, +like 'Shape.ZeroBased' (i.e. 'Matrix.ShapeInt') or 'IntIndexed'. + +The 'Permutable' class has no method, so you could add any shape to it. +However, you should use good taste when adding an instance. +There is no strict criterion which shape type to add. + +We tried to use 'ShapeInt' for eigenvalue vectors +and 'LiberalSquare's as transformation matrices of eigenvalue decompositions. +However, this way, the type checker cannot infer +that the product of the factorisation is a strict square. + +We also tried to use 'Shape.IntIndexed' for eigenvalue vectors +with according 'LiberalSquare's transformations. +This has also the problem of inferring squares. +Additionally, +more such transformations lead to nested 'Shape.IntIndexed' wrappers +and for 'Matrix.ShapeInt' even the first wrapper is unnecessary. -} -data Min sh0 sh1 = Min {minShape0 :: sh0, minShape1 :: sh1} +class (Shape.C shape) => Permutable shape where +instance Permutable Shape.Zero where +instance Permutable () where +instance (Ix n) => Permutable (Shape.Range n) where +instance (Integral n) => Permutable (Shape.Shifted n) where +instance (Integral n) => Permutable (Shape.ZeroBased n) where +instance (Integral n) => Permutable (Shape.OneBased n) where +instance (Integral n) => Permutable (Shape.Cyclic n) where +instance (Permutable sh) => Permutable (Shape.Deferred sh) where +instance (Permutable sh) => Permutable (Tagged s sh) where + + +{- | +This shape type wraps any other array shape type. +However, its 'Shape.Indexed' instance just uses zero-based 'Int' indices. +Thus it can turn any shape type into a 'Shape.Indexed' one. +The main usage is to make an arbitrary shape 'Permutable'. +-} +newtype IntIndexed sh = IntIndexed {deconsIntIndexed :: sh} deriving (Eq, Show) -instance (Shape.C sh0, Shape.C sh1) => Shape.C (Min sh0 sh1) where - size (Min sh0 sh1) = min (Shape.size sh0) (Shape.size sh1) - uncheckedSize (Min sh0 sh1) = - min (Shape.uncheckedSize sh0) (Shape.uncheckedSize sh1) -instance (Shape.C sh0, Shape.Indexed sh1) => Shape.Indexed (Min sh0 sh1) where - type Index (Min sh0 sh1) = Shape.Index sh1 - indices (Min sh0 sh1) = take (Shape.size sh0) $ Shape.indices sh1 - offset (Min sh0 sh1) ix = - let k = Shape.uncheckedOffset sh1 ix - in if k NFData (IntIndexed sh) where + rnf (IntIndexed sh) = rnf sh -instance - (Shape.C sh0, Shape.InvIndexed sh1) => - Shape.InvIndexed (Min sh0 sh1) where - indexFromOffset (Min sh0 sh1) k = - if k Shape.C (IntIndexed sh) where + size (IntIndexed sh) = Shape.size sh + +shapeInt :: (Shape.C sh) => sh -> Shape.ZeroBased Int +shapeInt = Shape.ZeroBased . Shape.size + +instance (Shape.C sh) => Shape.Indexed (IntIndexed sh) where + type Index (IntIndexed sh) = Int + indices (IntIndexed sh) = take (Shape.size sh) [0 ..] + unifiedOffset (IntIndexed sh) = Shape.unifiedOffset (shapeInt sh) + unifiedSizeOffset (IntIndexed sh) = + Shape.unifiedSizeOffset (shapeInt sh) + inBounds (IntIndexed sh) k = + Shape.inBounds (Shape.ZeroBased $ Shape.size sh) k + +instance (Shape.C sh) => Shape.InvIndexed (IntIndexed sh) where + unifiedIndexFromOffset (IntIndexed sh) = + Shape.unifiedIndexFromOffset (shapeInt sh) + +instance (Shape.C sh) => Permutable (IntIndexed sh) where diff --git a/src/Numeric/LAPACK/Shape/Private.hs b/src/Numeric/LAPACK/Shape/Private.hs --- a/src/Numeric/LAPACK/Shape/Private.hs +++ b/src/Numeric/LAPACK/Shape/Private.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Shape.Private where +import qualified Numeric.LAPACK.Shape as ExtShape + import qualified Data.Array.Comfort.Shape as Shape @@ -12,4 +14,5 @@ instance (Shape.C sh) => Shape.C (Unchecked sh) where size (Unchecked sh) = Shape.size sh - uncheckedSize (Unchecked sh) = Shape.uncheckedSize sh + +instance (ExtShape.Permutable sh) => ExtShape.Permutable (Unchecked sh) where diff --git a/src/Numeric/LAPACK/ShapeStatic.hs b/src/Numeric/LAPACK/ShapeStatic.hs deleted file mode 100644 --- a/src/Numeric/LAPACK/ShapeStatic.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -module Numeric.LAPACK.ShapeStatic where - -import Numeric.LAPACK.Matrix.Shape.Private (UnaryProxy) - -import qualified Data.FixedLength as FL - -import qualified Data.Array.Comfort.Storable as Array -import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable (Array) - -import qualified Type.Data.Num.Unary as Unary -import Type.Data.Num (integralFromProxy) -import Type.Base.Proxy (Proxy(Proxy)) - -import Foreign.Storable (Storable) - -import Text.Printf (printf) - - -{- | -'ZeroBased' denotes a range starting at zero and has a certain length. --} -newtype ZeroBased n = ZeroBased {zeroBasedSize :: UnaryProxy n} - deriving (Eq, Show) - -instance (Unary.Natural n) => Shape.C (ZeroBased n) where - size = Shape.uncheckedSize - uncheckedSize (ZeroBased len) = integralFromProxy len - -instance (Unary.Natural n) => Shape.Indexed (ZeroBased n) where - type Index (ZeroBased n) = FL.Index n - indices _len = FL.toList FL.indices - offset = Shape.uncheckedOffset - uncheckedOffset _len = fromIntegral . FL.numFromIndex - inBounds _len _ix = True - -instance (Unary.Natural n) => Shape.InvIndexed (ZeroBased n) where - -- could be implemented using new fixed-length-0.2.1:FL.indexFromNum - indexFromOffset len k = - case (0<=k, drop k $ Shape.indices len) of - (True, i:_) -> i - _ -> -- cf. comfort-array:Shape.errorIndexFromOffset - error $ - printf "indexFromOffset (ShapeStatic.ZeroBased): index %d out of range" k - -instance (Unary.Natural n) => Shape.Static (ZeroBased n) where - static = ZeroBased Proxy - - -vector :: (Unary.Natural n, Storable a) => FL.T n a -> Array (ZeroBased n) a -vector = Array.fromList (ZeroBased Proxy) . FL.toList diff --git a/src/Numeric/LAPACK/Singular.hs b/src/Numeric/LAPACK/Singular.hs --- a/src/Numeric/LAPACK/Singular.hs +++ b/src/Numeric/LAPACK/Singular.hs @@ -15,13 +15,15 @@ import qualified Numeric.LAPACK.Singular.Plain as Plain -import qualified Numeric.LAPACK.Matrix.Hermitian.Basic as HermitianBasic import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Basic as Basic import qualified Numeric.LAPACK.Matrix as Matrix -import qualified Numeric.LAPACK.Shape as ExtShape +import Numeric.LAPACK.Matrix.Array.Banded (RectangularDiagonal) import Numeric.LAPACK.Matrix.Array (ArrayMatrix, Full, General, Square) import Numeric.LAPACK.Matrix.Multiply ((##*#), (#*##)) import Numeric.LAPACK.Vector (Vector) @@ -30,24 +32,29 @@ import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable (Array) -import Data.Tuple.HT (mapFst, mapSnd, mapPair, mapTriple) +import Data.Tuple.HT (mapFst, mapSnd, mapPair, mapSnd3, mapTriple) +type RealVector sh a = Vector sh (RealOf a) + values :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector (ExtShape.Min height width) (RealOf a) -values = Plain.values . ArrMatrix.toVector + Full meas vert horiz height width a -> + RectangularDiagonal meas vert horiz height width (RealOf a) +values = ArrMatrix.lift1 Plain.values valuesTall :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> Vector width (RealOf a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert Extent.Small height width a -> RealVector width a valuesTall = Plain.valuesTall . ArrMatrix.toVector valuesWide :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> Vector height (RealOf a) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> RealVector height a valuesWide = Plain.valuesWide . ArrMatrix.toVector @@ -58,22 +65,24 @@ decompose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> + Full meas vert horiz height width a -> (Square height a, - Vector (ExtShape.Min height width) (RealOf a), + RectangularDiagonal meas vert horiz height width (RealOf a), Square width a) -decompose = liftDecompose Plain.decompose +decompose = mapSnd3 ArrMatrix.lift0 . liftDecompose Plain.decompose {- | > let (u,s,vt) = Singular.decomposeWide a > in a == u #*## Matrix.scaleRowsReal s vt -} decomposeWide :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> - (Square height a, Vector height (RealOf a), - Full Extent.Small horiz height width a) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> + (Square height a, RealVector height a, + Full meas Extent.Small horiz height width a) decomposeWide = liftDecompose Plain.decomposeWide {- | @@ -81,38 +90,53 @@ > in a == u ##*# Matrix.scaleRowsReal s vt -} decomposeTall :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> - (Full vert Extent.Small height width a, - Vector width (RealOf a), Square width a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert Extent.Small height width a -> + (Full meas vert Extent.Small height width a, + RealVector width a, Square width a) decomposeTall = liftDecompose Plain.decomposeTall + +type FullArray meas vert horiz height width = + ArrMatrix.PlainArray Layout.Unpacked Omni.Arbitrary + Layout.Filled Layout.Filled + meas vert horiz height width +type FullMatrix meas vert horiz height width = + ArrayMatrix Layout.Unpacked Omni.Arbitrary + Layout.Filled Layout.Filled + meas vert horiz height width + liftDecompose :: - (Array sha a -> (Array shb b, f, Array shc c)) -> - ArrayMatrix sha a -> (ArrayMatrix shb b, f, ArrayMatrix shc c) + (FullArray measA vertA horizA heightA widthA a -> + (FullArray measB vertB horizB heightB widthB b, f, + FullArray measC vertC horizC heightC widthC c)) -> + FullMatrix measA vertA horizA heightA widthA a -> + (FullMatrix measB vertB horizB heightB widthB b, f, + FullMatrix measC vertC horizC heightC widthC c) liftDecompose f = mapTriple (ArrMatrix.lift0, id, ArrMatrix.lift0) . f . ArrMatrix.toVector leastSquaresMinimumNormRCond :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => RealOf a -> - Full horiz vert height width a -> - Full vert horiz height nrhs a -> - (Int, Full vert horiz width nrhs a) + Full meas horiz vert height width a -> + Full meas vert horiz height nrhs a -> + (Int, Full meas vert horiz width nrhs a) leastSquaresMinimumNormRCond rcond a b = mapSnd ArrMatrix.lift0 $ Plain.leastSquaresMinimumNormRCond rcond (ArrMatrix.toVector a) (ArrMatrix.toVector b) pseudoInverseRCond :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => RealOf a -> - Full vert horiz height width a -> - (Int, Full horiz vert width height a) + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) pseudoInverseRCond rcond = mapSnd (ArrMatrix.lift0 . Basic.recheck) . Plain.pseudoInverseRCond rcond . @@ -120,20 +144,27 @@ +{- | +In @decomposePolar a = (u,h)@, +@u@ is the orthogonal matrix closest to @a@ +with respect to the 2- and the Frobenius norm. +(Higham: Functions of Matrices - Theory and Computation.) +-} decomposePolar :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => - Full vert horiz height width a -> - (Full vert horiz height width a, Matrix.Hermitian width a) + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert horiz height width a -> + (Full meas vert horiz height width a, Matrix.Hermitian width a) decomposePolar = mapPair (ArrMatrix.lift1 Basic.recheck, - ArrMatrix.lift1 HermitianBasic.recheck) + ArrMatrix.lift1 Mos.recheck) . getDecomposePolar - (Extent.switchTagPair + (Extent.switchTagTriple (DecomposePolar decomposePolarWide) (DecomposePolar decomposePolarWide) + (DecomposePolar decomposePolarWide) (DecomposePolar decomposePolarTall) (DecomposePolar $ either @@ -144,27 +175,27 @@ . ArrMatrix.lift1 Basic.uncheck -newtype DecomposePolar height width a vert horiz = +newtype DecomposePolar height width a meas vert horiz = DecomposePolar { getDecomposePolar :: - Full vert horiz height width a -> - (Full vert horiz height width a, Matrix.Hermitian width a) + Full meas vert horiz height width a -> + (Full meas vert horiz height width a, Matrix.Hermitian width a) } decomposePolarTall :: - (Extent.C vert, Shape.C height, Shape.C width, Eq width, - Class.Floating a) => - Full vert Extent.Small height width a -> - (Full vert Extent.Small height width a, Matrix.Hermitian width a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Eq width, Class.Floating a) => + Full meas vert Extent.Small height width a -> + (Full meas vert Extent.Small height width a, Matrix.Hermitian width a) decomposePolarTall a = let (u,s,vt) = decomposeTall a in (u ##*# vt, Hermitian.congruenceDiagonal s $ Matrix.fromFull vt) decomposePolarWide :: - (Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, - Class.Floating a) => - Full Extent.Small horiz height width a -> - (Full Extent.Small horiz height width a, Matrix.Hermitian width a) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> + (Full meas Extent.Small horiz height width a, Matrix.Hermitian width a) decomposePolarWide a = let (u,s,vt) = decomposeWide a in (u #*## vt, Hermitian.congruenceDiagonal s $ Matrix.fromFull vt) diff --git a/src/Numeric/LAPACK/Singular/Plain.hs b/src/Numeric/LAPACK/Singular/Plain.hs --- a/src/Numeric/LAPACK/Singular/Plain.hs +++ b/src/Numeric/LAPACK/Singular/Plain.hs @@ -12,19 +12,18 @@ RealOf, ) where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout import qualified Numeric.LAPACK.Matrix.Square.Basic as Square import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Matrix.Basic as Basic import qualified Numeric.LAPACK.Vector as Vector -import qualified Numeric.LAPACK.Shape as ExtShape import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Matrix.Hermitian.Private (TakeDiagonal(..), Determinant(..)) import Numeric.LAPACK.Matrix.Extent.Private (Extent) import Numeric.LAPACK.Matrix.Square.Basic (Square) -import Numeric.LAPACK.Matrix.Shape.Private (Order(ColumnMajor), swapOnRowMajor) +import Numeric.LAPACK.Matrix.Layout.Private (Order(ColumnMajor), swapOnRowMajor) import Numeric.LAPACK.Matrix.Private (Full, General) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, zero) @@ -59,26 +58,35 @@ import Data.Bool.HT (if') +type RealVector sh a = Vector sh (RealOf a) +type RectangularRealDiagonal meas vert horiz height width a = + RealVector (Layout.RectangularDiagonal meas vert horiz height width) a + values :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> Vector (ExtShape.Min height width) (RealOf a) -values = valuesGen $ uncurry ExtShape.Min . Extent.dimensions + Full meas vert horiz height width a -> + RectangularRealDiagonal meas vert horiz height width a +values = valuesGen $ snd . Layout.rectangularDiagonal valuesTall :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> Vector width (RealOf a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert Extent.Small height width a -> RealVector width a valuesTall = valuesGen Extent.width valuesWide :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> Vector height (RealOf a) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> RealVector height a valuesWide = valuesTall . Basic.transpose valuesGen :: - (Extent.C vert, Extent.C horiz, Shape.C width, Shape.C height, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C shape, Class.Floating a) => - (Extent vert horiz height width -> shape) -> - Full vert horiz height width a -> Vector shape (RealOf a) + (Extent meas vert horiz height width -> shape) -> + Full meas vert horiz height width a -> RealVector shape a valuesGen resultShape = runTakeDiagonal $ Class.switchFloating @@ -88,13 +96,14 @@ (TakeDiagonal $ valuesAux resultShape) valuesAux :: - (Extent.C vert, Extent.C horiz, Shape.C width, Shape.C height, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Shape.C shape, Class.Floating a, RealOf a ~ ar, Storable ar) => - (Extent vert horiz height width -> shape) -> - Full vert horiz height width a -> Vector shape ar -valuesAux resultShape (Array shape@(MatrixShape.Full _order extent) a) = + (Extent meas vert horiz height width -> shape) -> + Full meas vert horiz height width a -> Vector shape ar +valuesAux resultShape (Array shape@(Layout.Full _order extent) a) = Array.unsafeCreateWithSize (resultShape extent) $ \mn sPtr -> do - let (m,n) = MatrixShape.dimensions shape + let (m,n) = Layout.dimensions shape let lda = m evalContT $ do jobuPtr <- Call.char 'N' @@ -135,10 +144,11 @@ decompose :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C height, Shape.C width, Class.Floating a) => - General height width a -> + Full meas vert horiz height width a -> (Square height a, - Vector (ExtShape.Min height width) (RealOf a), + RectangularRealDiagonal meas vert horiz height width a, Square width a) decompose = getDecompose $ @@ -152,28 +162,30 @@ Decompose {getDecompose :: m a -> (f a, v (RealOf a), g a)} decomposeAux :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => (Shape.C height, Shape.C width, Class.Floating a, RealOf a ~ ar, Storable ar) => - General height width a -> - (Square height a, Vector (ExtShape.Min height width) ar, Square width a) -decomposeAux arr@(Array shape@(MatrixShape.Full order extent) a) = + Full meas vert horiz height width a -> + (Square height a, + RectangularRealDiagonal meas vert horiz height width a, + Square width a) +decomposeAux arr@(Array shape@(Layout.Full order extent) a) = let (height,width) = Extent.dimensions extent - minShape = ExtShape.Min height width - mn = Shape.size minShape + (mn,minShape) = Layout.rectangularDiagonal extent in (if' (mn==0) - (Square.identityFromHeight arr, + (Square.identityFromHeight $ Matrix.fromFull arr, Vector.fromList minShape [], - Square.identityFromWidth arr)) $ + Square.identityFromWidth $ Matrix.fromFull arr)) $ (\(u,(s,vt)) -> (u,s,vt)) $ - Array.unsafeCreateWithSizeAndResult (MatrixShape.square order height) $ + Array.unsafeCreateWithSizeAndResult (Layout.square order height) $ \ _ uPtr0 -> ArrayIO.unsafeCreateWithSizeAndResult minShape $ \ _ sPtr -> - ArrayIO.unsafeCreate (MatrixShape.square order width) $ \vtPtr0 -> + ArrayIO.unsafeCreate (Layout.square order width) $ \vtPtr0 -> evalContT $ do - let (m,n) = MatrixShape.dimensions shape + let (m,n) = Layout.dimensions shape let (uPtr,vtPtr) = swapOnRowMajor order (uPtr0,vtPtr0) let lda = m jobuPtr <- Call.char 'A' @@ -191,19 +203,21 @@ decomposeWide :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Full Extent.Small horiz height width a -> - (Square height a, Vector height (RealOf a), - Full Extent.Small horiz height width a) + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas Extent.Small horiz height width a -> + (Square height a, RealVector height a, + Full meas Extent.Small horiz height width a) decomposeWide a = let (u,s,vt) = decomposeTall $ Basic.transpose a in (Square.transpose vt, s, Basic.transpose u) decomposeTall :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Full vert Extent.Small height width a -> - (Full vert Extent.Small height width a, - Vector width (RealOf a), Square width a) + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Full meas vert Extent.Small height width a -> + (Full meas vert Extent.Small height width a, + RealVector width a, Square width a) decomposeTall = getDecompose $ Class.switchFloating @@ -213,17 +227,17 @@ (Decompose decomposeThin) decomposeThin :: - (Extent.C vert, Shape.C height, Shape.C width, + (Extent.Measure meas, Extent.C vert, Shape.C height, Shape.C width, Class.Floating a, RealOf a ~ ar, Storable ar) => - Full vert Extent.Small height width a -> - (Full vert Extent.Small height width a, Vector width ar, Square width a) -decomposeThin (Array (MatrixShape.Full order extent) a) = + Full meas vert Extent.Small height width a -> + (Full meas vert Extent.Small height width a, Vector width ar, Square width a) +decomposeThin (Array (Layout.Full order extent) a) = let (height,width) = Extent.dimensions extent in (\(u,(s,vt)) -> (u,s,vt)) $ - Array.unsafeCreateWithSizeAndResult (MatrixShape.Full order extent) $ + Array.unsafeCreateWithSizeAndResult (Layout.Full order extent) $ \ _ uPtr0 -> ArrayIO.unsafeCreateWithSizeAndResult width $ \ _ sPtr -> - ArrayIO.unsafeCreate (MatrixShape.square order width) $ \vtPtr0 -> + ArrayIO.unsafeCreate (Layout.square order width) $ \vtPtr0 -> evalContT $ do let ((m,uPtr),(n,vtPtr)) = @@ -280,21 +294,21 @@ leastSquaresMinimumNormRCond :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => RealOf a -> - Full horiz vert height width a -> - Full vert horiz height nrhs a -> - (Int, Full vert horiz width nrhs a) + Full meas horiz vert height width a -> + Full meas vert horiz height nrhs a -> + (Int, Full meas vert horiz width nrhs a) leastSquaresMinimumNormRCond rcond - (Array (MatrixShape.Full orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Full orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = case Extent.fuse (Extent.transpose extentA) extentB of Nothing -> error "leastSquaresMinimumNorm: height shapes mismatch" Just extent -> let widthA = Extent.width extentA (height,widthB) = Extent.dimensions extentB - shapeX = MatrixShape.Full ColumnMajor extent + shapeX = Layout.Full ColumnMajor extent m = Shape.size height n = Shape.size widthA nrhs = Shape.size widthB @@ -307,7 +321,7 @@ case Vector.zero height of Array _ b1 -> leastSquaresMinimumNormIO rcond - (MatrixShape.general ColumnMajor widthA ()) + (Layout.general ColumnMajor widthA ()) orderA a orderB b1 m n 1, Vector.zero shapeX) else @@ -384,11 +398,11 @@ pseudoInverseRCond :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => RealOf a -> - Full vert horiz height width a -> - (Int, Full horiz vert width height a) + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) pseudoInverseRCond = getPseudoInverseRCond $ Class.switchFloating @@ -403,17 +417,18 @@ } pseudoInverseRCondAux :: - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a, RealOf a ~ ar, Class.Real ar) => ar -> - Full vert horiz height width a -> - (Int, Full horiz vert width height a) + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) pseudoInverseRCondAux rcond = getPseudoInverseExtent $ - Extent.switchTagPair + Extent.switchTagTriple (PseudoInverseExtent $ pseudoInverseRCondWide rcond) (PseudoInverseExtent $ pseudoInverseRCondWide rcond) + (PseudoInverseExtent $ pseudoInverseRCondWide rcond) (PseudoInverseExtent $ pseudoInverseRCondTall rcond) (PseudoInverseExtent $ either @@ -422,19 +437,20 @@ . Basic.caseTallWide) -newtype PseudoInverseExtent height width a vert horiz = +newtype PseudoInverseExtent height width a meas vert horiz = PseudoInverseExtent { getPseudoInverseExtent :: - Full vert horiz height width a -> - (Int, Full horiz vert width height a) + Full meas vert horiz height width a -> + (Int, Full meas horiz vert width height a) } pseudoInverseRCondWide :: - (Extent.C horiz, Shape.C height, Eq height, Shape.C width, Eq width, + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a, RealOf a ~ ar, Class.Real ar) => RealOf a -> - Full Extent.Small horiz height width a -> - (Int, Full horiz Extent.Small width height a) + Full meas Extent.Small horiz height width a -> + (Int, Full meas horiz Extent.Small width height a) pseudoInverseRCondWide rcond a = let (u,s,vt) = decomposeWide a (rank,recipS) = recipSigma rcond s @@ -443,11 +459,12 @@ Basic.scaleRowsReal recipS $ Square.toFull $ Square.adjoint u) pseudoInverseRCondTall :: - (Extent.C vert, Shape.C height, Eq height, Shape.C width, Eq width, + (Extent.Measure meas, Extent.C vert, + Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a, RealOf a ~ ar, Class.Real ar) => RealOf a -> - Full vert Extent.Small height width a -> - (Int, Full Extent.Small vert width height a) + Full meas vert Extent.Small height width a -> + (Int, Full meas Extent.Small vert width height a) pseudoInverseRCondTall rcond a = let (u,s,vt) = decomposeTall a (rank,recipS) = recipSigma rcond s diff --git a/src/Numeric/LAPACK/Split.hs b/src/Numeric/LAPACK/Split.hs --- a/src/Numeric/LAPACK/Split.hs +++ b/src/Numeric/LAPACK/Split.hs @@ -1,25 +1,26 @@ {-# LANGUAGE TypeFamilies #-} module Numeric.LAPACK.Split where -import qualified Numeric.LAPACK.Matrix.Shape.Private as MatrixShape -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box -import qualified Numeric.LAPACK.Matrix.Triangular.Private as TriPriv +import qualified Numeric.LAPACK.Matrix.Layout.Private as Layout +import qualified Numeric.LAPACK.Matrix.Mosaic.Private as Mos import qualified Numeric.LAPACK.Matrix.Triangular.Basic as Tri import qualified Numeric.LAPACK.Matrix.Private as Matrix import qualified Numeric.LAPACK.Matrix.Extent.Private as Extent import qualified Numeric.LAPACK.Private as Private -import Numeric.LAPACK.Matrix.Triangular.Private (diagonalPointers, unpack) -import Numeric.LAPACK.Matrix.Triangular.Basic (UnitLower, Upper) -import Numeric.LAPACK.Matrix.Shape.Private +import Numeric.LAPACK.Matrix.Mosaic.Private (diagonalPointers) +import Numeric.LAPACK.Matrix.Triangular.Basic (Lower, Upper) +import Numeric.LAPACK.Matrix.Layout.Private (Order(RowMajor, ColumnMajor), transposeFromOrder, swapOnRowMajor, sideSwapFromOrder, Triangle, uploFromOrder, flipOrder) +import Numeric.LAPACK.Matrix.Extent.Private (Extent) import Numeric.LAPACK.Matrix.Modifier (Transposition, transposeOrder, Conjugation(NonConjugated, Conjugated)) import Numeric.LAPACK.Matrix.Private (Full) import Numeric.LAPACK.Linear.Private (solver, withInfo) import Numeric.LAPACK.Scalar (zero, one) +import Numeric.LAPACK.Shape.Private (Unchecked(Unchecked)) import Numeric.LAPACK.Private (copyBlock, conjugateToTemp) import qualified Numeric.LAPACK.FFI.Generic as LapackGen @@ -42,16 +43,83 @@ import Control.Monad.IO.Class (liftIO) -type Split lower vert horiz height width = - Array (MatrixShape.Split lower vert horiz height width) +type Split lower meas vert horiz height width = + Array (Layout.Split lower meas vert horiz height width) -type Square lower sh = Split lower Extent.Small Extent.Small sh sh +type Square lower sh = Split lower Extent.Shape Extent.Small Extent.Small sh sh +mapExtent :: + (Extent.Measure measA, Extent.C vertA, Extent.C horizA) => + (Extent.Measure measB, Extent.C vertB, Extent.C horizB) => + Extent.Map measA vertA horizA measB vertB horizB height width -> + Split lower measA vertA horizA height width a -> + Split lower measB vertB horizB height width a +mapExtent = Array.mapShape . Layout.splitMapExtent + +mapExtentSizes :: + (Extent measA vertA horizA heightA widthA -> + Extent measB vertB horizB heightB widthB) -> + Split lower measA vertA horizA heightA widthA a -> + Split lower measB vertB horizB heightB widthB a +mapExtentSizes f = + Array.mapShape + (\(Layout.Split lowerPart order extent) -> + Layout.Split lowerPart order $ f extent) + +mapHeight :: + (Extent.C vert, Extent.C horiz) => + (heightA -> heightB) -> + Split lower Extent.Size vert horiz heightA width a -> + Split lower Extent.Size vert horiz heightB width a +mapHeight = mapExtentSizes . Extent.mapHeight + +mapWidth :: + (Extent.C vert, Extent.C horiz) => + (widthA -> widthB) -> + Split lower Extent.Size vert horiz height widthA a -> + Split lower Extent.Size vert horiz height widthB a +mapWidth = mapExtentSizes . Extent.mapWidth + +uncheck :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Split lower meas vert horiz height width a -> + Split lower meas vert horiz (Unchecked height) (Unchecked width) a +uncheck = mapExtentSizes $ Extent.mapWrap Unchecked Unchecked + +recheck :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + Split lower meas vert horiz (Unchecked height) (Unchecked width) a -> + Split lower meas vert horiz height width a +recheck = mapExtentSizes Extent.recheck + + +heightToQuadratic :: + (Extent.Measure meas) => + Split lower meas Extent.Small Extent.Small height width a -> + Square lower height a +heightToQuadratic = + Array.mapShape $ + \(Layout.Split part order_ extent_) -> + Layout.Split part order_ $ + Extent.square $ Extent.height extent_ + +widthToQuadratic :: + (Extent.Measure meas) => + Split lower meas Extent.Small Extent.Small height width a -> + Square lower width a +widthToQuadratic = + Array.mapShape $ + \(Layout.Split part order_ extent_) -> + Layout.Split part order_ $ + Extent.square $ Extent.width extent_ + + determinantR :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Split lower vert Extent.Small height width a -> a -determinantR (Array (MatrixShape.Split _ order extent) a) = + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Split lower meas vert Extent.Small height width a -> a +determinantR (Array (Layout.Split _ order extent) a) = let (height,width) = Extent.dimensions extent m = Shape.size height n = Shape.size width @@ -62,14 +130,14 @@ extractTriangle :: - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, - Class.Floating a) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => Either lower Triangle -> - Split lower vert horiz height width a -> - Full vert horiz height width a -extractTriangle part (Array (MatrixShape.Split _ order extent) qr) = + Split lower meas vert horiz height width a -> + Full meas vert horiz height width a +extractTriangle part (Array (Layout.Split _ order extent) qr) = - Array.unsafeCreate (MatrixShape.Full order extent) $ \rPtr -> do + Array.unsafeCreate (Layout.Full order extent) $ \rPtr -> do let (height,width) = Extent.dimensions extent let ((loup,m), (uplo,n)) = @@ -96,65 +164,72 @@ wideExtractL :: - (Extent.C horiz, Shape.C height, Shape.C width, Class.Floating a) => - Split lower Extent.Small horiz height width a -> UnitLower height a + (Extent.Measure meas, Extent.C horiz, + Shape.C height, Shape.C width, Class.Floating a) => + Split lower meas Extent.Small horiz height width a -> Lower height a wideExtractL = - TriPriv.takeLower - (MatrixShape.Unit, - \order m lPtr -> mapM_ (flip poke one) $ diagonalPointers order m lPtr) + Mos.fromLowerPart + (\order m lPtr -> mapM_ (flip poke one) $ diagonalPointers order m lPtr) + Layout.NoMirror . toFull tallExtractR :: - (Extent.C vert, Shape.C height, Shape.C width, Class.Floating a) => - Split lower vert Extent.Small height width a -> Upper width a + (Extent.Measure meas, Extent.C vert, + Shape.C height, Shape.C width, Class.Floating a) => + Split lower meas vert Extent.Small height width a -> Upper width a tallExtractR = Tri.takeUpper . toFull toFull :: - Split lower vert horiz height width a -> - Full vert horiz height width a + Split lower meas vert horiz height width a -> + Full meas vert horiz height width a toFull = Array.mapShape - (\(MatrixShape.Split _ order extent) -> MatrixShape.Full order extent) + (\(Layout.Split _ order extent) -> Layout.Full order extent) wideMultiplyL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C widthA, Shape.C widthB, Class.Floating a) => Transposition -> - Split Triangle Extent.Small horizA height widthA a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + Split Triangle measA Extent.Small horizA height widthA a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a wideMultiplyL transposed a b = - if MatrixShape.splitHeight (Array.shape a) == Matrix.height b + if Layout.splitHeight (Array.shape a) == Matrix.height b then multiplyTriangular ('L','U') 'U' transposed a b else error "wideMultiplyL: height shapes mismatch" tallMultiplyR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, Shape.C heightA, Shape.C widthB, Class.Floating a) => Transposition -> - Split lower vertA Extent.Small heightA height a -> - Full vert horiz height widthB a -> - Full vert horiz height widthB a + Split lower measA vertA Extent.Small heightA height a -> + Full meas vert horiz height widthB a -> + Full meas vert horiz height widthB a tallMultiplyR transposed a b = - if MatrixShape.splitWidth (Array.shape a) == Matrix.height b + if Layout.splitWidth (Array.shape a) == Matrix.height b then multiplyTriangular ('U','L') 'N' transposed a b else error "wideMultiplyR: height shapes mismatch" multiplyTriangular :: - (Extent.C vertA, Extent.C horizA, Extent.C vertB, Extent.C horizB, + (Extent.Measure measA, Extent.C vertA, Extent.C horizA, + Extent.Measure measB, Extent.C vertB, Extent.C horizB, Shape.C heightA, Shape.C widthA, Shape.C heightB, Shape.C widthB, Class.Floating a) => (Char,Char) -> Char -> Transposition -> - Split lower vertA horizA heightA widthA a -> - Full vertB horizB heightB widthB a -> - Full vertB horizB heightB widthB a + Split lower measA vertA horizA heightA widthA a -> + Full measB vertB horizB heightB widthB a -> + Full measB vertB horizB heightB widthB a multiplyTriangular (normalPart,transposedPart) diag transposed - (Array (MatrixShape.Split _ orderA extentA) a) - (Array (MatrixShape.Full orderB extentB) b) = + (Array (Layout.Split _ orderA extentA) a) + (Array (Layout.Full orderB extentB) b) = - Array.unsafeCreate (MatrixShape.Full orderB extentB) $ \cPtr -> do + Array.unsafeCreate (Layout.Full orderB extentB) $ \cPtr -> do let (heightA,widthA) = Extent.dimensions extentA let (heightB,widthB) = Extent.dimensions extentB @@ -186,13 +261,14 @@ wideSolveL :: - (Extent.C horizA, Extent.C vert, Extent.C horiz, + (Extent.Measure measA, Extent.C horizA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Eq height, Shape.C width, Shape.C nrhs, Class.Floating a) => Transposition -> Conjugation -> - Split Triangle Extent.Small horizA height width a -> - Full vert horiz height nrhs a -> Full vert horiz height nrhs a + Split Triangle measA Extent.Small horizA height width a -> + Full meas vert horiz height nrhs a -> Full meas vert horiz height nrhs a wideSolveL transposed conjugated - (Array (MatrixShape.Split _ orderA extentA) a) = + (Array (Layout.Split _ orderA extentA) a) = let heightA = Extent.height extentA in solver "Split.wideSolveL" heightA $ \n nPtr nrhsPtr xPtr ldxPtr -> do @@ -203,13 +279,14 @@ uploPtr diagPtr nPtr nrhsPtr xPtr ldxPtr tallSolveR :: - (Extent.C vertA, Extent.C vert, Extent.C horiz, + (Extent.Measure measA, Extent.C vertA, + Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width, Eq width, Shape.C nrhs, Class.Floating a) => Transposition -> Conjugation -> - Split lower vertA Extent.Small height width a -> - Full vert horiz width nrhs a -> Full vert horiz width nrhs a + Split lower measA vertA Extent.Small height width a -> + Full meas vert horiz width nrhs a -> Full meas vert horiz width nrhs a tallSolveR transposed conjugated - (Array (MatrixShape.Split _ orderA extentA) a) = + (Array (Layout.Split _ orderA extentA) a) = let (heightA,widthA) = Extent.dimensions extentA in solver "Split.tallSolveR" widthA $ \n nPtr nrhsPtr xPtr ldxPtr -> do @@ -240,34 +317,3 @@ withInfo "trtrs" $ LapackGen.trtrs uploPtr transPtr diagPtr nPtr nrhsPtr aPtr ldaPtr xPtr ldxPtr - - -data Corrupt = Corrupt - deriving (Eq) - -{- -We could use Plain.Class.ShapeOrder -but this would currently cause an import cycle. --} -{- | -> let b = takeHalf a -> ==> -> isTriangular b && a == addTransposed b --} -takeHalf :: - (Box.Box symShape, Box.HeightOf symShape ~ sh, Shape.C sh, - Class.Floating a) => - (symShape -> Order) -> Array symShape a -> Square Corrupt sh a -takeHalf shapeOrder (Array symShape a) = - let sh = Box.height symShape - order = shapeOrder symShape - in Array.unsafeCreate (MatrixShape.Split Corrupt order (Extent.square sh)) $ - \bPtr -> evalContT $ do - let n = Shape.size sh - aPtr <- ContT $ withForeignPtr a - nPtr <- Call.cint n - alphaPtr <- Call.number 0.5 - incxPtr <- Call.cint (n+1) - liftIO $ do - unpack order n aPtr bPtr - BlasGen.scal nPtr alphaPtr bPtr incxPtr diff --git a/src/Numeric/LAPACK/Vector.hs b/src/Numeric/LAPACK/Vector.hs --- a/src/Numeric/LAPACK/Vector.hs +++ b/src/Numeric/LAPACK/Vector.hs @@ -31,7 +31,7 @@ add, sub, (|+|), (|-|), negate, raise, mac, - mul, + mul, mulConj, divide, recip, minimum, argMinimum, maximum, argMaximum, @@ -57,6 +57,7 @@ import qualified Numeric.LAPACK.Private as Private import Numeric.LAPACK.Matrix.Hermitian.Private (Determinant(Determinant, getDeterminant)) +import Numeric.LAPACK.Matrix.Modifier (Conjugation(NonConjugated, Conjugated)) import Numeric.LAPACK.Linear.Private (withInfo) import Numeric.LAPACK.Scalar (ComplexOf, RealOf, minusOne, absolute) import Numeric.LAPACK.Private @@ -90,7 +91,7 @@ import qualified Data.Array.Comfort.Storable as CheckedArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array), append, (!)) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Data.Function (id, flip, ($), (.)) import Data.Complex (Complex) @@ -143,13 +144,13 @@ {- | Precedence and associativity (right) of (List.++). -This also matches '(Shape.:+:)'. +This also matches '(::+)'. -} infixr 5 +++ (+++) :: (Shape.C shx, Shape.C shy, Storable a) => - Vector shx a -> Vector shy a -> Vector (shx:+:shy) a + Vector shx a -> Vector shy a -> Vector (shx::+shy) a (+++) = append @@ -539,13 +540,26 @@ mul :: (Shape.C sh, Eq sh, Class.Floating a) => Vector sh a -> Vector sh a -> Vector sh a -mul (Array shA a) (Array shX x) = +mul = mulConjugation NonConjugated + +{- | +prop> \xs ys -> mulConj xs ys == mul (conjugate xs) ys +-} +mulConj :: + (Shape.C sh, Eq sh, Class.Floating a) => + Vector sh a -> Vector sh a -> Vector sh a +mulConj = mulConjugation Conjugated + +mulConjugation :: + (Shape.C sh, Eq sh, Class.Floating a) => + Conjugation -> Vector sh a -> Vector sh a -> Vector sh a +mulConjugation conj (Array shA a) (Array shX x) = Array.unsafeCreateWithSize shX $ \n yPtr -> do Call.assert "mul: shapes mismatch" (shA == shX) evalContT $ do aPtr <- ContT $ withForeignPtr a xPtr <- ContT $ withForeignPtr x - liftIO $ Private.mul n aPtr 1 xPtr 1 yPtr 1 + liftIO $ Private.mul conj n aPtr 1 xPtr 1 yPtr 1 divide :: (Shape.C sh, Eq sh, Class.Floating a) => diff --git a/test/DocTest/Numeric/LAPACK/Example/DividedDifference.hs b/test/DocTest/Numeric/LAPACK/Example/DividedDifference.hs --- a/test/DocTest/Numeric/LAPACK/Example/DividedDifference.hs +++ b/test/DocTest/Numeric/LAPACK/Example/DividedDifference.hs @@ -1,17 +1,18 @@ -- Do not edit! Automatically created with doctest-extract from src/Numeric/LAPACK/Example/DividedDifference.hs -{-# LINE 29 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} +{-# LINE 30 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} module DocTest.Numeric.LAPACK.Example.DividedDifference where import qualified Test.DocTest.Driver as DocTest -{-# LINE 30 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} +{-# LINE 31 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} import qualified Test.Utility as Util import Test.Utility (approxArray) +import qualified Numeric.LAPACK.Example.DividedDifference as DD import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Example.DividedDifference (dividedDifferencesMatrix) -import Numeric.LAPACK.Matrix (ShapeInt, (#+#)) +import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (#+#)) import Numeric.LAPACK.Vector ((|+|)) import qualified Data.Array.Comfort.Storable as Array @@ -30,18 +31,23 @@ fmap (mapPair (Vector.autoFromList, Vector.autoFromList) . unzip . take 10) $ QC.listOf $ liftM2 (,) (Util.genElement 10) (Util.genElement 10) - xs <- Util.genDistinct 10 10 $ Array.shape ys0 + xs <- Util.genDistinct [-10..10] [-10..10] $ Array.shape ys0 return (xs,(ys0,ys1)) test :: DocTest.T () test = do - DocTest.printPrefix "Numeric.LAPACK.Example.DividedDifference:77: " -{-# LINE 77 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} + DocTest.printPrefix "Numeric.LAPACK.Example.DividedDifference:85: " +{-# LINE 85 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} DocTest.property -{-# LINE 77 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} +{-# LINE 85 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} (QC.forAll genDD $ \(xs, (ys0,ys1)) -> approxArray (dividedDifferencesMatrix xs (ys0|+|ys1)) (dividedDifferencesMatrix xs ys0 #+# dividedDifferencesMatrix xs ys1)) - DocTest.printPrefix "Numeric.LAPACK.Example.DividedDifference:78: " -{-# LINE 78 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} + DocTest.printPrefix "Numeric.LAPACK.Example.DividedDifference:86: " +{-# LINE 86 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} DocTest.property -{-# LINE 78 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} +{-# LINE 86 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} (QC.forAll genDD $ \(xs, (ys0,ys1)) -> approxArray (dividedDifferencesMatrix xs (Vector.mul ys0 ys1)) (dividedDifferencesMatrix xs ys0 <> dividedDifferencesMatrix xs ys1)) + DocTest.printPrefix "Numeric.LAPACK.Example.DividedDifference:96: " +{-# LINE 96 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} + DocTest.property +{-# LINE 96 "src/Numeric/LAPACK/Example/DividedDifference.hs" #-} + (QC.forAll (QC.choose (0,10)) $ \n -> let sh = shapeInt n in QC.forAll (Util.genDistinct [-10..10] [-10..10] sh) $ \xs -> approxArray (DD.parameterDifferencesMatrix xs) (DD.upperFromPyramid sh (Vector.zero sh : DD.parameterDifferences xs))) diff --git a/test/DocTest/Numeric/LAPACK/Example/EconomicAllocation.hs b/test/DocTest/Numeric/LAPACK/Example/EconomicAllocation.hs --- a/test/DocTest/Numeric/LAPACK/Example/EconomicAllocation.hs +++ b/test/DocTest/Numeric/LAPACK/Example/EconomicAllocation.hs @@ -1,11 +1,11 @@ -- Do not edit! Automatically created with doctest-extract from src/Numeric/LAPACK/Example/EconomicAllocation.hs -{-# LINE 20 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} +{-# LINE 22 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} module DocTest.Numeric.LAPACK.Example.EconomicAllocation where import qualified Test.DocTest.Driver as DocTest -{-# LINE 21 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} +{-# LINE 23 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} import Numeric.LAPACK.Example.EconomicAllocation import Test.Utility (approxVector) @@ -16,8 +16,8 @@ test :: DocTest.T () test = do - DocTest.printPrefix "Numeric.LAPACK.Example.EconomicAllocation:90: " -{-# LINE 90 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} + DocTest.printPrefix "Numeric.LAPACK.Example.EconomicAllocation:92: " +{-# LINE 92 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} DocTest.property -{-# LINE 90 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} +{-# LINE 92 "src/Numeric/LAPACK/Example/EconomicAllocation.hs" #-} (let result = iterated expenses0 balances0 in approxVector result $ compensated expenses0 balances0 +++ Vector.zero (Array.shape $ Vector.takeRight result)) diff --git a/test/DocTest/Numeric/LAPACK/Permutation/Private.hs b/test/DocTest/Numeric/LAPACK/Permutation/Private.hs --- a/test/DocTest/Numeric/LAPACK/Permutation/Private.hs +++ b/test/DocTest/Numeric/LAPACK/Permutation/Private.hs @@ -1,20 +1,19 @@ -- Do not edit! Automatically created with doctest-extract from src/Numeric/LAPACK/Permutation/Private.hs -{-# LINE 47 "src/Numeric/LAPACK/Permutation/Private.hs" #-} +{-# LINE 46 "src/Numeric/LAPACK/Permutation/Private.hs" #-} module DocTest.Numeric.LAPACK.Permutation.Private where import qualified Test.DocTest.Driver as DocTest -{-# LINE 48 "src/Numeric/LAPACK/Permutation/Private.hs" #-} +{-# LINE 47 "src/Numeric/LAPACK/Permutation/Private.hs" #-} import qualified Test.QuickCheck as QC import Test.Permutation (genPerm, genPivots) import qualified Numeric.LAPACK.Permutation as Perm -import Numeric.LAPACK.Permutation (Permutation, Inversion(NonInverted), determinant, multiply, transpose) +import Numeric.LAPACK.Permutation + (Permutation, determinant, multiply, transpose) import Numeric.LAPACK.Matrix (ShapeInt) -import qualified Data.Array.Comfort.Storable as Array -import Data.Eq.HT (equating) import Data.Semigroup ((<>)) import Control.Applicative (liftA2) @@ -26,18 +25,18 @@ test :: DocTest.T () test = do - DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:87: " -{-# LINE 87 "src/Numeric/LAPACK/Permutation/Private.hs" #-} + DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:100: " +{-# LINE 100 "src/Numeric/LAPACK/Permutation/Private.hs" #-} DocTest.property -{-# LINE 87 "src/Numeric/LAPACK/Permutation/Private.hs" #-} - (QC.forAll QC.arbitraryBoundedEnum $ \inv -> QC.forAll (QC.arbitrary >>= genPivots) $ \xs -> Array.toList xs == Array.toList (Perm.toPivots inv (Perm.fromPivots inv xs))) - DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:168: " -{-# LINE 168 "src/Numeric/LAPACK/Permutation/Private.hs" #-} +{-# LINE 100 "src/Numeric/LAPACK/Permutation/Private.hs" #-} + (QC.forAll QC.arbitraryBoundedEnum $ \inv -> QC.forAll (QC.arbitrary >>= genPivots) $ \xs -> xs == Perm.toPivots inv (Perm.fromPivots inv xs)) + DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:183: " +{-# LINE 183 "src/Numeric/LAPACK/Permutation/Private.hs" #-} DocTest.property -{-# LINE 168 "src/Numeric/LAPACK/Permutation/Private.hs" #-} +{-# LINE 183 "src/Numeric/LAPACK/Permutation/Private.hs" #-} (QC.forAll genPerm2 $ \(p0,p1) -> determinant (multiply p0 p1) == determinant p0 <> determinant p1) - DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:197: " -{-# LINE 197 "src/Numeric/LAPACK/Permutation/Private.hs" #-} + DocTest.printPrefix "Numeric.LAPACK.Permutation.Private:212: " +{-# LINE 212 "src/Numeric/LAPACK/Permutation/Private.hs" #-} DocTest.property -{-# LINE 197 "src/Numeric/LAPACK/Permutation/Private.hs" #-} - (QC.forAll genPerm2 $ \(p0,p1) -> equating (Array.toList . Perm.toPivots NonInverted) (transpose $ multiply p0 p1) (multiply (transpose p1) (transpose p0))) +{-# LINE 212 "src/Numeric/LAPACK/Permutation/Private.hs" #-} + (QC.forAll genPerm2 $ \(p0,p1) -> transpose (multiply p0 p1) == multiply (transpose p1) (transpose p0)) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -12,6 +12,7 @@ import qualified Test.LowerUpper as LowerUpper import qualified Test.Orthogonal as Orthogonal import qualified Test.Singular as Singular +import qualified Test.Function as Function import qualified Test.Shape as Shape import qualified Test.Permutation as Permutation import qualified DocTest.Main as DocTestMain @@ -58,8 +59,16 @@ prefix "LowerUpper" LowerUpper.testsVar ++ prefix "Orthogonal" Orthogonal.testsVar ++ prefix "Singular" Singular.testsVar ++ + prefix "Function" Function.testsVar ++ [] +testsReal :: + (Show a, Class.Real a, Eq a, RealOf a ~ a) => + [(String, Tagged a QC.Property)] +testsReal = + prefix "Function" Function.testsReal ++ + [] + tagTests :: String -> Proxy tag -> [(String, Tagged tag QC.Property)] -> [(String, QC.Property)] @@ -69,8 +78,8 @@ tests :: [(String, QC.Property)] tests = concat $ List.transpose $ - (tagTests "Float" (Proxy :: Proxy Float) testsVar) : - (tagTests "Double" (Proxy :: Proxy Double) testsVar) : + (tagTests "Float" (Proxy :: Proxy Float) (testsVar++testsReal)) : + (tagTests "Double" (Proxy :: Proxy Double) (testsVar++testsReal)) : (tagTests "ComplexFloat" (Proxy :: Proxy (Complex Float)) testsVar) : (tagTests "ComplexDouble" (Proxy :: Proxy (Complex Double)) testsVar) : [] diff --git a/test/Numeric/LAPACK/Matrix/Banded/Naive.hs b/test/Numeric/LAPACK/Matrix/Banded/Naive.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/LAPACK/Matrix/Banded/Naive.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.Banded.Naive where + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix.Layout (Order) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable ((!)) + + +toFull :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + Matrix.Banded sub super meas vert horiz height width a -> + Matrix.Full meas vert horiz height width a +toFull = ArrMatrix.lift1 $ \a -> + case Array.shape a of + shape@(Layout.Banded _offDiag order extent) -> + Array.sample (Layout.Full order extent) $ \ix -> + let bix = uncurry Layout.InsideBox ix + in if Shape.inBounds shape bix then a!bix else 0 + +forceOrder :: + (Unary.Natural sub, Unary.Natural super, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + Order -> + Matrix.Banded sub super meas vert horiz height width a -> + Matrix.Banded sub super meas vert horiz height width a +forceOrder newOrder = ArrMatrix.lift1 $ \a -> + case Array.shape a of + shape -> + Array.sample (shape{Layout.bandedOrder = newOrder}) $ \ix -> + case ix of + Layout.InsideBox _ _ -> a!ix + _ -> + if newOrder == Layout.bandedOrder shape + then a!ix + else 0 diff --git a/test/Numeric/LAPACK/Matrix/BandedHermitian/Naive.hs b/test/Numeric/LAPACK/Matrix/BandedHermitian/Naive.hs new file mode 100644 --- /dev/null +++ b/test/Numeric/LAPACK/Matrix/BandedHermitian/Naive.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies #-} +module Numeric.LAPACK.Matrix.BandedHermitian.Naive where + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent +import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix.Layout (Order) +import Numeric.LAPACK.Matrix ((#!)) + +import qualified Numeric.Netlib.Class as Class + +import qualified Type.Data.Num.Unary as Unary + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable ((!)) + + +toHermitian :: + (Unary.Natural offDiag, Shape.Indexed size, Class.Floating a) => + Banded.Hermitian offDiag size a -> Matrix.Hermitian size a +toHermitian = ArrMatrix.lift1 $ \a -> + case Array.shape a of + shape@(Layout.BandedHermitian _offDiag order size) -> + Array.sample (Layout.hermitian order size) $ \ix -> + let bix = uncurry Layout.InsideBox ix + in if Shape.inBounds shape bix then a!bix else 0 + +toBanded :: + (Unary.Natural offDiag, Shape.Indexed size, Class.Floating a) => + Banded.Hermitian offDiag size a -> Banded.Square offDiag offDiag size a +toBanded a = flip ArrMatrix.lift1 a $ \av -> + case Array.shape av of + shape@(Layout.BandedHermitian offDiag order size) -> + Array.sample + (Layout.Banded (offDiag,offDiag) order (Extent.square size)) $ + \ix -> + case ix of + Layout.InsideBox r c -> a#!(r,c) + _ -> if Shape.inBounds shape ix then av!ix else 0 + +forceOrder :: + (Unary.Natural offDiag, Shape.Indexed size, Class.Floating a) => + Order -> + Banded.Hermitian offDiag size a -> + Banded.Hermitian offDiag size a +forceOrder newOrder = ArrMatrix.lift1 $ \a -> + case Array.shape a of + shape -> + Array.sample (shape{Layout.bandedHermitianOrder = newOrder}) $ + \ix -> + case ix of + Layout.InsideBox _ _ -> a!ix + _ -> + if newOrder == Layout.bandedHermitianOrder shape + then a!ix + else 0 diff --git a/test/Test/Banded.hs b/test/Test/Banded.hs --- a/test/Test/Banded.hs +++ b/test/Test/Banded.hs @@ -2,29 +2,36 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} module Test.Banded (testsVar) where import qualified Test.Divide as Divide +import qualified Test.Generic as Generic import qualified Test.Indexed as Indexed import qualified Test.Generator as Gen import qualified Test.Utility as Util import Test.Banded.Utility (Square(Square), genSquare, shapeBandedFromFull, offDiagonals, offDiagonalNats) -import Test.Generator ((<-*#>), (<#*|>), (<-*|>), (<#*#>), (<#\#>)) +import Test.Generator ((<#=#>), (<-*#>), (<#*|>), (<-*|>), (<#*#>), (<#\#>)) import Test.Logic (Dim) import Test.Utility (approx, approxArray, approxMatrix, approxVector, - genArray, Tagged, equalListWith) + genOrder, genArray, genArrayIndexed, + equalArray, Tagged, equalListWith) +import qualified Numeric.LAPACK.Matrix.Banded.Naive as BandedNaive import qualified Numeric.LAPACK.Matrix.Banded as Banded import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix (ShapeInt, (#*##), (-*#), (#*|)) import Numeric.LAPACK.Vector (Vector) -import Numeric.LAPACK.Scalar (RealOf, absolute) +import Numeric.LAPACK.Scalar (RealOf, absolute, one) import qualified Numeric.Netlib.Class as Class @@ -33,13 +40,15 @@ import qualified Type.Data.Num.Unary as Unary import Type.Data.Num.Unary (unary, (:+:)) +import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) -import Control.Applicative ((<$>)) +import Control.Applicative (liftA2, (<$>)) -import Data.Tuple.HT (mapSnd) +import Data.Tuple.HT (mapPair, mapSnd) import qualified Test.QuickCheck as QC @@ -55,7 +64,6 @@ Show (Banded height width a) where showsPrec p (Banded a) = showsPrec p a - genBanded :: (Dim height, Dim width, Class.Floating a) => Gen.Matrix height width a (Banded height width a) @@ -67,6 +75,91 @@ fmap Banded $ genArray maxElem $ shapeBandedFromFull (unary sub, unary super) shape +genBandedLimitted :: + (Dim height, Dim width, Shape.Indexed height, Shape.Indexed width, + Class.Floating a) => + Gen.Matrix height width a (Banded height width a) +genBandedLimitted = + flip Gen.mapGenDim Gen.matrixShape $ \maxElem maxDim shape -> do + kl <- QC.choose (0, toInteger maxDim) + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural kl $ \sub -> + Unary.reifyNatural ku $ \super -> + fmap (Banded . ArrMatrix.lift0) $ + Util.genArrayIndexed + (Omni.toBanded $ + shapeBandedFromFull (unary sub, unary super) shape) $ \ix -> + case ix of + Layout.InsideBox _ _ -> Util.genElement maxElem + Layout.VertOutsideBox _ _ -> return 0 + Layout.HorizOutsideBox _ _ -> return 0 + + +data Banded2 height width a = + forall sub super. + (Unary.Natural sub, Unary.Natural super) => + Banded2 + (Banded.General sub super height width a) + (Banded.General sub super height width a) + +instance + (Show width, Show height, Show a, + Shape.C width, Shape.C height, Storable a) => + Show (Banded2 height width a) where + showsPrec p (Banded2 a b) = + showParen True $ showsPrec p a . showString ", " . showsPrec p b + +genMatrixShape :: + (Dim height, Dim width) => + Gen.Matrix height width a (MatrixShape.General height width) +genMatrixShape = Gen.mapGen (const return) Gen.matrixShape + +genBanded2 :: + (Dim height, Eq height, Dim width, Eq width, Class.Floating a) => + Gen.Matrix height width a (Banded2 height width a) +genBanded2 = + flip Gen.mapQCDim ((,) <$> genMatrixShape <#=#> genMatrixShape) $ + \maxElem maxDim (shapeA,shapeB) -> do + kl <- QC.choose (0, toInteger maxDim) + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural kl $ \sub -> + Unary.reifyNatural ku $ \super -> + liftA2 Banded2 + (genArray maxElem $ + shapeBandedFromFull (unary sub, unary super) shapeA) + (genArray maxElem $ + shapeBandedFromFull (unary sub, unary super) shapeB) + + +toFull :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Banded ShapeInt ShapeInt a -> Bool +toFull (Banded a) = equalArray (Banded.toFull a) (BandedNaive.toFull a) + +forceOrderIndexed :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.Order -> Banded ShapeInt ShapeInt a -> Bool +forceOrderIndexed newOrder (Banded a) = + equalArray (Banded.forceOrder newOrder a) (BandedNaive.forceOrder newOrder a) + + +takeTopLeftSquare :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square (ShapeInt ::+ ShapeInt) a -> Bool +takeTopLeftSquare (Square a) = + approxArray + (Square.takeTopLeft $ Banded.toFull a) + (Banded.toFull $ Banded.takeTopLeftSquare a) + +takeBottomRightSquare :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Square (ShapeInt ::+ ShapeInt) a -> Bool +takeBottomRightSquare (Square a) = + approxArray + (Square.takeBottomRight $ Banded.toFull a) + (Banded.toFull $ Banded.takeBottomRightSquare a) + + multiplyFullIdentity :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => Banded ShapeInt ShapeInt a -> Bool @@ -126,7 +219,7 @@ Banded.General subB superB heightB widthB a -> (Proof.Nat (subA :+: subB), Proof.Nat (superA :+: superB)) addOffDiagonals a b = - fst $ MatrixShape.addOffDiagonals (offDiagonals a) (offDiagonals b) + fst $ Layout.addOffDiagonals (offDiagonals a) (offDiagonals b) multiplyBanded :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => @@ -203,6 +296,61 @@ in approxVector (lo#*|x) (Banded.toLowerTriangular lo #*| x) +data UnitUpper size a = + forall super. + (Unary.Natural super) => UnitUpper (Banded.UnitUpper super size a) + +instance + (Show size, Show a, Shape.C size, Storable a) => + Show (UnitUpper size a) where + showsPrec p (UnitUpper a) = showsPrec p a + +genUnitUpper :: (Class.Floating a) => Gen.MatrixInt a (UnitUpper ShapeInt a) +genUnitUpper = flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim shape -> do + ku <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural ku $ \super -> + fmap UnitUpper $ genArrayUnitDiagFromSquare maxElem $ + shapeBandedFromFull (unary TypeNum.u0, unary super) shape + +singletonFromSuper :: + (Unary.Natural super) => + MatrixShape.BandedUpper super sh -> Unary.HeadSingleton super +singletonFromSuper _ = Unary.headSingleton + +genArrayUnitDiagFromSquare :: + (Unary.Natural super, + Shape.Indexed sh, Shape.Index sh ~ i, Eq i, Class.Floating a) => + Integer -> + MatrixShape.BandedUpper super sh -> + QC.Gen (Banded.UnitUpper super sh a) +genArrayUnitDiagFromSquare maxElem shape = + case singletonFromSuper shape of + Unary.Zero -> genArrayUnitDiag maxElem $ shapeUnitBanded shape + Unary.Succ -> genArrayUnitDiag maxElem $ shapeUnitBanded shape + +genArrayUnitDiag :: + (Omni.BandedTriangular super Unary.Zero, + Omni.BandedTriangular Unary.Zero super, + Shape.Indexed sh, Shape.Index sh ~ i, Eq i, Class.Floating a) => + Integer -> + MatrixShape.BandedUnitUpper super sh -> + QC.Gen (Banded.UnitUpper super sh a) +genArrayUnitDiag maxElem shape = + fmap (ArrMatrix.Array . Array.reshape shape) $ + genArrayIndexed (Omni.toPlain shape) $ + \ix -> + if case ix of Layout.InsideBox r c -> r==c; _ -> False + then return one + else Util.genElement maxElem + +shapeUnitBanded :: + (Omni.BandedTriangular super Unary.Zero, + Omni.BandedTriangular Unary.Zero super) => + MatrixShape.BandedUpper super sh -> MatrixShape.BandedUnitUpper super sh +shapeUnitBanded (Omni.Banded shape) = Omni.UnitBandedTriangular shape + + + determinant :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => Square ShapeInt a -> Bool @@ -228,7 +376,13 @@ Gen.T dim tag a -> (a -> test) -> Tagged tag QC.Property checkForAll gen = Util.checkForAll (Gen.run gen 10 5) +checkForAllExtra :: + (Show a, Show b, QC.Testable test) => + QC.Gen a -> Gen.T dim tag b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + testsVar :: (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => [(String, Tagged a QC.Property)] @@ -239,7 +393,31 @@ (\(Banded arr) -> Matrix.indices arr) genBanded) (\(mix, Banded arr) -> Indexed.unitDot (mix, arr))) : + ("forceOrder", + checkForAllExtra genOrder + ((,) <$> Gen.asMatrixInt genBanded <#*|> Gen.vector) + (\order (Banded a, v) -> Generic.forceOrder order (a,v))) : + ("forceOrderInverse", + checkForAll (Gen.asMatrixInt genBandedLimitted) + (\(Banded a) -> Generic.forceOrderInverse a)) : + ("forceOrderIndexed", + checkForAllExtra genOrder genBanded forceOrderIndexed) : + ("addDistributive", + checkForAll + (Generic.genDistribution2 (Gen.asMatrixInt genBanded2)) + (\(Banded2 a b, v) -> Generic.addDistributive ((a,b),v))) : + ("subDistributive", + checkForAll + (Generic.genDistribution2 (Gen.asMatrixInt genBanded2)) + (\(Banded2 a b, v) -> Generic.subDistributive ((a,b),v))) : + ("toFull", + checkForAll genBanded toFull) : + ("takeTopLeftSquare", + checkForAll genSquare takeTopLeftSquare) : + ("takeBottomRightSquare", + checkForAll genSquare takeBottomRightSquare) : + ("multiplyFullIdentity", checkForAll genBanded multiplyFullIdentity) : ("multiplyFullAny", @@ -274,6 +452,17 @@ checkForAll ((,) <$> Gen.condition invertible genSquare <#\#> Gen.matrix) multiplySolve) : + map + (mapPair + (("UnitUpper."++), + ($ ((\(UnitUpper m) -> Divide.SquareMatrix m) <$> genUnitUpper)))) + Divide.testsVarAny ++ + map + (mapPair + (("UnitLower."++), + ($ ((\(UnitUpper m) -> Divide.SquareMatrix $ Banded.transpose m) + <$> genUnitUpper)))) + Divide.testsVarAny ++ map (mapSnd ($ ((\(Square m) -> Divide.SquareMatrix m) diff --git a/test/Test/Banded/Utility.hs b/test/Test/Banded/Utility.hs --- a/test/Test/Banded/Utility.hs +++ b/test/Test/Banded/Utility.hs @@ -1,14 +1,18 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} module Test.Banded.Utility where import qualified Test.Generator as Gen +import Test.Logic (Dim) import Test.Utility (genArray) import qualified Numeric.LAPACK.Matrix.Banded as Banded import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape -import Numeric.LAPACK.Matrix.Shape (UnaryProxy) -import Numeric.LAPACK.Matrix (ShapeInt) +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix.Layout (UnaryProxy) import qualified Numeric.Netlib.Class as Class @@ -31,23 +35,24 @@ natFromProxy Proxy = Proof.Nat offDiagonals :: - Banded.Banded sub super vert horiz height width a -> + Matrix.Banded sub super meas vert horiz height width a -> (UnaryProxy sub, UnaryProxy super) offDiagonals = MatrixShape.bandedOffDiagonals . ArrMatrix.shape offDiagonalNats :: (Unary.Natural sub, Unary.Natural super) => - Banded.Banded sub super vert horiz height width a -> + Matrix.Banded sub super meas vert horiz height width a -> (Proof.Nat sub, Proof.Nat super) offDiagonalNats = mapPair (natFromProxy, natFromProxy) . offDiagonals shapeBandedFromFull :: - (MatrixShape.UnaryProxy sub, MatrixShape.UnaryProxy super) -> - MatrixShape.Full vert horiz height width -> - MatrixShape.Banded sub super vert horiz height width -shapeBandedFromFull klu (MatrixShape.Full order extent) = - MatrixShape.Banded klu order extent + (Unary.Natural sub, Unary.Natural super) => + (Layout.UnaryProxy sub, Layout.UnaryProxy super) -> + MatrixShape.Full meas vert horiz height width -> + MatrixShape.Banded sub super meas vert horiz height width +shapeBandedFromFull klu (Omni.Full (Layout.Full order extent)) = + Omni.Banded $ Layout.Banded klu order extent data Square size a = @@ -60,7 +65,7 @@ Show (Square size a) where showsPrec p (Square a) = showsPrec p a -genSquare :: (Class.Floating a) => Gen.MatrixInt a (Square ShapeInt a) +genSquare :: (Dim size, Class.Floating a) => Gen.Square size a (Square size a) genSquare = flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim shape -> do kl <- QC.choose (0, toInteger maxDim) ku <- QC.choose (0, toInteger maxDim) diff --git a/test/Test/BandedHermitian.hs b/test/Test/BandedHermitian.hs --- a/test/Test/BandedHermitian.hs +++ b/test/Test/BandedHermitian.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ExistentialQuantification #-} @@ -6,32 +7,38 @@ module Test.BandedHermitian (testsVar) where import qualified Test.Divide as Divide +import qualified Test.Generic as Generic import qualified Test.Indexed as Indexed import qualified Test.Generator as Gen import qualified Test.Utility as Util import Test.Banded.Utility (Square(Square), genSquare, shapeBandedFromFull, natFromProxy, offDiagonalNats) -import Test.Generator ((<-*#>), (<#*|>), (<-*|>), (<#*#>), (<#\#>)) +import Test.Generator ((<#=#>), (<-*#>), (<#*|>), (<-*|>), (<#*#>), (<#\#>)) import Test.Logic (Dim) import Test.Utility (approxReal, approxArray, approxRealVectorTol, approxMatrix, approxVector, - genOrder, genArray, genVector, Tagged, equalListWith) + genOrder, genArray, genVector, Tagged, equalArray, equalListWith) import qualified Numeric.LAPACK.Matrix.BandedHermitianPositiveDefinite as BandedHermitianPD +import qualified Numeric.LAPACK.Matrix.BandedHermitian.Naive + as BandedHermitianNaive import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian import qualified Numeric.LAPACK.Matrix.Banded as Banded +import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Square as Square import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import qualified Numeric.LAPACK.ShapeStatic as ShapeStatic -import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (#*#), (#*##), (-*#), (#*|)) +import qualified Data.Array.Comfort.Shape.Static as ShapeStatic +import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (#*##), (-*#), (#*|)) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, fromReal, absolute, selectReal) @@ -40,9 +47,11 @@ import qualified Type.Data.Num.Unary.Proof as Proof import qualified Type.Data.Num.Unary as Unary import Type.Data.Num.Unary (unary) +import Type.Data.Bool (False, True) import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)) import Foreign.Storable (Storable) @@ -55,22 +64,41 @@ import qualified Test.QuickCheck as QC -data BandedHermitian size a = +data FlexBandedHermitian neg zero pos size a = forall offDiag. (Unary.Natural offDiag) => - BandedHermitian (BandedHermitian.BandedHermitian offDiag size a) + BandedHermitian (Banded.FlexHermitian neg zero pos offDiag size a) +type BandedHermitian = FlexBandedHermitian True True True +type BandedHermitianPosDef = FlexBandedHermitian False False True + instance (Show size, Show a, Shape.C size, Storable a) => - Show (BandedHermitian size a) where + Show (FlexBandedHermitian neg zero pos size a) where showsPrec p (BandedHermitian a) = showsPrec p a +data BandedHermitian2 size a = + forall offDiag. + (Unary.Natural offDiag) => + BandedHermitian2 + (Banded.Hermitian offDiag size a) + (Banded.Hermitian offDiag size a) + +instance + (Show size, Show a, Shape.C size, Storable a) => + Show (BandedHermitian2 size a) where + showsPrec p (BandedHermitian2 a b) = + showParen True $ showsPrec p a . showString ", " . showsPrec p b + + shapeBandedHermitianFromSquare :: - (MatrixShape.UnaryProxy off) -> + (Unary.Natural off) => + Layout.UnaryProxy off -> MatrixShape.Square size -> MatrixShape.BandedHermitian off size -shapeBandedHermitianFromSquare k (MatrixShape.Full order extent) = - MatrixShape.BandedHermitian k order $ Extent.height extent +shapeBandedHermitianFromSquare k (Omni.Full (Layout.Full order extent)) = + Omni.BandedHermitian $ + Layout.BandedHermitian k order $ Extent.height extent {- @@ -90,23 +118,95 @@ Class.Floating a, RealOf a ~ ar, Class.Real ar) => Gen.Square sh a (BandedHermitian sh a) genBandedHermitian = - flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim sqShape -> do + flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim shape -> do k <- QC.choose (0, toInteger maxDim) - Unary.reifyNatural k $ \numOff -> do - let shape = shapeBandedHermitianFromSquare (unary numOff) sqShape - BandedHermitian <$> - (Util.genArrayIndexed shape $ \ix -> - let real = - case ix of - MatrixShape.InsideBox r c -> r==c - MatrixShape.VertOutsideBox _ _ -> False - MatrixShape.HorizOutsideBox _ _ -> False - in if real + Unary.reifyNatural k $ \numOff -> + BandedHermitian <$> qcGenBandedHermitian (unary numOff) maxElem shape + +genSquareShape :: (Dim sh) => Gen.Matrix sh sh a (MatrixShape.Square sh) +genSquareShape = Gen.mapGen (const return) Gen.squareShape + +genBandedHermitian2 :: + (Dim sh, Eq sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Square sh a (BandedHermitian2 sh a) +genBandedHermitian2 = + flip Gen.mapQCDim ((,) <$> genSquareShape <#=#> genSquareShape) $ + \maxElem maxDim (shapeA,shapeB) -> do + k <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural k $ \numOff -> + liftA2 BandedHermitian2 + (qcGenBandedHermitian (unary numOff) maxElem shapeA) + (qcGenBandedHermitian (unary numOff) maxElem shapeB) + +qcGenBandedHermitian :: + (Unary.Natural offDiag, + Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.UnaryProxy offDiag -> + Integer -> + MatrixShape.Square sh -> + QC.Gen (Banded.Hermitian offDiag sh a) +qcGenBandedHermitian numOff maxElem sqShape = + case shapeBandedHermitianFromSquare numOff sqShape of + Omni.BandedHermitian shape -> + fmap ArrMatrix.lift0 $ Util.genArrayIndexed shape $ \ix -> + let real = + case ix of + Layout.InsideBox r c -> r==c + Layout.VertOutsideBox _ _ -> False + Layout.HorizOutsideBox _ _ -> False + in if real + then fromReal <$> Util.genReal maxElem + else Util.genElement maxElem + + +genBandedHermitianLimitted :: + (Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.Square sh a (BandedHermitian sh a) +genBandedHermitianLimitted = + flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim shape -> do + k <- QC.choose (0, toInteger maxDim) + Unary.reifyNatural k $ \numOff -> + fmap (BandedHermitian . ArrMatrix.lift0) $ + Util.genArrayIndexed + (Omni.toBandedHermitian $ + shapeBandedHermitianFromSquare (unary numOff) shape) $ \ix -> + case ix of + Layout.InsideBox r c -> + if r==c then fromReal <$> Util.genReal maxElem - else Util.genElement maxElem) + else Util.genElement maxElem + Layout.VertOutsideBox _ _ -> return 0 + Layout.HorizOutsideBox _ _ -> return 0 +toHermitian :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ShapeInt a -> Bool +toHermitian (BandedHermitian a) = + equalArray + (BandedHermitian.toHermitian a) + (BandedHermitianNaive.toHermitian a) +toBanded :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian ShapeInt a -> Bool +toBanded (BandedHermitian a) = + equalArray + (BandedHermitian.toBanded a) + (BandedHermitianNaive.toBanded a) + +forceOrderIndexed :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.Order -> BandedHermitian ShapeInt a -> Bool +forceOrderIndexed newOrder (BandedHermitian a) = + equalArray + (BandedHermitian.forceOrder newOrder a) + (BandedHermitianNaive.forceOrder newOrder a) + + convertToFull :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => BandedHermitian ShapeInt a -> Bool @@ -123,6 +223,24 @@ (Hermitian.takeDiagonal $ BandedHermitian.toHermitian a) (BandedHermitian.takeDiagonal a) + +takeTopLeft :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian (ShapeInt ::+ ShapeInt) a -> Bool +takeTopLeft (BandedHermitian a) = + approxArray + (Hermitian.takeTopLeft $ BandedHermitian.toHermitian a) + (BandedHermitian.toHermitian $ BandedHermitian.takeTopLeft a) + +takeBottomRight :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + BandedHermitian (ShapeInt ::+ ShapeInt) a -> Bool +takeBottomRight (BandedHermitian a) = + approxArray + (Hermitian.takeBottomRight $ BandedHermitian.toHermitian a) + (BandedHermitian.toHermitian $ BandedHermitian.takeBottomRight a) + + gramian :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => Square ShapeInt a -> Bool @@ -132,7 +250,7 @@ (Proof.Nat, Proof.AddComm) -> approxArray (BandedHermitian.toBanded $ BandedHermitian.gramian a) - (Banded.adjoint a #*# a) + (Banded.multiply (Banded.adjoint a) a) @@ -168,7 +286,7 @@ sumRank1 :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - MatrixShape.Order -> SumRank1 ShapeInt a -> Bool + Layout.Order -> SumRank1 ShapeInt a -> Bool sumRank1 order (SumRank1 sh xs) = approxArray (BandedHermitian.toHermitian $ BandedHermitian.sumRank1 order sh xs) @@ -268,7 +386,7 @@ genBandedHPD :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Gen.MatrixInt a (BandedHermitian ShapeInt a) + Gen.MatrixInt a (BandedHermitianPosDef ShapeInt a) genBandedHPD = flip Gen.mapGenDim Gen.squareShape $ \maxElem maxDim shape -> do kl <- QC.choose (0, toInteger maxDim) ku <- QC.choose (0, toInteger maxDim) @@ -278,30 +396,34 @@ super = unary superU; superP = natFromProxy super in case (Proof.addNat subP superP, Proof.addComm subP superP) of (Proof.Nat, Proof.AddComm) -> - fmap (BandedHermitian . BandedHermitian.gramian) $ + fmap (BandedHermitian . HermitianPD.assurePositiveDefiniteness . + BandedHermitian.gramian) $ (genArray maxElem $ shapeBandedFromFull (sub, super) shape) `QC.suchThat` - (\a -> absolute (Banded.determinant a) > 0.1) + (\a -> absolute (Banded.determinant a) > 0.5) determinant :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - BandedHermitian ShapeInt a -> Bool + BandedHermitianPosDef ShapeInt a -> Bool determinant (BandedHermitian a) = let detB = BandedHermitianPD.determinant a - detS = Hermitian.determinant $ BandedHermitian.toHermitian a + detS = HermitianPD.determinant $ BandedHermitian.toHermitian a in approxReal (selectReal 1 1e-3 * max 1 (abs detB + abs detS)) detB detS multiplySolve :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (BandedHermitian ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + (BandedHermitianPosDef ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> + Bool multiplySolve (BandedHermitian a, b) = approxMatrix (selectReal 10 1e-3) (a #*## BandedHermitianPD.solve a b) b solveDecomposed :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (BandedHermitian ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + (BandedHermitianPosDef ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> Bool solveDecomposed (BandedHermitian a, b) = approxMatrix (selectReal 1e-3 1e-7) (BandedHermitianPD.solve a b) @@ -311,7 +433,7 @@ eigenvaluesDeterminant :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - BandedHermitian ShapeInt a -> Bool + BandedHermitianPosDef ShapeInt a -> Bool eigenvaluesDeterminant (BandedHermitian a) = let det = BandedHermitianPD.determinant a prod = Vector.product $ BandedHermitian.eigenvalues a @@ -323,8 +445,8 @@ eigensystem (BandedHermitian a) = let (q,d) = BandedHermitian.eigensystem a in approxMatrix 1e-4 - (Banded.toFull $ BandedHermitian.toBanded a) - (q <> Matrix.scaleRowsReal d (Square.adjoint q)) + (BandedHermitian.toHermitian a) + (Hermitian.congruenceDiagonalAdjoint (Matrix.fromFull q) d) eigenvaluesHermitian :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => @@ -349,7 +471,7 @@ and (zipWith (\(r,c) x -> approxReal tol (absolute x) $ if r==c then 1 else 0) - (Shape.indices $ ArrMatrix.shape unit) + (Shape.indices $ ArrMatrix.plainShape unit) (Array.toList $ ArrMatrix.toVector unit)) @@ -377,10 +499,38 @@ (\(BandedHermitian arr) -> Matrix.indices arr) genBandedHermitian) (\(mix, BandedHermitian arr) -> Indexed.unitDot (mix, arr))) : + ("forceOrder", + checkForAllExtra genOrder + ((,) <$> genBandedHermitian <#*|> Gen.vector) + (\order (BandedHermitian a, v) -> Generic.forceOrder order (a,v))) : + ("forceOrderInverse", + checkForAll genBandedHermitianLimitted + (\(BandedHermitian a) -> Generic.forceOrderInverse a)) : + ("forceOrderIndexed", + checkForAllExtra genOrder genBandedHermitian forceOrderIndexed) : + ("addDistributive", + checkForAll + (Generic.genDistribution2 genBandedHermitian2) + (\(BandedHermitian2 a b, v) -> Generic.addDistributive ((a,b),v))) : + ("subDistributive", + checkForAll + (Generic.genDistribution2 genBandedHermitian2) + (\(BandedHermitian2 a b, v) -> Generic.subDistributive ((a,b),v))) : + + ("toHermitian", + checkForAll genBandedHermitian toHermitian) : + ("toBanded", + checkForAll genBandedHermitian toBanded) : ("convertToFull", checkForAll genBandedHermitian convertToFull) : ("takeDiagonal", checkForAll genBandedHermitian takeDiagonal) : + + ("takeTopLeft", + checkForAll genBandedHermitian takeTopLeft) : + ("takeBottomRight", + checkForAll genBandedHermitian takeBottomRight) : + ("sumRank1", checkForAllExtra genOrder genScaledVectors sumRank1) : ("gramian", diff --git a/test/Test/Divide.hs b/test/Test/Divide.hs --- a/test/Test/Divide.hs +++ b/test/Test/Divide.hs @@ -6,6 +6,8 @@ testsVarAny, SquareMatrix(SquareMatrix), determinant, + solve, solveIdentity, inverse, + approxRelMatrix, approxRelArray, ) where import qualified Test.Generator as Gen @@ -15,13 +17,15 @@ import qualified Numeric.LAPACK.Linear.LowerUpper as LU import qualified Numeric.LAPACK.Matrix.Square as Square -import qualified Numeric.LAPACK.Matrix.Special as Special +import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix -import qualified Numeric.LAPACK.Matrix.Shape.Box as Box +import qualified Numeric.LAPACK.Matrix.Special as Special +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Scalar as Scalar -import Numeric.LAPACK.Matrix.Array (ArrayMatrix) -import Numeric.LAPACK.Matrix (Matrix, ShapeInt, (##/#), (##*#), (#*##), (#\##)) +import Numeric.LAPACK.Matrix.Array (Quadratic, ArrayMatrix) +import Numeric.LAPACK.Matrix (ShapeInt, (##/#), (##*#), (#*##), (#\##)) import Numeric.LAPACK.Scalar (RealOf) import qualified Numeric.Netlib.Class as Class @@ -37,50 +41,110 @@ determinant :: - (ArrMatrix.Determinant shape, ArrMatrix.SquareShape shape, - Box.HeightOf shape ~ ShapeInt, Box.WidthOf shape ~ ShapeInt, + (MatrixShape.Packing pack, MatrixShape.Property property, + MatrixShape.Strip lower, MatrixShape.Strip upper, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ArrayMatrix shape a -> Bool + Quadratic pack property lower upper ShapeInt a -> Bool determinant a = - Util.approx - (Scalar.selectReal 1e-1 1e-5) - (Matrix.determinant a) - (Square.determinant $ Matrix.toSquare a) + let d = Square.determinant $ Matrix.toSquare a + in Util.approx + (max (Scalar.selectReal 1 1e-2) + (Scalar.selectReal 1e-3 1e-5 * Scalar.absolute d)) + d + (Matrix.determinant a) +approxRelMatrix, approxRelArray :: + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool +approxRelMatrix a b = + approxMatrix + (Scalar.selectReal 0.5 1e-4 * + (max 1 $ Vector.normInf $ ArrMatrix.unwrap a)) + a b + +approxRelArray a b = + Util.approxArrayTol + (max (Scalar.selectReal 1e-1 1e-4) + (Scalar.selectReal 1e-1 1e-5 * Vector.normInf (ArrMatrix.unwrap a))) + a b + + + multiplySolveTrans :: (Shape.C size, Eq size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => LU.Transposition -> (SquareMatrix size a, Matrix.General size ShapeInt a) -> Bool multiplySolveTrans trans (SquareMatrix a, b) = - approxMatrix 1e-2 b $ + approxRelMatrix b $ Matrix.multiplySquare trans a $ Matrix.solve trans a b multiplySolveRight :: (Shape.C size, Eq size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => (SquareMatrix size a, Matrix.General size ShapeInt a) -> Bool multiplySolveRight (SquareMatrix a, b) = - approxMatrix 1e-2 b (a #*## (a #\## b)) + approxRelMatrix b (a #*## (a #\## b)) multiplySolveLeft :: (Shape.C size, Eq size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => (Matrix.General ShapeInt size a, SquareMatrix size a) -> Bool multiplySolveLeft (b, SquareMatrix a) = - approxMatrix 1e-2 b ((b ##/# a) ##*# a) + approxRelMatrix b ((b ##/# a) ##*# a) multiplyInverseRight :: (Shape.C size, Eq size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => (SquareMatrix size a, Matrix.General size ShapeInt a) -> Bool multiplyInverseRight (SquareMatrix a, b) = - approxMatrix 1e-2 b (a #*## (Special.Inverse a #*## b)) + let aInv = Special.inverse a + in case aInv of + Special.Inverse _ -> approxRelMatrix b (a #*## (aInv #*## b)) multiplyInverseLeft :: (Shape.C size, Eq size, Class.Floating a, RealOf a ~ ar, Class.Real ar) => (Matrix.General ShapeInt size a, SquareMatrix size a) -> Bool multiplyInverseLeft (b, SquareMatrix a) = - approxMatrix 1e-2 b ((b ##*# Special.Inverse a) ##*# a) + let aInv = Special.inverse a + in case aInv of + Special.Inverse _ -> approxRelMatrix b ((b ##*# aInv) ##*# a) +solve :: + (MatrixShape.Packing pack, MatrixShape.Property property, + MatrixShape.Strip lower, MatrixShape.Strip upper) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Quadratic pack property upper lower ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> + Bool +solve (a, b) = + approxRelArray + (Square.solve (Matrix.toSquare a) b) + (Matrix.solveRight a b) + +solveIdentity :: + (MatrixShape.Packing pack, MatrixShape.Property property, + MatrixShape.Strip lower, MatrixShape.Strip upper) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Quadratic pack property upper lower ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> + Bool +solveIdentity (eye, a) = + approxMatrix (Scalar.selectReal 1e-3 1e-5) a (Matrix.solveRight eye a) + +inverse :: + (MatrixShape.Packing pack, MatrixShape.Property property, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Quadratic pack property upper lower ShapeInt a -> Bool +inverse a = + approxRelArray + (Square.inverse $ Matrix.toSquare a) + (Matrix.toSquare $ Matrix.inverse a) + + checkForAll :: (Show a, QC.Testable test) => Gen.T dim tag a -> (a -> test) -> Tagged tag QC.Property @@ -88,11 +152,12 @@ data SquareMatrix size a = - forall typ matrix. - (Matrix.Solve typ, Matrix.MultiplySquare typ, - Matrix typ a ~ matrix, Show matrix, - Matrix.HeightOf typ ~ size, Matrix.WidthOf typ ~ size) => - SquareMatrix (Matrix typ a) + forall typ xl xu lower upper matrix. + (Matrix.Solve typ xl xu, Matrix.MultiplySquare typ xl xu, + Matrix.ToQuadratic typ, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Matrix.Quadratic typ xl xu lower upper size a ~ matrix, Show matrix) => + SquareMatrix (Matrix.Quadratic typ xl xu lower upper size a) instance Show (SquareMatrix size a) where show (SquareMatrix m) = show m @@ -121,10 +186,12 @@ [] testsVar :: - (Matrix.Solve typ, Matrix.MultiplySquare typ, - Matrix typ a ~ matrix, Show matrix, - Matrix.HeightOf typ ~ ShapeInt, Matrix.WidthOf typ ~ ShapeInt, + (Matrix.Solve typ xl xu, Matrix.MultiplySquare typ xl xu, + Matrix.ToQuadratic typ, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Matrix.Quadratic typ xl xu lower upper ShapeInt a ~ matrix, Show matrix, Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => - Gen.MatrixInt a (Matrix typ a) -> [(String, Tagged a QC.Property)] + Gen.MatrixInt a (Matrix.Quadratic typ xl xu lower upper ShapeInt a) -> + [(String, Tagged a QC.Property)] testsVar gen = map (mapSnd ($ (SquareMatrix <$> gen))) testsVarAny diff --git a/test/Test/Format.hs b/test/Test/Format.hs --- a/test/Test/Format.hs +++ b/test/Test/Format.hs @@ -4,15 +4,16 @@ import qualified Numeric.LAPACK.Orthogonal.Householder as Hh import qualified Numeric.LAPACK.Linear.LowerUpper as LU import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape -import qualified Numeric.LAPACK.Matrix.BandedHermitian as BandedHermitian +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix.Banded as Banded -import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Permutation as Perm -import Numeric.LAPACK.Matrix.Shape (Order(RowMajor, ColumnMajor), UnaryProxy) +import Numeric.LAPACK.Matrix.Shape.Omni (Omni) +import Numeric.LAPACK.Matrix.Layout (Order(RowMajor, ColumnMajor), UnaryProxy) import Numeric.LAPACK.Matrix.Array (ArrayMatrix) import Numeric.LAPACK.Matrix (ShapeInt, shapeInt) import Numeric.LAPACK.Format (Format, (##)) @@ -31,8 +32,11 @@ randomMatrix :: - (Shape.C sh, Class.Floating a) => sh -> Word64 -> ArrayMatrix sh a -randomMatrix sh = ArrMatrix.lift0 . Vector.random Vector.UniformBoxPM1 sh + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> Word64 -> + ArrayMatrix pack property lower upper meas vert horiz height width a +randomMatrix sh = ArrMatrix.Array . Vector.random Vector.UniformBoxPM1 sh vector :: (Class.Floating a) => Vector.Vector ShapeInt a @@ -45,16 +49,16 @@ split :: (Eq lower, Shape.C height, Shape.C width, Class.Floating a) => lower -> height -> width -> Order -> - Array (MatrixShape.SplitGeneral lower height width) a + Array (Layout.SplitGeneral lower height width) a split lowerPart height width order = Vector.random Vector.UniformBoxPM1 - (MatrixShape.splitGeneral lowerPart order height width) 420 + (Layout.splitGeneral lowerPart order height width) 420 -hermitian :: (Class.Floating a) => Order -> Hermitian.Hermitian ShapeInt a +hermitian :: (Class.Floating a) => Order -> Matrix.Hermitian ShapeInt a hermitian order = randomMatrix (MatrixShape.hermitian order (shapeInt 4)) 421 -diagonal :: (Class.Floating a) => Order -> Triangular.Diagonal ShapeInt a +diagonal :: (Class.Floating a) => Order -> Matrix.Diagonal ShapeInt a diagonal order = randomMatrix (MatrixShape.diagonal order (shapeInt 4)) 422 @@ -68,7 +72,7 @@ upperTriangular order = randomMatrix (MatrixShape.upperTriangular order (shapeInt 4)) 424 -symmetric :: (Class.Floating a) => Order -> Triangular.Symmetric ShapeInt a +symmetric :: (Class.Floating a) => Order -> Matrix.Symmetric ShapeInt a symmetric order = randomMatrix (MatrixShape.symmetric order (shapeInt 4)) 425 @@ -76,7 +80,7 @@ bandedHermitian :: (Unary.Natural offDiag, Class.Floating a) => UnaryProxy offDiag -> Order -> - BandedHermitian.BandedHermitian offDiag ShapeInt a + Banded.Hermitian offDiag ShapeInt a bandedHermitian numOff order = randomMatrix (MatrixShape.bandedHermitian numOff order (shapeInt 4)) 426 @@ -143,9 +147,12 @@ printVectorFloat vector printVectorComplex vector printVectorWithOrder general - printVectorWithOrder $ split MatrixShape.Reflector (shapeInt 4) (shapeInt 3) - printVectorWithOrder $ split MatrixShape.Reflector (shapeInt 3) (shapeInt 4) - printVectorWithOrder $ split MatrixShape.Triangle (shapeInt 4) (shapeInt 3) + printVectorWithOrder $ + split Layout.Reflector (shapeInt 4) (shapeInt 3) + printVectorWithOrder $ + split Layout.Reflector (shapeInt 3) (shapeInt 4) + printVectorWithOrder $ + split Layout.Triangle (shapeInt 4) (shapeInt 3) printVectorWithOrder hermitian printVectorWithOrder diagonal printVectorWithOrder lowerTriangular diff --git a/test/Test/Function.hs b/test/Test/Function.hs new file mode 100644 --- /dev/null +++ b/test/Test/Function.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE GADTs #-} +module Test.Function (testsVar, testsReal) where + +import qualified Test.Generator as Gen +import qualified Test.Utility as Util +import Test.Symmetric (genSymmetric) +import Test.Hermitian (genHermitian) +import Test.Triangular + (genTriangular, diagonal, PowerStrip(Diagonal, Lower, Upper)) +import Test.Utility (approx, approxMatrix, Tagged) + +import qualified Numeric.LAPACK.Orthogonal as Ortho +import qualified Numeric.LAPACK.Matrix.Function as Fn +import qualified Numeric.LAPACK.Matrix.Hermitian as Hermitian +import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric +import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix.Quadratic as Quadratic +import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix as Matrix +import qualified Numeric.LAPACK.Vector as Vector +import qualified Numeric.LAPACK.Scalar as Scalar +import Numeric.LAPACK.Matrix.Array (Quadratic) +import Numeric.LAPACK.Matrix.Shape (DiagSingleton(Unit, Arbitrary)) +import Numeric.LAPACK.Matrix + (Square, ShapeInt, (#+#), (.*#), (#*##), (\*#), (#\##)) +import Numeric.LAPACK.Vector ((|-|)) +import Numeric.LAPACK.Scalar (RealOf, selectReal) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape + +import Control.Applicative (liftA2, (<$>)) + +import qualified Data.List as List +import Data.Complex (Complex((:+))) +import Data.Semigroup ((<>)) + +import qualified Test.QuickCheck as QC + + + +genPositiveSpectrum :: (Class.Real a) => Gen.MatrixInt a (Square ShapeInt a) +genPositiveSpectrum = + flip fmap Gen.square $ \a -> + let (q,r) = Ortho.householderTall a + in q <> diagonalPositive r #*## Matrix.adjoint q + +genPositiveHermitian :: + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + Layout.PackingSingleton pack -> + Gen.MatrixInt a (HermitianP pack ShapeInt a) +genPositiveHermitian _p = + flip fmap Gen.square $ \a -> + let (q,r) = Ortho.householderTall a + d = Matrix.takeDiagonal r + dd = + if Shape.size (Array.shape d) == 0 + then 0 + else 0.1 - min 0 (Vector.minimum d) + in Hermitian.congruenceDiagonalAdjoint + (Square.toFull q) (Vector.raise dd d) + +genPositiveTriangular :: + (MatrixShape.DiagUpLo lo up, Class.Real a, RealOf a ~ a) => + PowerStrip lo up -> + MatrixShape.DiagSingleton diag -> + Layout.PackingSingleton pack -> + Gen.MatrixInt a (ArrMatrix.Quadratic pack diag lo up ShapeInt a) +genPositiveTriangular cont diag p = + case diag of + Unit -> genTriangular cont diag p + Arbitrary -> fmap diagonalPositive (genTriangular cont diag p) + +diagonalPositive :: + (ArrMatrix.Additive property, ArrMatrix.Scale property, Class.Real a) => + (Quadratic pack property lower upper ShapeInt ~ matrix) => + matrix a -> matrix a +diagonalPositive a = + let d = + if Shape.size (Quadratic.size a) == 0 + then 0 + else 0.1 - min 0 (Vector.minimum (Matrix.takeDiagonal a)) + in a #+# d .*# Matrix.identityFrom a + +sqrSqrt :: + (Fn.SqRt property, MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + (Quadratic pack property lower upper ShapeInt ~ matrix) => + (matrix a -> matrix a) -> matrix a -> Bool +sqrSqrt sqrtm a = + approxMatrix (selectReal 1 1e-6) a (Matrix.square (sqrtm a)) + +sqrtSqr :: + (Fn.SqRt property, MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + (Quadratic pack property lower upper ShapeInt ~ matrix) => + (matrix a -> matrix a) -> matrix a -> Bool +sqrtSqr sqrtm a = + approxMatrix (selectReal 1e-1 1e-6) a (sqrtm (Matrix.square a)) + +expSum :: + (Fn.Exp property, ArrMatrix.Additive property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Quadratic pack property lower upper ShapeInt ~ matrix) => + (b -> matrix a -> matrix a) -> + (b,b) -> matrix a -> Bool +expSum scale (x,y) m = + let a = scale x m; b = scale y m + in approxMatrix (selectReal 10 1e-4) + (Matrix.toFull $ Fn.exp (a#+#b)) + (Matrix.toFull (Fn.exp a) <> Matrix.toFull (Fn.exp b)) + +scalarExp :: (Class.Floating a) => a -> a +scalarExp a = + case Scalar.complexSingletonOf a of + Scalar.Real -> exp a + Scalar.Complex -> exp a + +expTrace :: + (Fn.Exp property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Quadratic pack property lower upper ShapeInt a -> Bool +expTrace a = + let e = scalarExp $ Matrix.trace a + in approx + (selectReal 1 1e-6 * max 1 (1e-2 * Scalar.absolute e)) + e (Matrix.determinant $ Fn.exp a) + +{- +Fails for arbitrary square matrices because eigenvalues can be non-real. +-} +expSqrt :: + (Fn.Exp property, Fn.SqRt property, + ArrMatrix.Additive property, ArrMatrix.Homogeneous property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + (Quadratic pack property lower upper ShapeInt ~ matrix) => + (matrix a -> matrix a) -> matrix a -> Bool +expSqrt sqrtm a = + approxMatrix (selectReal 10 1e-4) + (sqrtm (Fn.exp a)) + (Fn.exp (Matrix.scaleReal (1/2) a)) + +type HermitianP pack sh = + ArrMatrix.FullQuadratic pack Omni.HermitianUnknownDefiniteness sh + +expSqrtHermitian :: + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + HermitianP pack ShapeInt a -> Bool +expSqrtHermitian a = + approxMatrix (selectReal 1e-1 1e-4) + (Fn.expRealHermitian (Matrix.scaleReal (1/2) a)) + (Fn.sqrt (Fn.expRealHermitian a)) + +type UnitUpperTriangularP pack sh = + ArrMatrix.Quadratic pack + MatrixShape.Unit MatrixShape.Empty MatrixShape.Filled sh + +expLogUnipotent :: + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + UnitUpperTriangularP pack ShapeInt a -> Bool +expLogUnipotent a = + approxMatrix (selectReal 1e-2 1e-6) + (Triangular.relaxUnitDiagonal a) + (Fn.exp (Fn.logUnipotentUpper a)) + +expLogHermitian :: + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + HermitianP pack ShapeInt a -> Bool +expLogHermitian a = + approxMatrix (selectReal 1e-2 1e-6) a (Fn.log (Fn.exp a)) + + +genPositiveDiagonalizable :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.MatrixInt a (Square ShapeInt a) +genPositiveDiagonalizable = flip Gen.mapQC Gen.invertible $ \a -> do + d <- Util.genDistinct [1..10] [1..10] (Square.size a) + return $ a #\## d \*# a + +genPositiveDistinctTriangular :: + (Layout.Packing pack, MatrixShape.DiagUpLo lo up) => + (Class.Real a, RealOf a ~ ar, Class.Real ar) => + (Quadratic pack MatrixShape.Arbitrary lo up ShapeInt ~ matrix) => + PowerStrip lo up -> + Layout.PackingSingleton pack -> + Gen.MatrixInt a (matrix a) +genPositiveDistinctTriangular cont p = + flip Gen.mapQC (genTriangular cont Arbitrary p) $ \a -> do + d <- Util.genDistinct [1..10] [1..10] (Quadratic.size a) + return $ a #+# diagonal (ArrMatrix.order a) (d |-| Matrix.takeDiagonal a) + +expLog :: + (Fn.Exp property, Fn.Log property) => + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Layout.Packing pack, Class.Real a, RealOf a ~ a) => + Quadratic pack property lower upper ShapeInt a -> Bool +expLog a = approxMatrix (selectReal 10 1e-6) a (Fn.exp (Fn.log a)) + + +genCoefficient :: (Class.Floating a) => QC.Gen a +genCoefficient = + Class.switchFloating + (QC.choose (-1,1)) + (QC.choose (-1,1)) + (liftA2 (:+) (QC.choose (-1,1)) (QC.choose (-1,1))) + (liftA2 (:+) (QC.choose (-1,1)) (QC.choose (-1,1))) + + +checkForAll :: + (Show a, QC.Testable test) => + Gen.T dim tag a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 2 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test) => + QC.Gen a -> Gen.T dim tag b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +testsVar :: + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + [(String, Tagged a QC.Property)] +testsVar = + ("Square.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + Gen.square (expSum (.*#))) : + ("Square.expTrace", + checkForAll Gen.square expTrace) : + concat + (List.transpose + [Util.suffix "Packed" (testsVarPacking Layout.Packed), + Util.suffix "Unpacked" (testsVarPacking Layout.Unpacked)]) + +testsVarPacking :: + (Layout.Packing pack) => + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsVarPacking p = + ("Hermitian.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + (genHermitian p) (expSum Matrix.scaleReal)) : + ("Symmetric.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + (genSymmetric p) (expSum (.*#))) : + ("Diagonal.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + (genTriangular Diagonal Arbitrary p) (expSum (.*#))) : + ("LowerTriangular.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + (genTriangular Lower Arbitrary p) (expSum (.*#))) : + ("UpperTriangular.expSum", + checkForAllExtra + (liftA2 (,) genCoefficient genCoefficient) + (genTriangular Upper Arbitrary p) (expSum (.*#))) : + + ("Hermitian.expTrace", + checkForAll (genHermitian p) expTrace) : + ("Symmetric.expTrace", + checkForAll (genSymmetric p) expTrace) : + ("Diagonal.expTrace", + checkForAll (genTriangular Diagonal Arbitrary p) expTrace) : + ("LowerTriangular.expTrace", + checkForAll (genTriangular Lower Arbitrary p) expTrace) : + ("UpperTriangular.expTrace", + checkForAll (genTriangular Upper Arbitrary p) expTrace) : + [] + + +testsReal :: + (Show a, Class.Floating a, Eq a, RealOf a ~ a, Class.Real a) => + [(String, Tagged a QC.Property)] +testsReal = + ("Square.sqrSqrt", + checkForAll genPositiveSpectrum (sqrSqrt Fn.sqrt)) : + ("Square.sqrSqrt.DenmanBeavers", + checkForAll genPositiveSpectrum (sqrSqrt Fn.sqrtDenmanBeavers)) : +{- FixMe: +Schur decomposition seems to produce 2x2 diagonal blocks +even for an entirely real set of eigenvalues. + ("Square.sqrSqrt.Schur", + checkForAll genPositiveSpectrum (sqrSqrt Fn.sqrtSchur)) : +-} + ("expLog", + checkForAll genPositiveDiagonalizable expLog) : + concat + (List.transpose + [Util.suffix "Packed" (testsRealPacking Layout.Packed), + Util.suffix "Unpacked" (testsRealPacking Layout.Unpacked)]) + +testsRealPacking :: + (Layout.Packing pack) => + (Show a, Class.Floating a, Eq a, RealOf a ~ a, Class.Real a) => + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsRealPacking p = + ("Symmetric.sqrSqrt", + checkForAll (Symmetric.fromHermitian <$> genPositiveHermitian p) + (sqrSqrt Fn.sqrt)) : + ("Symmetric.sqrSqrt.DenmanBeavers", + checkForAll (Symmetric.fromHermitian <$> genPositiveHermitian p) + (sqrSqrt Fn.sqrtDenmanBeavers)) : + ("Symmetric.sqrtSqr", + checkForAll (Symmetric.fromHermitian <$> genPositiveHermitian p) + (sqrtSqr Fn.sqrt)) : + + ("Hermitian.expSqrt", + checkForAll (genHermitian p) expSqrtHermitian) : + ("Symmetric.expSqrt", + checkForAll (genSymmetric p) (expSqrt Fn.sqrt)) : + ("Symmetric.expSqrt.DenmanBeavers", + checkForAll (genSymmetric p) + (expSqrt Fn.sqrtDenmanBeavers)) : + + ("UpperTriangular.expLogUnipotent", + checkForAll (genTriangular Upper Unit p) expLogUnipotent) : + ("UpperTriangular.expLogHermitian", + checkForAll (genHermitian p) expLogHermitian) : + + Util.prefix "Diagonal" (testsRealPowerStrip Diagonal p) ++ + Util.prefix "Lower" (testsRealPowerStrip Lower p) ++ + Util.prefix "Upper" (testsRealPowerStrip Upper p) ++ + [] + +testsRealPowerStrip :: + (Layout.Packing pack) => + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up) => + (Show a, Class.Floating a, Eq a, RealOf a ~ a, Class.Real a) => + PowerStrip lo up -> + Layout.PackingSingleton pack -> + [(String, Tagged a QC.Property)] +testsRealPowerStrip cont p = + ("Unit.sqrSqrt", + checkForAll (genPositiveTriangular cont Unit p) (sqrSqrt Fn.sqrt)) : + ("Arbitrary.sqrSqrt", + checkForAll (genPositiveTriangular cont Arbitrary p) (sqrSqrt Fn.sqrt)) : + ("sqrSqrt.DenmanBeavers", + checkForAll (genPositiveTriangular cont Arbitrary p) + (sqrSqrt Fn.sqrtDenmanBeavers)) : + ("Unit.sqrtSqr", + checkForAll (genPositiveTriangular cont Unit p) (sqrtSqr Fn.sqrt)) : + ("Arbitrary.sqrtSqr", + checkForAll (genPositiveTriangular cont Arbitrary p) (sqrtSqr Fn.sqrt)) : + ("expSqrt", + checkForAll (genTriangular cont Arbitrary p) (expSqrt Fn.sqrt)) : + ("expSqrt.DenmanBeavers", + checkForAll (genTriangular cont Arbitrary p) + (expSqrt Fn.sqrtDenmanBeavers)) : + ("expLog", + checkForAll (genPositiveDistinctTriangular cont p) expLog) : + [] diff --git a/test/Test/Generator.hs b/test/Test/Generator.hs --- a/test/Test/Generator.hs +++ b/test/Test/Generator.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ConstraintKinds #-} module Test.Generator where import qualified Test.Logic as Logic @@ -13,18 +14,18 @@ import qualified UniqueLogic.ST.TF.System.Simple as Sys import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Square as Square import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Hermitian (Hermitian) import Numeric.LAPACK.Matrix (ShapeInt) import Numeric.LAPACK.Scalar (RealOf, fromReal, one) import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import qualified Control.Monad.Trans.RWS as MRWS import qualified Control.Monad.Trans.Writer as MW @@ -148,10 +149,17 @@ mapGenDim f (Base gen) = Cons $ do (maxDim, _matchMode) <- MT.lift $ Logic.M MRWS.ask - mapSnd (fmap (\a -> MR.ReaderT $ \maxElem -> f maxElem maxDim a)) - <$> gen + flip fmap gen $ mapSnd $ fmap $ \a -> + MR.ReaderT $ \maxElem -> f maxElem maxDim a +mapQCDim :: (Integer -> Int -> a -> QC.Gen b) -> T dim elem a -> T dim elem b +mapQCDim f (Cons gen) = + Cons $ do + (maxDim, _matchMode) <- MT.lift $ Logic.M MRWS.ask + flip fmap gen $ mapSnd $ fmap $ \meQCGen -> + meQCGen >>= \a -> MR.ReaderT $ \maxElem -> f maxElem maxDim a + constrain :: (forall s. TaggedVariables s dim -> Logic.System s) -> Base dim a -> Base dim a @@ -274,7 +282,7 @@ (<+++>) :: Vector sizeA elem (a -> b) -> Vector sizeB elem a -> - Vector (sizeA:+:sizeB) elem b + Vector (sizeA::+sizeB) elem b (<+++>) = combineM (\sizeA sizeB -> newVariableWith $ sizeA!+!sizeB) @@ -307,7 +315,10 @@ (Class.Floating a) => MatrixInt a (Matrix.General ShapeInt ShapeInt a) matrixInt = matrix +asMatrixInt :: MatrixInt a matrix -> MatrixInt a matrix +asMatrixInt = id + listOf :: (NonEmptyC.Gen f) => (forall s. TaggedVariables s dim -> Logic.M s size) -> @@ -351,27 +362,32 @@ MatrixInt a (Square.Square ShapeInt a) invertible = condition Util.invertible square -diagonal :: (Class.Floating a) => MatrixInt a (Triangular.Diagonal ShapeInt a) +diagonal :: (Class.Floating a) => MatrixInt a (Matrix.Diagonal ShapeInt a) diagonal = mapGen Util.genArray $ shapeFromDims MatrixShape.diagonal squareDim identity :: - (MatrixShape.Content lo, MatrixShape.Content up, Class.Floating a) => - MatrixInt a (Triangular.Triangular lo MatrixShape.Unit up ShapeInt a) -identity = fromBase $ return <$> shapeFromDims Triangular.identity squareDim + (Omni.Quadratic MatrixShape.Packed ~ quadratic, + quadratic diag lo up, quadratic diag up lo, Class.Floating a) => + MatrixInt a (Matrix.Triangular lo diag up ShapeInt a) +identity = + fromBase $ return <$> shapeFromDims Triangular.identityOrder squareDim +triangularIdentity :: + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, + Class.Floating a) => + MatrixInt a (Matrix.Triangular lo diag up ShapeInt a) +triangularIdentity = + fromBase $ return . Matrix.identityFromShape <$> triangularShape + triangularShape :: - (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, - Dim sh) => + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Dim sh) => SquareBase sh (MatrixShape.Triangular lo diag up sh) -triangularShape = - shapeFromDims - (MatrixShape.Triangular MatrixShape.autoDiag MatrixShape.autoUplo) - squareDim +triangularShape = shapeFromDims MatrixShape.triangular squareDim triangular :: - (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, Class.Floating a) => - Square sh a (Triangular.Triangular lo diag up sh a) + Square sh a (Matrix.Triangular lo diag up sh a) triangular = mapGen genTriangularArray triangularShape @@ -379,29 +395,33 @@ GenTriangularDiag { runGenTriangularDiag :: MatrixShape.Triangular lo diag up sh -> - QC.Gen (Triangular.Triangular lo diag up sh a) + QC.Gen (Matrix.Triangular lo diag up sh a) } genTriangularArray :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, Class.Floating a) => Integer -> MatrixShape.Triangular lo diag up sh -> - QC.Gen (Triangular.Triangular lo diag up sh a) + QC.Gen (Matrix.Triangular lo diag up sh a) genTriangularArray maxElem = runGenTriangularDiag $ - MatrixShape.switchTriDiag + Omni.switchTriDiag (GenTriangularDiag $ \shape -> Util.genArrayExtraDiag maxElem shape (const $ return one)) (GenTriangularDiag $ Util.genArray maxElem) -tallShape :: MatrixBase ShapeInt ShapeInt (MatrixShape.Tall ShapeInt ShapeInt) +tallShape :: + (Logic.DimInclZero width) => + MatrixBase ShapeInt width (MatrixShape.Tall ShapeInt width) tallShape = shapeFromDims (uncurry . MatrixShape.tall) $ constrain (uncurry $ flip ( MatrixInt a (Matrix.Tall ShapeInt ShapeInt a) +tall :: + (Logic.DimInclZero width, Class.Floating a) => + Matrix ShapeInt width a (Matrix.Tall ShapeInt width a) tall = mapGen Util.genArray tallShape fullRankTall :: @@ -410,7 +430,9 @@ fullRankTall = condition Util.fullRankTall tall -wide :: (Class.Floating a) => MatrixInt a (Matrix.Wide ShapeInt ShapeInt a) +wide :: + (Logic.DimInclZero height, Class.Floating a) => + Matrix height ShapeInt a (Matrix.Wide height ShapeInt a) wide = Matrix.transpose <$> transpose tall fullRankWide :: @@ -419,20 +441,23 @@ fullRankWide = Matrix.transpose <$> transpose fullRankTall +symmetric :: (Dim sh, Class.Floating a) => Square sh a (Matrix.Symmetric sh a) +symmetric = mapGen Util.genArray $ shapeFromDims MatrixShape.symmetric squareDim + hermitian :: (Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Square sh a (Hermitian sh a) + Square sh a (Matrix.Hermitian sh a) hermitian = flip mapGen (shapeFromDims MatrixShape.hermitian squareDim) $ \maxElem shape -> - Util.genArrayExtraDiag maxElem shape + Util.genArrayExtraDiag_ maxElem Omni.toPlain shape (const $ fromReal <$> Util.genReal maxElem) lscStack :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Matrix (ShapeInt:+:ShapeInt) ShapeInt a - (Matrix.Tall (ShapeInt:+:ShapeInt) ShapeInt a) + Matrix (ShapeInt::+ShapeInt) ShapeInt a + (Matrix.Tall (ShapeInt::+ShapeInt) ShapeInt a) lscStack = condition (Util.fullRankTall . Matrix.transpose . @@ -528,7 +553,7 @@ (Dim width, Eq width) => Matrix heightA width elem (a -> b) -> Matrix heightB width elem a -> - Matrix (heightA:+:heightB) width elem b + Matrix (heightA::+heightB) width elem b (<===>) = combineM (\(heightA,widthA) (heightB,widthB) -> do @@ -540,7 +565,7 @@ (Dim height, Eq height) => Matrix height widthA elem (a -> b) -> Matrix height widthB elem a -> - Matrix height (widthA:+:widthB) elem b + Matrix height (widthA::+widthB) elem b (<|||>) f a = transpose $ transpose f <===> transpose a @@ -550,7 +575,7 @@ (Dim widthB, Eq widthB) => Matrix heightA widthA elem a -> Matrix heightB widthB elem c -> - Matrix (heightA:+:heightB) (widthA:+:widthB) elem (a,c) + Matrix (heightA::+heightB) (widthA::+widthB) elem (a,c) stackDiagonal genA = combineM (\(heightA,widthA) (heightB,widthB) -> do @@ -565,7 +590,7 @@ Matrix heightA widthA elem a -> Matrix heightA widthB elem b -> Matrix heightB widthB elem c -> - Matrix (heightA:+:heightB) (widthA:+:widthB) elem (a,b,c) + Matrix (heightA::+heightB) (widthA::+widthB) elem (a,b,c) stack3 genA = combine3M (\(heightA,widthA) (heightA0,widthB0) (heightB,widthB) -> do diff --git a/test/Test/Generic.hs b/test/Test/Generic.hs --- a/test/Test/Generic.hs +++ b/test/Test/Generic.hs @@ -4,10 +4,11 @@ import qualified Test.Generator as Gen import qualified Test.Logic as Logic import Test.Generator ((<#*|>), (<#=#>)) -import Test.Utility (approxVector) +import Test.Utility (approxVector, equalArray) import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix as Matrix import Numeric.LAPACK.Matrix.Array (ArrayMatrix) import Numeric.LAPACK.Matrix (ShapeInt, (#*|), (#+#), (#-#)) @@ -22,31 +23,53 @@ forceOrder :: - (ArrMatrix.ShapeOrder shape, ArrMatrix.MultiplyVector shape, - MatrixShape.HeightOf shape ~ height, Shape.C height, Eq height, - MatrixShape.WidthOf shape ~ width, width ~ ShapeInt, + (MatrixShape.Packing pack, MatrixShape.Property property, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, width ~ ShapeInt, Class.Floating a, RealOf a ~ ar, Class.Real ar) => MatrixShape.Order -> - (ArrayMatrix shape a, Vector width a) -> Bool + (ArrayMatrix pack property lower upper meas vert horiz height width a, + Vector width a) -> + Bool forceOrder order (a,x) = let ao = Matrix.forceOrder order a - in ArrMatrix.shapeOrder (ArrMatrix.shape ao) == order + in ArrMatrix.order ao == order && approxVector (a #*| x) (ao #*| x) +forceOrderInverse :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, width ~ ShapeInt, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool +forceOrderInverse a = + let order = ArrMatrix.order a + in equalArray a $ + Matrix.forceOrder order $ + Matrix.forceOrder (MatrixShape.flipOrder order) a + +genDistribution2 :: + (Logic.Dim height, Eq height, Logic.Dim width, Eq width, Class.Floating a) => + Gen.Matrix height width a matrixPair -> + Gen.Vector height a (matrixPair, Vector width a) +genDistribution2 genPair = (,) <$> genPair <#*|> Gen.vector + genDistribution :: (Logic.Dim height, Eq height, Logic.Dim width, Eq width, Class.Floating a) => Gen.Matrix height width a matrix -> Gen.Vector height a ((matrix, matrix), Vector width a) -genDistribution gen = (,) <$> ((,) <$> gen <#=#> gen) <#*|> Gen.vector +genDistribution gen = genDistribution2 ((,) <$> gen <#=#> gen) addDistributive, subDistributive :: - (ArrMatrix.Additive shape, ArrMatrix.MultiplyVector shape, - MatrixShape.HeightOf shape ~ height, Shape.C height, Eq height, - MatrixShape.WidthOf shape ~ width, width ~ ShapeInt, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ((ArrayMatrix shape a, ArrayMatrix shape a), Vector width a) -> - Bool + (MatrixShape.Packing pack, ArrMatrix.Subtractive property, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Eq height, width ~ ShapeInt, + Class.Floating a, RealOf a ~ ar, Class.Real ar, + ArrayMatrix pack property lower upper meas vert horiz height width a ~ + matrix) => + ((matrix, matrix), Vector width a) -> Bool addDistributive ((a,b),x) = approxVector ((a#+#b) #*| x) (a#*|x |+| b#*|x) subDistributive ((a,b),x) = approxVector ((a#-#b) #*| x) (a#*|x |-| b#*|x) diff --git a/test/Test/Hermitian.hs b/test/Test/Hermitian.hs --- a/test/Test/Hermitian.hs +++ b/test/Test/Hermitian.hs @@ -1,17 +1,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Test.Hermitian (testsVar) where +{-# LANGUAGE GADTs #-} +module Test.Hermitian (testsVar, genHermitian) where +import qualified Test.Mosaic as Mosaic import qualified Test.Divide as Divide -import qualified Test.Multiply as Multiply import qualified Test.Generic as Generic import qualified Test.Indexed as Indexed import qualified Test.Generator as Gen +import qualified Test.Logic as Logic import qualified Test.Utility as Util +import Test.Mosaic (repack) import Test.Generator ((<-*#>), (<#*|>), (<.*#>), (<#*#>), (<#\#>), (<#=#>)) import Test.Utility (approxReal, approxArray, approxArrayTol, approxMatrix, - approxVector, equalArray, Tagged, genOrder, (!===)) + equalArray, Tagged, genOrder, (!===)) import qualified Numeric.LAPACK.Orthogonal.Householder as HH import qualified Numeric.LAPACK.Matrix.HermitianPositiveDefinite as HermitianPD @@ -19,27 +22,30 @@ import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Square as Square import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Hermitian (Hermitian) import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix.Shape (Order) -import Numeric.LAPACK.Matrix - (General, ShapeInt, (#+#), (-*#), (##*#), (#*##), (#*|), (|||)) +import Numeric.LAPACK.Matrix.Layout (Order) +import Numeric.LAPACK.Matrix (General, ShapeInt, (#+#), (|||)) import Numeric.LAPACK.Vector (Vector, (.*|)) import Numeric.LAPACK.Scalar (RealOf, selectReal) import qualified Numeric.Netlib.Class as Class +import qualified Type.Data.Bool as TBool + import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Control.Applicative (liftA2, (<$>)) import qualified Data.NonEmpty.Class as NonEmptyC import qualified Data.NonEmpty as NonEmpty +import qualified Data.List as List import Data.Semigroup ((<>)) import Data.Tuple.HT (uncurry3, mapFst) @@ -47,13 +53,34 @@ +type FlexHermitianP pack neg zero pos sh = + ArrMatrix.FullQuadratic pack (Omni.Hermitian neg zero pos) sh +type HermitianP pack sh = + ArrMatrix.FullQuadratic pack Omni.HermitianUnknownDefiniteness sh +type HermitianPosDefP pack sh = + ArrMatrix.FullQuadratic pack Omni.HermitianPositiveDefinite sh +type HermitianNegDefP pack sh = + ArrMatrix.FullQuadratic pack Omni.HermitianNegativeDefinite sh + +genHermitian :: + (Logic.Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Gen.Square sh a (HermitianP pack sh a) +genHermitian p = repack p <$> Gen.hermitian + generalFromHermitian :: - (Shape.C sh, Class.Floating a) => Hermitian sh a -> General sh sh a + (Layout.Packing pack) => + (TBool.C neg, TBool.C zero, TBool.C pos, + Shape.C sh, Class.Floating a) => + FlexHermitianP pack neg zero pos sh a -> General sh sh a generalFromHermitian = Matrix.fromFull . Hermitian.toSquare stack :: - (Class.Floating a) => - (Hermitian ShapeInt a, General ShapeInt ShapeInt a, Hermitian ShapeInt a) -> + (Layout.Packing pack, Class.Floating a) => + (HermitianP pack ShapeInt a, + General ShapeInt ShapeInt a, + HermitianP pack ShapeInt a) -> Bool stack (a,b,c) = let abc = generalFromHermitian $ Hermitian.stack a b c @@ -62,114 +89,148 @@ !=== Matrix.adjoint b ||| Matrix.fromFull (Hermitian.toSquare c)) -split :: (Class.Floating a) => Hermitian (ShapeInt:+:ShapeInt) a -> Bool +split :: + (Layout.Packing pack, Class.Floating a) => + HermitianP pack (ShapeInt::+ShapeInt) a -> Bool split abc = equalArray abc $ uncurry3 Hermitian.stack $ Hermitian.split abc gramian :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramian x = +gramian pack x = approxArray - (generalFromHermitian $ Hermitian.gramian x) + (generalFromHermitian $ + ArrMatrix.requirePacking pack $ Hermitian.gramian x) (Matrix.adjoint x <> x) gramianAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramianAdjoint x = +gramianAdjoint pack x = approxArray - (generalFromHermitian $ Hermitian.gramianAdjoint x) + (generalFromHermitian $ + ArrMatrix.requirePacking pack $ Hermitian.gramianAdjoint x) (Matrix.adaptOrder x $ x <> Matrix.adjoint x) gramianNonAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramianNonAdjoint x = +gramianNonAdjoint pack x = approxArray - (Matrix.forceOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape x) $ + (Matrix.forceOrder (ArrMatrix.order x) $ Hermitian.gramian $ Matrix.adjoint x) - (Hermitian.gramianAdjoint x) + (ArrMatrix.requirePacking pack $ Hermitian.gramianAdjoint x) congruenceDiagonal :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (Vector ShapeInt ar, General ShapeInt ShapeInt a) -> Bool -congruenceDiagonal (d,a) = +congruenceDiagonal pack (d,a) = approxArray - (generalFromHermitian $ Hermitian.congruenceDiagonal d a) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.congruenceDiagonal d a) (Matrix.adjoint a <> Matrix.scaleRowsReal d a) congruenceDiagonalAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, Vector ShapeInt ar) -> Bool -congruenceDiagonalAdjoint (a,d) = +congruenceDiagonalAdjoint pack (a,d) = approxMatrix 1e-5 - (generalFromHermitian $ Hermitian.congruenceDiagonalAdjoint a d) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.congruenceDiagonalAdjoint a d) (Matrix.scaleColumnsReal d a <> Matrix.adjoint a) congruenceDiagonalGramian :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -congruenceDiagonalGramian a = +congruenceDiagonalGramian pack a = approxArray (Hermitian.congruenceDiagonal (Vector.one $ Matrix.height a) a) - (Hermitian.gramian a) + (Hermitian.relaxIndefinite $ ArrMatrix.requirePacking pack $ + Hermitian.gramian a) congruence :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, General ShapeInt ShapeInt a) -> Bool + (HermitianP pack ShapeInt a, General ShapeInt ShapeInt a) -> Bool congruence (b,a) = approxArray (Hermitian.toSquare $ Hermitian.congruence b a) (Square.congruence (Hermitian.toSquare b) a) congruenceAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (General ShapeInt ShapeInt a, Hermitian ShapeInt a) -> Bool + (General ShapeInt ShapeInt a, HermitianP pack ShapeInt a) -> Bool congruenceAdjoint (a,b) = approxMatrix 1e-5 (Hermitian.toSquare $ Hermitian.congruenceAdjoint a b) (Square.congruenceAdjoint a $ Hermitian.toSquare b) congruenceCongruenceDiagonal :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> (Vector ShapeInt ar, General ShapeInt ShapeInt a) -> Bool -congruenceCongruenceDiagonal order (d,a) = +congruenceCongruenceDiagonal pack order (d,a) = approxArray (Hermitian.congruenceDiagonal d a) - (Hermitian.congruence (Hermitian.diagonal order d) a) + (Hermitian.congruence (repack pack $ Hermitian.diagonal order d) a) anticommutator :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutator (a,b) = +anticommutator pack (a,b) = approxArray - (generalFromHermitian $ Hermitian.anticommutator a b) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.anticommutator a b) ((Matrix.adjoint b <> a) #+# (Matrix.adjoint a <> b)) anticommutatorCommutative :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutatorCommutative (a,b) = +anticommutatorCommutative pack (a,b) = approxMatrix 1e-5 - (Hermitian.anticommutator a b) + (ArrMatrix.requirePacking pack $ + Hermitian.anticommutator a b) (Hermitian.anticommutator b a) anticommutatorAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutatorAdjoint (a,b) = +anticommutatorAdjoint pack (a,b) = approxArray - (Matrix.forceOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape b) $ + (Matrix.forceOrder (ArrMatrix.order b) $ Hermitian.anticommutator (Matrix.adjoint a) (Matrix.adjoint b)) - (Hermitian.anticommutatorAdjoint a b) + (ArrMatrix.requirePacking pack $ Hermitian.anticommutatorAdjoint a b) outer :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> Vector ShapeInt a -> Bool -outer order x = +outer pack order x = approxArray - (generalFromHermitian $ Hermitian.outer order x) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.outer order x) (Matrix.outer order x x) @@ -179,20 +240,26 @@ genScaledVectors = Gen.listOfVector ((,) <$> Gen.scalarReal <.*#> Gen.vector) sumRank1 :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> (ShapeInt, [(ar, Vector ShapeInt a)]) -> Bool -sumRank1 order (sh,xs) = +sumRank1 pack order (sh,xs) = approxArray - (generalFromHermitian $ Hermitian.sumRank1 order sh xs) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.sumRank1 order sh xs) (Util.addMatrices (MatrixShape.general order sh sh) $ fmap (rank1 order) xs) sumRank1NonEmpty :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> NonEmpty.T [] (ar, Vector ShapeInt a) -> Bool -sumRank1NonEmpty order xs = +sumRank1NonEmpty pack order xs = approxArray - (generalFromHermitian $ Hermitian.sumRank1NonEmpty order xs) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.sumRank1NonEmpty order xs) (NonEmpty.foldl1 (ArrMatrix.lift2 Vector.add) $ fmap (rank1 order) xs) rank1 :: @@ -212,20 +279,26 @@ liftA2 (,) (Util.genVector maxElem size) (Util.genVector maxElem size) sumRank2 :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> (ShapeInt, [(a, (Vector ShapeInt a, Vector ShapeInt a))]) -> Bool -sumRank2 order (sh,xys) = +sumRank2 pack order (sh,xys) = approxArray - (generalFromHermitian $ Hermitian.sumRank2 order sh xys) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.sumRank2 order sh xys) (Util.addMatrices (MatrixShape.general order sh sh) $ fmap (rank2 order) xys) sumRank2NonEmpty :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> NonEmpty.T [] (a, (Vector ShapeInt a, Vector ShapeInt a)) -> Bool -sumRank2NonEmpty order xys = +sumRank2NonEmpty pack order xys = approxArray - (generalFromHermitian $ Hermitian.sumRank2NonEmpty order xys) + (generalFromHermitian $ ArrMatrix.requirePacking pack $ + Hermitian.sumRank2NonEmpty order xys) (NonEmpty.foldl1 (ArrMatrix.lift2 Vector.add) $ fmap (rank2 order) xys) rank2 :: @@ -239,114 +312,99 @@ addAdjoint :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Square ShapeInt a -> Bool -addAdjoint x = +addAdjoint pack x = approxArray - (Hermitian.toSquare $ Hermitian.addAdjoint x) + (Hermitian.toSquare $ ArrMatrix.requirePacking pack $ + Hermitian.addAdjoint x) (Matrix.adjoint x #+# x) - -multiplyVectorLeft :: - (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Vector ShapeInt a, Hermitian ShapeInt a) -> Bool -multiplyVectorLeft (x,a) = - approxVector (x -*# Hermitian.toSquare a) (x -*# a) - -multiplyVectorRight :: - (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, Vector ShapeInt a) -> Bool -multiplyVectorRight (a,x) = - approxVector (Hermitian.toSquare a #*| x) (a #*| x) - - -multiplyLeft :: - (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (General ShapeInt ShapeInt a, Hermitian ShapeInt a) -> Bool -multiplyLeft (a,b) = - approxMatrix 1e-5 (a ##*# Hermitian.toSquare b) (a ##*# b) - -multiplyRight :: - (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, General ShapeInt ShapeInt a) -> Bool -multiplyRight (a,b) = - approxArray (Hermitian.toSquare a #*## b) (a #*## b) - - choleskyQR :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Matrix.Tall ShapeInt ShapeInt a -> QC.Property -choleskyQR a = +choleskyQR pack a = let qr = HH.fromMatrix a r = HH.tallExtractR qr in HH.determinantAbsolute qr > 0.1 QC.==> approxArrayTol 1e-1 (Matrix.scaleRows (Array.map signum $ Triangular.takeDiagonal r) $ - Triangular.toSquare r) - (Triangular.toSquare $ - HermitianPD.decompose $ Hermitian.gramian $ Matrix.fromFull a) + Triangular.toSquare r) + (Triangular.toSquare $ HermitianPD.decompose $ + ArrMatrix.requirePacking pack $ gramianPosDef a) +gramianPosDef :: + (Layout.Packing pack, Class.Floating a) => + Matrix.Tall ShapeInt ShapeInt a -> HermitianPosDefP pack ShapeInt a +gramianPosDef = + HermitianPD.assureFullRank . Hermitian.gramian . Matrix.fromFull + genInvertible :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Gen.MatrixInt a (Hermitian ShapeInt a) -genInvertible = Gen.condition Util.invertible Gen.hermitian + Layout.PackingSingleton pack -> + Gen.MatrixInt a (HermitianP pack ShapeInt a) +genInvertible pack = + repack pack <$> Gen.condition Util.invertible Gen.hermitian -inverse :: - (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian ShapeInt a -> Bool -inverse a = - approxArrayTol - (selectReal 1 1e-5) - (Hermitian.toSquare $ Hermitian.inverse a) - (Square.inverse $ Hermitian.toSquare a) -solve :: +genPositiveDefinite :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool -solve (a, b) = - approxMatrix (selectReal 1 1e-5) - (Hermitian.solve a b) - (Square.solve (Hermitian.toSquare a) b) - - + Layout.PackingSingleton pack -> + Gen.MatrixInt a (HermitianPosDefP pack ShapeInt a) +genPositiveDefinite pack = + repack pack . gramianPosDef <$> Gen.gramian Gen.fullRankTall -genPositiveDefinite :: +genNegativeDefinite :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Gen.MatrixInt a (Hermitian ShapeInt a) -genPositiveDefinite = - Hermitian.gramian . Matrix.fromFull <$> Gen.gramian Gen.fullRankTall + Layout.PackingSingleton pack -> + Gen.MatrixInt a (HermitianNegDefP pack ShapeInt a) +genNegativeDefinite pack = + Hermitian.negate <$> genPositiveDefinite pack + determinantPD :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian ShapeInt a -> Bool + HermitianPosDefP pack ShapeInt a -> Bool determinantPD a = - approxReal (selectReal 100 1e-4) - (Hermitian.determinant a) - (HermitianPD.determinant a) + let d = HermitianPD.determinant a + in approxReal + (max (selectReal 1 1e-2) (selectReal 1e-3 1e-5 * abs d)) + d + (Hermitian.determinant $ Hermitian.relaxIndefinite a) inversePD :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian ShapeInt a -> Bool + HermitianPosDefP pack ShapeInt a -> Bool inversePD a = - approxArrayTol (selectReal 1000 1e-4) - (Hermitian.inverse a) - (HermitianPD.inverse a) + Divide.approxRelArray + (Hermitian.inverse $ Hermitian.relaxIndefinite a) + (Hermitian.relaxIndefinite $ HermitianPD.inverse a) solvePD :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + (HermitianPosDefP pack ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> + Bool solvePD (a,b) = - approxArrayTol (selectReal 1000 1e-4) - (Hermitian.solve a b) + Divide.approxRelMatrix + (Hermitian.solve (Hermitian.relaxIndefinite a) b) (HermitianPD.solve a b) solveDecomposedPD :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Hermitian ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + (HermitianPosDefP pack ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> + Bool solveDecomposedPD (a,b) = approxArrayTol (selectReal 1e-1 1e-6) (HermitianPD.solve a b) @@ -355,8 +413,9 @@ eigenvaluesDeterminant :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian ShapeInt a -> Bool + HermitianP pack ShapeInt a -> Bool eigenvaluesDeterminant a = approxReal (selectReal 1e-1 1e-5) @@ -364,8 +423,9 @@ (Vector.product $ Hermitian.eigenvalues a) eigensystem :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Hermitian ShapeInt a -> Bool + HermitianP pack ShapeInt a -> Bool eigensystem a = approxMatrix 1e-4 a $ uncurry Hermitian.congruenceDiagonalAdjoint $ @@ -389,104 +449,134 @@ (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => [(String, Tagged a QC.Property)] testsVar = + concat $ + List.transpose + [Util.suffix "Packed" (testsVarPacking Layout.Packed), + Util.suffix "Unpacked" (testsVarPacking Layout.Unpacked)] + +testsVarPacking :: + (Layout.Packing pack) => + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsVarPacking p = ("index", - checkForAll (Indexed.genMatrixIndex Gen.hermitian) Indexed.unitDot) : + checkForAll (Indexed.genMatrixIndex $ genHermitian p) Indexed.unitDot) : ("forceOrder", checkForAllExtra genOrder - ((,) <$> Gen.hermitian <#*|> Gen.vector) Generic.forceOrder) : + ((,) <$> genHermitian p <#*|> Gen.vector) Generic.forceOrder) : + ("forceOrderInverse", + checkForAll (genHermitian p) Generic.forceOrderInverse) : ("addDistributive", checkForAll - (Generic.genDistribution Gen.hermitian) + (Generic.genDistribution (genHermitian p)) Generic.addDistributive) : ("subDistributive", checkForAll - (Generic.genDistribution Gen.hermitian) + (Generic.genDistribution (genHermitian p)) Generic.subDistributive) : ("stack", - checkForAll (Gen.stack3 Gen.hermitian Gen.matrix Gen.hermitian) stack) : + checkForAll + (Gen.stack3 (genHermitian p) Gen.matrix (genHermitian p)) + stack) : ("split", - checkForAll Gen.hermitian split) : + checkForAll (genHermitian p) split) : + ("gramian", - checkForAll Gen.matrix gramian) : + checkForAll Gen.matrix (gramian p)) : ("gramianAdjoint", - checkForAll Gen.matrix gramianAdjoint) : + checkForAll Gen.matrix (gramianAdjoint p)) : ("gramianNonAdjoint", - checkForAll Gen.matrix gramianNonAdjoint) : + checkForAll Gen.matrix (gramianNonAdjoint p)) : ("congruenceDiagonal", - checkForAll ((,) <$> Gen.vectorReal <-*#> Gen.matrix) congruenceDiagonal) : + checkForAll + ((,) <$> Gen.vectorReal <-*#> Gen.matrix) + (congruenceDiagonal p)) : ("congruence", - checkForAll ((,) <$> Gen.hermitian <#*#> Gen.matrix) congruence) : + checkForAll + ((,) <$> genHermitian p <#*#> Gen.matrix) + congruence) : ("congruenceDiagonalAdjoint", checkForAll - ((,) <$> Gen.matrix <#*|> Gen.vectorReal) congruenceDiagonalAdjoint) : + ((,) <$> Gen.matrix <#*|> Gen.vectorReal) + (congruenceDiagonalAdjoint p)) : ("congruenceDiagonalGramian", - checkForAll Gen.matrix congruenceDiagonalGramian) : + checkForAll Gen.matrix (congruenceDiagonalGramian p)) : ("congruenceAdjoint", - checkForAll ((,) <$> Gen.matrix <#*#> Gen.hermitian) congruenceAdjoint) : + checkForAll + ((,) <$> Gen.matrix <#*#> genHermitian p) + congruenceAdjoint) : ("congruenceCongruenceDiagonal", checkForAllExtra genOrder - ((,) <$> - Gen.vectorReal <-*#> Gen.matrix) congruenceCongruenceDiagonal) : + ((,) <$> Gen.vectorReal <-*#> Gen.matrix) + (congruenceCongruenceDiagonal p)) : ("anticommutator", - checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) anticommutator) : + checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) + (anticommutator p)) : ("anticommutatorCommutative", checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) - anticommutatorCommutative) : + (anticommutatorCommutative p)) : ("anticommutatorAdjoint", - checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) anticommutatorAdjoint) : + checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) + (anticommutatorAdjoint p)) : ("outer", - checkForAllExtra genOrder Gen.vector outer) : + checkForAllExtra genOrder Gen.vector (outer p)) : ("sumRank1", - checkForAllExtra genOrder genScaledVectors sumRank1) : + checkForAllExtra genOrder genScaledVectors (sumRank1 p)) : ("sumRank1NonEmpty", - checkForAllExtra genOrder (snd <$> genScaledVectors) sumRank1NonEmpty) : + checkForAllExtra genOrder + (snd <$> genScaledVectors) (sumRank1NonEmpty p)) : ("sumRank2", - checkForAllExtra genOrder genScaledVectorPairs sumRank2) : + checkForAllExtra genOrder genScaledVectorPairs (sumRank2 p)) : ("sumRank2NonEmpty", checkForAllExtra genOrder - (snd <$> genScaledVectorPairs) sumRank2NonEmpty) : + (snd <$> genScaledVectorPairs) (sumRank2NonEmpty p)) : ("addAdjoint", - checkForAll Gen.square addAdjoint) : - ("multiplySquare", - checkForAll Gen.hermitian Multiply.multiplySquare) : - ("squareSquare", - checkForAll Gen.hermitian Multiply.squareSquare) : - ("power", - checkForAllExtra (QC.choose (0,10)) Gen.hermitian Multiply.power) : + checkForAll Gen.square (addAdjoint p)) : - ("multiplyVectorLeft", - checkForAll ((,) <$> Gen.vector <-*#> Gen.hermitian) multiplyVectorLeft) : - ("multiplyVectorRight", - checkForAll ((,) <$> Gen.hermitian <#*|> Gen.vector) multiplyVectorRight) : - ("multiplyLeft", - checkForAll ((,) <$> Gen.matrix <#*#> Gen.hermitian) multiplyLeft) : - ("multiplyRight", - checkForAll ((,) <$> Gen.hermitian <#*#> Gen.matrix) multiplyRight) : + Mosaic.testsVar Mosaic.Hermitian p ++ ("determinant", - checkForAll Gen.hermitian Divide.determinant) : + checkForAll (genHermitian p) Divide.determinant) : ("choleskyQR", - checkForAll Gen.tall choleskyQR) : + checkForAll Gen.tall (choleskyQR p)) : - ("inverse", - checkForAll genInvertible inverse) : ("solve", - checkForAll ((,) <$> genInvertible <#\#> Gen.matrix) solve) : - Divide.testsVar genInvertible ++ + checkForAll + ((,) <$> genInvertible p <#\#> Gen.matrix) + Divide.solve) : + ("solveIdentity", + checkForAll + ((,) <$> + (repack p <$> Gen.identity `asTypeOf` Gen.hermitian) + <#\#> Gen.matrix) + Divide.solveIdentity) : + ("inverse", + checkForAll (genInvertible p) Divide.inverse) : + Divide.testsVar (genInvertible p) ++ ("determinantPD", - checkForAll genPositiveDefinite determinantPD) : + checkForAll (genPositiveDefinite p) determinantPD) : + ("determinantND", + checkForAll (genNegativeDefinite p) Divide.determinant) : ("inversePD", - checkForAll genPositiveDefinite inversePD) : + checkForAll (genPositiveDefinite p) inversePD) : + ("inverseND", + checkForAll (genNegativeDefinite p) Divide.inverse) : ("solvePD", - checkForAll ((,) <$> genPositiveDefinite <#\#> Gen.matrix) solvePD) : + checkForAll ((,) <$> genPositiveDefinite p <#\#> Gen.matrix) solvePD) : + ("solveND", + checkForAll + ((,) <$> genNegativeDefinite p <#\#> Gen.matrix) Divide.solve) : ("solveDecomposedPD", checkForAll - ((,) <$> genPositiveDefinite <#\#> Gen.matrix) solveDecomposedPD) : + ((,) <$> genPositiveDefinite p <#\#> Gen.matrix) + solveDecomposedPD) : + Util.suffix "PD" (Divide.testsVar (genPositiveDefinite p)) ++ + Util.suffix "ND" (Divide.testsVar (genNegativeDefinite p)) ++ ("eigenvaluesDeterminant", - checkForAll Gen.hermitian eigenvaluesDeterminant) : + checkForAll (genHermitian p) eigenvaluesDeterminant) : ("eigensystem", - checkForAll Gen.hermitian eigensystem) : + checkForAll (genHermitian p) eigensystem) : [] diff --git a/test/Test/Indexed.hs b/test/Test/Indexed.hs --- a/test/Test/Indexed.hs +++ b/test/Test/Indexed.hs @@ -4,6 +4,8 @@ import qualified Test.Generator as Gen import Test.Utility (NonEmptyInt) +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix (Matrix, (#!), (#*|)) @@ -30,19 +32,25 @@ genMatrixIndex :: (Matrix.Indexed typ, - Matrix.HeightOf typ ~ height, Shape.Indexed height, - Matrix.WidthOf typ ~ width, Shape.Indexed width, - Class.Floating a) => - GenMatrixNonEmpty a (Matrix typ a) -> - GenMatrixNonEmpty a (Shape.Index (height,width), Matrix typ a) + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Shape.Indexed width, Class.Floating a) => + GenMatrixNonEmpty a + (Matrix typ xl xu lower upper meas vert horiz height width a) -> + GenMatrixNonEmpty a + (Shape.Index (height,width), + Matrix typ xl xu lower upper meas vert horiz height width a) genMatrixIndex = genMatrixIndexGen Matrix.indices unitDot :: - (Matrix.Indexed typ, Matrix.MultiplyVector typ, - Matrix.HeightOf typ ~ height, Shape.Indexed height, Eq height, - Matrix.WidthOf typ ~ width, Shape.Indexed width, Eq width, + (Matrix.Indexed typ, Matrix.MultiplyVector typ xl xu, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.Indexed height, Eq height, + Shape.Indexed width, Eq width, Class.Floating a, Eq a) => - (Shape.Index (height,width), Matrix typ a) -> Bool + (Shape.Index (height,width), + Matrix typ xl xu lower upper meas vert horiz height width a) -> + Bool unitDot ((i,j),m) = m#!(i,j) == Vector.unit (Matrix.height m) i -*| diff --git a/test/Test/Logic.hs b/test/Test/Logic.hs --- a/test/Test/Logic.hs +++ b/test/Test/Logic.hs @@ -14,12 +14,12 @@ import Data.STRef (newSTRef, writeSTRef, readSTRef) import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) import qualified Control.Monad.Trans.Class as MT import qualified Control.Monad.Trans.RWS as MRWS import Control.Monad.ST (ST, runST) -import Control.Applicative (Applicative, liftA2, (<$>)) +import Control.Applicative (Applicative, liftA2, pure, (<$>)) import qualified Data.Monoid.Applicative as AppMn import Data.Semigroup ((<>)) @@ -82,11 +82,21 @@ (a -> f b) -> Shape.ZeroBased a -> f (Shape.ZeroBased b) liftZeroBased f (Shape.ZeroBased x) = Shape.ZeroBased <$> f x -( Variable s ShapeInt -> System s -va choose (\ maxk -> (a,maxk))) va vb - assignmentM (liftZeroBased $ \b -> choose (\_maxk -> (0,b))) vb va +class (Dim dim) => DimInclZero dim where + ( Variable s ShapeInt -> System s +instance (n ~ Int) => DimInclZero (Shape.ZeroBased n) where + va choose (\ maxk -> (a,maxk))) va vb + assignmentM (liftZeroBased $ \b -> choose (\_maxk -> (0,b))) vb va + +instance DimInclZero Shape.Zero where + va Shape.ZeroBased <$> choose (\maxk -> (0,maxk))) + va vb + Sys.runApply (pure Shape.Zero) va + {- We cannot split this into something like @@ -94,20 +104,20 @@ because the solver might choose in this order -a+b=6:+:4 +a+b=6::+4 c=5 and then it is left with a>c from which it cannot recover. -} -between :: Variable s (ShapeInt:+:ShapeInt) -> Variable s ShapeInt -> System s +between :: Variable s (ShapeInt::+ShapeInt) -> Variable s ShapeInt -> System s between vab vc = AppMn.Cons $ do assignmentM - (\(Shape.ZeroBased a :+: Shape.ZeroBased b) -> + (\(Shape.ZeroBased a ::+ Shape.ZeroBased b) -> Shape.ZeroBased <$> choose (\_maxk -> (a,a+b))) vab vc assignmentM (\(Shape.ZeroBased c) -> - liftA2 (:+:) + liftA2 (::+) (Shape.ZeroBased <$> choose (\_maxk -> (0,c))) (Shape.ZeroBased <$> choose (\ maxk -> (c,maxk)))) vc vab @@ -116,14 +126,14 @@ class (Shape.C dim) => Dim dim where chooseDim :: M s dim instance (i ~ Int) => Dim (Shape.ZeroBased i) where chooseDim = fmap Shape.ZeroBased $ choose ((,) 0) +instance Dim Shape.Zero where chooseDim = return Shape.Zero instance Dim () where chooseDim = return () instance (Dim dimA, Dim dimB) => Dim (dimA,dimB) where chooseDim = liftA2 (,) chooseDim chooseDim -instance (Dim dimA, Dim dimB) => Dim (dimA:+:dimB) where - chooseDim = liftA2 (:+:) chooseDim chooseDim +instance (Dim dimA, Dim dimB) => Dim (dimA::+dimB) where + chooseDim = liftA2 (::+) chooseDim chooseDim -(=!=) :: - (Dim dim, Eq dim) => Variable s dim -> Variable s dim -> System s +(=!=) :: (Dim dim, Eq dim) => Variable s dim -> Variable s dim -> System s va =!= vb = AppMn.Cons $ do let equalM = assignmentM $ \x -> do @@ -143,11 +153,11 @@ (!+!) :: - Variable s dimA -> Variable s dimB -> Variable s (dimA:+:dimB) -> System s + Variable s dimA -> Variable s dimB -> Variable s (dimA::+dimB) -> System s (!+!) va vb vab = AppMn.Cons $ do - Sys.assignment3 (:+:) va vb vab - Sys.assignment2 (\(a:+:_) -> a) vab va - Sys.assignment2 (\(_:+:b) -> b) vab vb + Sys.assignment3 (::+) va vb vab + Sys.assignment2 (\(a::+_) -> a) vab va + Sys.assignment2 (\(_::+b) -> b) vab vb (!*!) :: Variable s dimA -> Variable s dimB -> Variable s (dimA,dimB) -> System s diff --git a/test/Test/LowerUpper.hs b/test/Test/LowerUpper.hs --- a/test/Test/LowerUpper.hs +++ b/test/Test/LowerUpper.hs @@ -4,6 +4,7 @@ import qualified Test.Divide as Divide import qualified Test.Generator as Gen import qualified Test.Utility as Util +import Test.Permutation (genPermMatrix) import Test.Generator ((<#\#>), (<#*#>)) import Test.Utility (Tagged, approx, approxMatrix, maybeConjugate) @@ -46,6 +47,11 @@ approxMatrix 1e-5 a (LU.toMatrix $ LU.fromMatrix a) +permutation :: (Class.Floating a) => PermMatrix.Permutation ShapeInt a -> Bool +permutation perm = + perm == + (LU.extractP Perm.NonInverted $ LU.fromMatrix $ PermMatrix.toSquare perm) + multiplyPApply :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => (LU.Inversion, LU.Inversion) -> @@ -58,7 +64,8 @@ multiplyP :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - LU.Inversion -> (Square ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + LU.Inversion -> + (Square ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool multiplyP inv (a,b) = let lu = LU.fromMatrix a in approxMatrix (selectReal 1e-1 1e-5) @@ -180,6 +187,8 @@ checkForAll Gen.fullRankTall toFromTallMatrix) : ("toFromSquareMatrix", checkForAll Gen.invertible toFromSquareMatrix) : + ("permutation", + checkForAll genPermMatrix permutation) : ("multiplyPApply", checkForAllExtra (liftA2 (,) QC.arbitraryBoundedEnum QC.arbitraryBoundedEnum) diff --git a/test/Test/Matrix.hs b/test/Test/Matrix.hs --- a/test/Test/Matrix.hs +++ b/test/Test/Matrix.hs @@ -12,7 +12,7 @@ import Test.Utility (equalArray, approx, approxArray, approxMatrix, approxVector, equalVector, genOrder, - Tagged(Tagged), TaggedGen, NonEmptyInt, EInt, (!|||), (!===)) + Tagged, NonEmptyInt, EInt, (!|||), (!===)) import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Square as Square @@ -22,9 +22,9 @@ import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix.Array (ArrayMatrix) import Numeric.LAPACK.Matrix - (General, ShapeInt, shapeInt, (##*#), (#*#), (#*##), (#*|), (|||), (===)) + (General, ShapeInt, shapeInt, + (##*#), (#*#), (#*##), (#*|), (|||), (===)) import Numeric.LAPACK.Vector (Vector, (.*|)) import Numeric.LAPACK.Scalar (RealOf, conjugate) @@ -33,7 +33,7 @@ import qualified Data.Array.Comfort.Boxed as BoxedArray import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import qualified Control.Monad.Trans.Reader as MR import qualified Control.Functor.HT as FuncHT @@ -44,11 +44,6 @@ import qualified Test.QuickCheck as QC -genArray :: - (Shape.C shape, Class.Floating a) => shape -> QC.Gen (ArrayMatrix shape a) -genArray = Util.genArray 10 - - dotProduct :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => (Vector ShapeInt a, Vector ShapeInt a) -> Bool @@ -92,15 +87,15 @@ tensorProductMul :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular.Diagonal ShapeInt a, + (Matrix.Diagonal ShapeInt a, Matrix.General ShapeInt ShapeInt a, - Triangular.Diagonal ShapeInt a) -> + Matrix.Diagonal ShapeInt a) -> Bool tensorProductMul (x,m,y) = let xmy = (x #*## m) ##*# y in approxArray xmy (ArrMatrix.lift2 Vector.mul m - (Matrix.tensorProduct (MatrixShape.fullOrder $ ArrMatrix.shape xmy) + (Matrix.tensorProduct (ArrMatrix.order xmy) (Triangular.takeDiagonal x) (Triangular.takeDiagonal y))) outerTensorProduct :: @@ -140,7 +135,7 @@ outerTrace order (x,y) = approx 1e-5 (Vector.inner y x) - (Square.trace $ Square.fromGeneral $ Matrix.outer order x y) + (Square.trace $ Square.fromFull $ Matrix.outer order x y) outerInner :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => @@ -155,7 +150,7 @@ MatrixShape.Order -> (Vector ShapeInt a, Vector ShapeInt a) -> Bool tensorTrace order (x,y) = approx 1e-5 (Vector.dot y x) - (Square.trace $ Square.fromGeneral $ Matrix.tensorProduct order x y) + (Square.trace $ Square.fromFull $ Matrix.tensorProduct order x y) tensorDot :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => @@ -202,33 +197,25 @@ (Matrix.toRowMajor $ a #*# b #*# c) -genZeroColumns :: - (Class.Floating a) => TaggedGen a (Matrix.Tall ShapeInt ShapeInt a) -genZeroColumns = Tagged $ do - height <- shapeInt <$> QC.choose (0,5) - order <- genOrder - genArray (MatrixShape.tall order height (shapeInt 0)) - - -reverseNoRows :: (Class.Floating a) => Matrix.Wide ShapeInt ShapeInt a -> Bool -reverseNoRows x = - equalArray x $ Matrix.reverseRows x +reverseNoRows :: + (Class.Floating a) => Matrix.Wide Shape.Zero ShapeInt a -> Bool +reverseNoRows x = equalArray x $ Matrix.reverseRows x -reverseNoColumns :: (Class.Floating a) => Matrix.Tall ShapeInt ShapeInt a -> Bool -reverseNoColumns x = - equalArray x $ Matrix.reverseColumns x +reverseNoColumns :: + (Class.Floating a) => Matrix.Tall ShapeInt Shape.Zero a -> Bool +reverseNoColumns x = equalArray x $ Matrix.reverseColumns x genMatrix2EqHeight :: (Class.Floating a) => - Gen.Matrix ShapeInt (ShapeInt:+:ShapeInt) a + Gen.Matrix ShapeInt (ShapeInt::+ShapeInt) a (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) genMatrix2EqHeight = (,) <$> Gen.matrix <|||> Gen.matrix genMatrix2EqWidth :: (Class.Floating a) => - Gen.Matrix (ShapeInt:+:ShapeInt) ShapeInt a + Gen.Matrix (ShapeInt::+ShapeInt) ShapeInt a (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) genMatrix2EqWidth = (,) <$> Gen.matrix <===> Gen.matrix @@ -342,12 +329,12 @@ stackSplitRows :: - (Class.Floating a) => General (ShapeInt:+:ShapeInt) ShapeInt a -> Bool + (Class.Floating a) => General (ShapeInt::+ShapeInt) ShapeInt a -> Bool stackSplitRows x = equalArray x $ Matrix.takeTop x === Matrix.takeBottom x stackSplitColumns :: - (Class.Floating a) => General ShapeInt (ShapeInt:+:ShapeInt) a -> Bool + (Class.Floating a) => General ShapeInt (ShapeInt::+ShapeInt) a -> Bool stackSplitColumns x = equalArray x $ Matrix.takeLeft x ||| Matrix.takeRight x @@ -376,7 +363,7 @@ Class.Floating a) => BiasMatrix height widthA a -> BiasMatrix height widthB a -> - BiasMatrix height (widthA:+:widthB) a + BiasMatrix height (widthA::+widthB) a (?|||?) = liftA3 (flip Matrix.beside Extent.appendAny) MR.ask (?===?) :: @@ -384,7 +371,7 @@ Class.Floating a) => BiasMatrix heightA width a -> BiasMatrix heightB width a -> - BiasMatrix (heightA:+:heightB) width a + BiasMatrix (heightA::+heightB) width a (?===?) = liftA3 (flip Matrix.above Extent.appendAny) MR.ask runWithOrderBias :: @@ -434,7 +421,7 @@ rowArgAbsMaximums :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - General ShapeInt (():+:ShapeInt) a -> Bool + General ShapeInt (()::+ShapeInt) a -> Bool rowArgAbsMaximums x0 = let x = zeroIntWidth x0 (ixs0,xs0) = Matrix.rowArgAbsMaximums x @@ -446,13 +433,13 @@ multiplyDiagonalMatrix :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular.Diagonal ShapeInt a, General ShapeInt ShapeInt a) -> Bool + (Matrix.Diagonal ShapeInt a, General ShapeInt ShapeInt a) -> Bool multiplyDiagonalMatrix (x,y) = approxArray (x #*## y) (Triangular.toSquare x #*## y) multiplyMatrixDiagonal :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (General ShapeInt ShapeInt a, Triangular.Diagonal ShapeInt a) -> Bool + (General ShapeInt ShapeInt a, Matrix.Diagonal ShapeInt a) -> Bool multiplyMatrixDiagonal (x,y) = approxMatrix 1e-5 (x ##*# y) (x ##*# Triangular.toSquare y) @@ -529,10 +516,9 @@ kronecker3) : ("reverseNoRows", - Util.checkForAllPlain - (fmap Matrix.transpose <$> genZeroColumns) reverseNoRows) : + checkForAll Gen.wide reverseNoRows) : ("reverseNoColumns", - Util.checkForAllPlain genZeroColumns reverseNoColumns) : + checkForAll Gen.tall reverseNoColumns) : ("reverseRows", checkForAll Gen.matrix reverseRows) : ("reverseColumns", @@ -597,6 +583,8 @@ ("forceOrder", checkForAllExtra genOrder ((,) <$> Gen.matrixInt <#*|> Gen.vector) Generic.forceOrder) : + ("forceOrderInverse", + checkForAll Gen.matrixInt Generic.forceOrderInverse) : ("addDistributive", checkForAll (Generic.genDistribution Gen.matrixInt) diff --git a/test/Test/Mosaic.hs b/test/Test/Mosaic.hs new file mode 100644 --- /dev/null +++ b/test/Test/Mosaic.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +module Test.Mosaic ( + testsVar, + Property(..), + genIdentity, + repack, + ) where + +import qualified Test.Multiply as Multiply +import qualified Test.Generator as Gen +import qualified Test.Logic as Logic +import qualified Test.Utility as Util +import Test.Generator ((<-*#>), (<#*|>), (<#*#>)) +import Test.Utility (Tagged) + +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout +import qualified Numeric.LAPACK.Matrix as Matrix +import Numeric.LAPACK.Matrix (ShapeInt) +import Numeric.LAPACK.Scalar (RealOf) + +import qualified Numeric.Netlib.Class as Class + +import qualified Data.Array.Comfort.Shape as Shape + +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck as QC + + + +data Property property lower upper where + Symmetric :: + Property Omni.Symmetric MatrixShape.Filled MatrixShape.Filled + Hermitian :: + Property Omni.HermitianUnknownDefiniteness + MatrixShape.Filled MatrixShape.Filled + Diagonal :: + (MatrixShape.TriDiag diag) => + Property diag MatrixShape.Empty MatrixShape.Empty + Lower :: + (MatrixShape.TriDiag diag) => + Property diag MatrixShape.Filled MatrixShape.Empty + Upper :: + (MatrixShape.TriDiag diag) => + Property diag MatrixShape.Empty MatrixShape.Filled + +genMosaic :: + (Logic.Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Property prop lo up -> + Layout.PackingSingleton pack -> + Gen.Square sh a (ArrMatrix.Quadratic pack prop lo up sh a) +genMosaic prop p = + case prop of + Symmetric -> repack p <$> Gen.symmetric + Hermitian -> repack p <$> Gen.hermitian + Diagonal -> repack p <$> Gen.triangular + Lower -> repack p <$> Gen.triangular + Upper -> repack p <$> Gen.triangular + +genIdentity :: + (sh ~ ShapeInt, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Property prop lo up -> + Layout.PackingSingleton pack -> + Gen.Square sh a (ArrMatrix.Quadratic pack prop lo up sh a) +genIdentity prop p = + case prop of + Symmetric -> repack p <$> Gen.identity `asTypeOf` Gen.symmetric + Hermitian -> repack p <$> Gen.identity `asTypeOf` Gen.hermitian + Diagonal -> repack p <$> Gen.triangularIdentity + Lower -> repack p <$> Gen.identity `asTypeOf` Gen.triangular + Upper -> repack p <$> Gen.identity `asTypeOf` Gen.triangular + + +checkForAll :: + (Show a, QC.Testable test) => + Gen.T dim tag a -> (a -> test) -> Tagged tag QC.Property +checkForAll gen = Util.checkForAll (Gen.run gen 3 5) + +checkForAllExtra :: + (Show a, Show b, QC.Testable test) => + QC.Gen a -> Gen.T dim tag b -> + (a -> b -> test) -> Tagged tag QC.Property +checkForAllExtra = Gen.withExtra checkForAll + + +repack :: + (Shape.C sh, Class.Floating a) => + Layout.PackingSingleton pack -> + ArrMatrix.Quadratic Layout.Packed prop lo up sh a -> + ArrMatrix.Quadratic pack prop lo up sh a +repack pack m = + case pack of + Layout.Packed -> m + Layout.Unpacked -> Matrix.unpack m + +testsVar :: + (MatrixShape.Property prop, + MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up) => + (Layout.Packing pack) => + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + Property prop lo up -> + Layout.PackingSingleton pack -> + [(String, Tagged a QC.Property)] +testsVar prop p = + ("multiplySquare", + checkForAll (genMosaic prop p) Multiply.multiplySquare) : + ("squareSquare", + checkForAll (genMosaic prop p) Multiply.squareSquare) : + ("power", + checkForAllExtra (QC.choose (0,10)) (genMosaic prop p) Multiply.power) : + + ("multiplyIdentityVector", + checkForAll + ((,) <$> genIdentity prop p <#*|> Gen.vector) + Multiply.multiplyIdentityVector) : + ("multiplyIdentityFull", + checkForAll + ((,) <$> genIdentity prop p <#*#> Gen.matrix) + Multiply.multiplyIdentityFull) : + ("multiplyVector", + checkForAll ((,) <$> genMosaic prop p <#*|> Gen.vector) + Multiply.multiplyVector) : + ("multiplyFull", + checkForAll ((,) <$> genMosaic prop p <#*#> Gen.matrix) + Multiply.multiplyFull) : + ("multiplyVectorLeft", + checkForAll + ((,) <$> Gen.vector <-*#> genMosaic prop p) + Multiply.multiplyVectorLeft) : + ("multiplyVectorRight", + checkForAll + ((,) <$> genMosaic prop p <#*|> Gen.vector) + Multiply.multiplyVectorRight) : + ("multiplyLeft", + checkForAll + ((,) <$> Gen.matrix <#*#> genMosaic prop p) + Multiply.multiplyLeft) : + ("multiplyRight", + checkForAll + ((,) <$> genMosaic prop p <#*#> Gen.matrix) + Multiply.multiplyRight) : + [] diff --git a/test/Test/Multiply.hs b/test/Test/Multiply.hs --- a/test/Test/Multiply.hs +++ b/test/Test/Multiply.hs @@ -3,15 +3,27 @@ multiplySquare, squareSquare, power, + + multiplyIdentityVector, + multiplyIdentityFull, + multiplyVector, + multiplyFull, + multiplyVectorLeft, + multiplyVectorRight, + multiplyLeft, + multiplyRight, ) where import qualified Test.Utility as Util +import Test.Utility (approxArray, approxMatrix, approxVector) import qualified Numeric.LAPACK.Matrix.Square as Square import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix (Matrix, ShapeInt, (#*##)) +import Numeric.LAPACK.Matrix (ShapeInt, (-*#), (##*#), (#*##), (#*|)) +import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) import qualified Numeric.Netlib.Class as Class @@ -19,32 +31,106 @@ multiplySquare :: - (Matrix.Power typ, Matrix.MultiplySquare typ, - Matrix.SquareShape typ, Matrix.HeightOf typ ~ ShapeInt, + (Matrix.Power typ xl xu, Matrix.MultiplySquare typ xl xu, + Matrix.SquareShape typ, Matrix.ToQuadratic typ, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Matrix typ a -> Bool + Matrix.Quadratic typ xl xu lower upper ShapeInt a -> Bool multiplySquare a = Util.approxArray -- (Scalar.selectReal 1e-1 1e-5) (Matrix.toSquare $ Matrix.square a) (a #*## Matrix.toSquare a) squareSquare :: - (Matrix.Power typ, Matrix.MultiplySquare typ, - Matrix.SquareShape typ, Matrix.HeightOf typ ~ ShapeInt, + (Matrix.Power typ xl xu, Matrix.MultiplySquare typ xl xu, + Matrix.SquareShape typ, Matrix.ToQuadratic typ, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Matrix typ a -> Bool + Matrix.Quadratic typ xl xu lower upper ShapeInt a -> Bool squareSquare a = Util.approxArray -- (Scalar.selectReal 1e-1 1e-5) (Matrix.toSquare $ Matrix.square a) (Square.square $ Matrix.toSquare a) power :: - (Matrix.Power typ, Matrix.MultiplySquare typ, - Matrix.SquareShape typ, Matrix.HeightOf typ ~ ShapeInt, + (Matrix.Power typ xl xu, Matrix.MultiplySquare typ xl xu, + Matrix.SquareShape typ, Matrix.ToQuadratic typ, + MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Int -> Matrix typ a -> Bool -power n a = - let b = Matrix.toSquare (Matrix.power (n+1) a) + Int -> Matrix.Quadratic typ xl xu lower upper ShapeInt a -> Bool +power n0 a = + let n = fromIntegral n0 + b = Matrix.toSquare (Matrix.power (n+1) a) c = a #*## Matrix.toSquare (Matrix.power n a) normInf1 = Vector.normInf1 . ArrMatrix.toVector in Util.approxArrayTol (1e-6 * (normInf1 b + normInf1 c)) b c + + + +multiplyIdentityVector :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, Vector ShapeInt a) -> Bool +multiplyIdentityVector (eye,a) = approxVector a (eye #*| a) + +multiplyIdentityFull :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> + Bool +multiplyIdentityFull (eye,a) = approxArray a (eye #*## a) + +multiplyVector :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, Vector ShapeInt a) -> Bool +multiplyVector (a,x) = approxVector (Matrix.toSquare a #*| x) (a #*| x) + +multiplyFull :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> + Bool +multiplyFull (a,b) = approxArray (Matrix.toSquare a #*## b) (a #*## b) + + +multiplyVectorLeft :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Vector ShapeInt a, ArrMatrix.Quadratic pack prop lo up ShapeInt a) -> Bool +multiplyVectorLeft (x,a) = + approxVector (x -*# Matrix.toSquare a) (x -*# a) + +multiplyVectorRight :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, Vector ShapeInt a) -> Bool +multiplyVectorRight (a,x) = + approxVector (Matrix.toSquare a #*| x) (a #*| x) + + +multiplyLeft :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (Matrix.General ShapeInt ShapeInt a, + ArrMatrix.Quadratic pack prop lo up ShapeInt a) -> Bool +multiplyLeft (a,b) = + approxMatrix 1e-5 (a ##*# Matrix.toSquare b) (a ##*# b) + +multiplyRight :: + (MatrixShape.Packing pack) => + (MatrixShape.Property prop, MatrixShape.PowerStrip lo, MatrixShape.PowerStrip up, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + (ArrMatrix.Quadratic pack prop lo up ShapeInt a, + Matrix.General ShapeInt ShapeInt a) -> Bool +multiplyRight (a,b) = + approxArray (Matrix.toSquare a #*## b) (a #*## b) diff --git a/test/Test/Orthogonal.hs b/test/Test/Orthogonal.hs --- a/test/Test/Orthogonal.hs +++ b/test/Test/Orthogonal.hs @@ -30,7 +30,7 @@ import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Control.Applicative (liftA2, (<$>)) import Data.Semigroup ((<>)) @@ -144,7 +144,7 @@ approxArrayTol (selectReal 10 1e-3) (Ortho.leastSquares a b) - (Herm.solve (Herm.gramian $ Matrix.fromFull a) $ + (Herm.solve (ArrMatrix.asPacked $ Herm.gramian $ Matrix.fromFull a) $ Matrix.adjoint a #*# b) specializedLeastSquares :: @@ -193,7 +193,10 @@ (selectReal 10 1e-3) (Ortho.minimumNorm a b) (Matrix.adjoint a #*# - Herm.solve (Herm.gramian $ Matrix.fromFull $ Matrix.adjoint a) b) + Herm.solve + (ArrMatrix.asPacked $ Herm.gramian $ + Matrix.fromFull $ Matrix.adjoint a) + b) specializedMinimumNorm :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => @@ -244,24 +247,24 @@ complementOrthogonal = isUnitary (selectReal 1e-3 1e-7) . Ortho.complement -affineSpanFromKernel :: +affineFrameFromFiber :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => (Matrix.Wide ShapeInt ShapeInt a, Vector ShapeInt a) -> Bool -affineSpanFromKernel (a, by) = +affineFrameFromFiber (a, by) = let b = Vector.take (Shape.size $ Matrix.height a) by y = Vector.drop (Shape.size $ Matrix.height a) by - (c,d) = Ortho.affineSpanFromKernel a b + (c,d) = Ortho.affineFrameFromFiber a b in approxVectorTol (selectReal 1e-3 1e-7) b (a#*|(c#*|y|+|d)) -affineKernelFromSpan :: +affineFiberFromFrame :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => (Matrix.Tall ShapeInt ShapeInt a, Vector ShapeInt a, Vector ShapeInt a) -> Bool -affineKernelFromSpan (c,y,d) = - let (a,b) = Ortho.affineKernelFromSpan c d +affineFiberFromFrame (c,y,d) = + let (a,b) = Ortho.affineFiberFromFrame c d in approxVectorTol (selectReal 1e-3 1e-7) b @@ -308,8 +311,8 @@ splitLSCStack :: (Shape.C height, Shape.C constraints, Shape.C width, Class.Floating a) => - Matrix.Tall (constraints:+:height) width a -> - Vector (constraints:+:height) a -> + Matrix.Tall (constraints::+height) width a -> + Vector (constraints::+height) a -> ((Matrix.General height width a, Vector height a), (Matrix.Wide constraints width a, Vector constraints a)) splitLSCStack baTall dc = @@ -321,8 +324,8 @@ leastSquaresConstraintAdmissible :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Matrix.Tall (ShapeInt:+:ShapeInt) ShapeInt a, - Vector (ShapeInt:+:ShapeInt) a) -> + (Matrix.Tall (ShapeInt::+ShapeInt) ShapeInt a, + Vector (ShapeInt::+ShapeInt) a) -> Bool leastSquaresConstraintAdmissible (ba,dc) = let ((a,c),(b,d)) = splitLSCStack ba dc @@ -333,9 +336,9 @@ leastSquaresConstraintMinimal :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Matrix.Tall (ShapeInt:+:ShapeInt) ShapeInt a, + (Matrix.Tall (ShapeInt::+ShapeInt) ShapeInt a, Vector ShapeInt a, - Vector (ShapeInt:+:ShapeInt) a) -> + Vector (ShapeInt::+ShapeInt) a) -> Bool leastSquaresConstraintMinimal (ba,x,dc) = let ((a,c),(b,d)) = splitLSCStack ba dc @@ -379,7 +382,7 @@ gaussMarkovLinearModelAdmissible :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Matrix.Wide ShapeInt (ShapeInt:+:ShapeInt) a, Vector ShapeInt a) -> Bool + (Matrix.Wide ShapeInt (ShapeInt::+ShapeInt) a, Vector ShapeInt a) -> Bool gaussMarkovLinearModelAdmissible (abWide,d) = let ab = Matrix.fromFull abWide a = Matrix.tallFromGeneral $ Matrix.takeLeft ab @@ -391,9 +394,9 @@ gaussMarkovLinearModelMinimal :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Matrix.Wide ShapeInt (ShapeInt:+:ShapeInt) a, + (Matrix.Wide ShapeInt (ShapeInt::+ShapeInt) a, Vector ShapeInt a, - Vector (ShapeInt:+:ShapeInt) a) -> Bool + Vector (ShapeInt::+ShapeInt) a) -> Bool gaussMarkovLinearModelMinimal (abWide,d,xy) = let ab = Matrix.fromFull abWide a = Matrix.tallFromGeneral $ Matrix.takeLeft ab @@ -421,10 +424,8 @@ maybeTriTranspose :: - (Shape.C size, Class.Floating a, MatrixShape.TriDiag diag, - MatrixShape.Content lo, MatrixShape.Content up) => - HH.Transposition -> - Triangular.Triangular up diag lo size a -> Square size a + (Shape.C size, Class.Floating a) => + HH.Transposition -> Triangular.Upper size a -> Square size a maybeTriTranspose HH.NonTransposed = Triangular.toSquare maybeTriTranspose HH.Transposed = Triangular.toSquare . Triangular.transpose @@ -557,13 +558,13 @@ ("complementOrthogonal", checkForAll Gen.tall complementOrthogonal) : - ("affineSpanFromKernel", + ("affineFrameFromFiber", checkForAll - ((,) <$> Gen.fullRankWide <#*|> Gen.vector) affineSpanFromKernel) : - ("affineKernelFromSpan", + ((,) <$> Gen.fullRankWide <#*|> Gen.vector) affineFrameFromFiber) : + ("affineFiberFromFrame", checkForAll ((,,) <$> Gen.tall <#*|> Gen.vector <|=|> Gen.vector) - affineKernelFromSpan) : + affineFiberFromFrame) : ("projectHit", checkForAll diff --git a/test/Test/Permutation.hs b/test/Test/Permutation.hs --- a/test/Test/Permutation.hs +++ b/test/Test/Permutation.hs @@ -15,7 +15,7 @@ import Numeric.LAPACK.Permutation (Permutation, Inversion(Inverted, NonInverted)) import Numeric.LAPACK.Matrix.Square (Square) -import Numeric.LAPACK.Matrix (Matrix, ShapeInt, shapeInt, (#*##)) +import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (#*##)) import Numeric.LAPACK.Vector (Vector) import qualified Numeric.Netlib.Class as Class @@ -59,7 +59,8 @@ applyToMatrix :: (Class.Floating a) => - Inversion -> (Permutation ShapeInt, Matrix.General ShapeInt ShapeInt a) -> Bool + Inversion -> + (Permutation ShapeInt, Matrix.General ShapeInt ShapeInt a) -> Bool applyToMatrix inv (p,m) = equalArray (Perm.apply inv p m) @@ -79,20 +80,21 @@ applyTranspose :: (Class.Floating a) => - Inversion -> (Permutation ShapeInt, Matrix.General ShapeInt ShapeInt a) -> Bool + Inversion -> + (Permutation ShapeInt, Matrix.General ShapeInt ShapeInt a) -> Bool applyTranspose inv (p,m) = equalArray (Perm.apply inv (Perm.transpose p) m) (Matrix.transpose (permToMatrix inv p) #*## m) -genPermMatrix :: (Dim sh) => Gen.Matrix sh sh a (Matrix (Permutation sh) a) +genPermMatrix :: (Dim sh) => Gen.Matrix sh sh a (Matrix.Permutation sh a) genPermMatrix = PermMatrix.fromPermutation <$> genPermutation determinantNumber :: - (Class.Floating a, Eq a) => Matrix (Permutation ShapeInt) a -> Bool + (Class.Floating a, Eq a) => Matrix.Permutation ShapeInt a -> Bool determinantNumber p = - PermMatrix.determinant p == Square.determinant (PermMatrix.toMatrix p) + PermMatrix.determinant p == Square.determinant (PermMatrix.toSquare p) diff --git a/test/Test/Shape.hs b/test/Test/Shape.hs --- a/test/Test/Shape.hs +++ b/test/Test/Shape.hs @@ -7,7 +7,7 @@ import qualified Data.Array.Comfort.Shape.Test as ShapeTest import qualified Data.Array.Comfort.Shape as Shape -import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Permutation as Perm import qualified Numeric.LAPACK.Shape as ExtShape @@ -21,159 +21,157 @@ import qualified Test.QuickCheck as QC -genMin :: QC.Gen (ExtShape.Min ShapeInt (Shape.Shifted Int)) -genMin = do - m <- QC.choose (0,10) - start <- QC.choose (-10,10) - n <- QC.choose (0,10) - return $ ExtShape.Min (shapeInt m) (Shape.Shifted start n) - genPermutation :: QC.Gen (Perm.Shape ShapeInt) genPermutation = Perm.Shape . Shape.ZeroBased <$> QC.choose (0,10) +genIntIndexed :: QC.Gen (ExtShape.IntIndexed (Shape.UpperTriangular ShapeInt)) +genIntIndexed = + ExtShape.IntIndexed . Shape.Triangular Shape.Upper . shapeInt + <$> + QC.choose (0,10) -genGeneral :: QC.Gen (MatrixShape.General ShapeInt ShapeInt) + +genGeneral :: QC.Gen (Layout.General ShapeInt ShapeInt) genGeneral = do order <- genOrder m <- QC.choose (0,10) n <- QC.choose (0,10) - return $ MatrixShape.general order (shapeInt m) (shapeInt n) + return $ Layout.general order (shapeInt m) (shapeInt n) -genTall :: QC.Gen (MatrixShape.Tall ShapeInt ShapeInt) +genTall :: QC.Gen (Layout.Tall ShapeInt ShapeInt) genTall = do order <- genOrder m <- QC.choose (0,10) n <- QC.choose (0,m) - return $ MatrixShape.tall order (shapeInt m) (shapeInt n) + return $ Layout.tall order (shapeInt m) (shapeInt n) -genWide :: QC.Gen (MatrixShape.Wide ShapeInt ShapeInt) +genWide :: QC.Gen (Layout.Wide ShapeInt ShapeInt) genWide = do order <- genOrder m <- QC.choose (0,10) n <- QC.choose (m,10) - return $ MatrixShape.wide order (shapeInt m) (shapeInt n) + return $ Layout.wide order (shapeInt m) (shapeInt n) -genSquare :: QC.Gen (MatrixShape.Square ShapeInt) +genSquare :: QC.Gen (Layout.Square ShapeInt) genSquare = do order <- genOrder n <- QC.choose (0,10) - return $ MatrixShape.square order (shapeInt n) + return $ Layout.square order (shapeInt n) -genHermitian :: QC.Gen (MatrixShape.Hermitian ShapeInt) -genHermitian = do - order <- genOrder - n <- QC.choose (0,10) - return $ MatrixShape.hermitian order (shapeInt n) - -genDiagonal :: QC.Gen (MatrixShape.Diagonal ShapeInt) +genDiagonal :: QC.Gen (Layout.Diagonal ShapeInt) genDiagonal = do order <- genOrder n <- QC.choose (0,10) - return $ MatrixShape.diagonal order (shapeInt n) + return $ Layout.diagonal order (shapeInt n) genLowerTriangular :: - QC.Gen (MatrixShape.LowerTriangular MatrixShape.NonUnit ShapeInt) -genLowerTriangular = do + Layout.PackingSingleton pack -> + QC.Gen (Layout.LowerTriangularP pack ShapeInt) +genLowerTriangular pack = do order <- genOrder n <- QC.choose (0,10) - return $ MatrixShape.lowerTriangular order (shapeInt n) + return $ Layout.lowerTriangularP pack order (shapeInt n) genUpperTriangular :: - QC.Gen (MatrixShape.UpperTriangular MatrixShape.NonUnit ShapeInt) -genUpperTriangular = do + Layout.PackingSingleton pack -> + QC.Gen (Layout.UpperTriangularP pack ShapeInt) +genUpperTriangular pack = do order <- genOrder n <- QC.choose (0,10) - return $ MatrixShape.upperTriangular order (shapeInt n) + return $ Layout.upperTriangularP pack order (shapeInt n) -genSymmetric :: QC.Gen (MatrixShape.Symmetric ShapeInt) -genSymmetric = do +genSymmetric :: + Layout.PackingSingleton pack -> + QC.Gen (Layout.SymmetricP pack ShapeInt) +genSymmetric pack = do order <- genOrder n <- QC.choose (0,10) - return $ MatrixShape.symmetric order (shapeInt n) + return $ Layout.symmetricP pack order (shapeInt n) +genHermitian :: + Layout.PackingSingleton pack -> + QC.Gen (Layout.HermitianP pack ShapeInt) +genHermitian pack = do + order <- genOrder + n <- QC.choose (0,10) + return $ Layout.hermitianP pack order (shapeInt n) -data Banded vert horiz height width = + +data Banded meas vert horiz height width = forall sub super. (Unary.Natural sub, Unary.Natural super) => - Banded (MatrixShape.Banded sub super vert horiz height width) + Banded (Layout.Banded sub super meas vert horiz height width) instance - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Show height, Show width, Shape.C height, Shape.C width) => - Show (Banded vert horiz height width) where + Show (Banded meas vert horiz height width) where showsPrec p (Banded sh) = showsPrec p sh instance - (Extent.C vert, Extent.C horiz, Shape.C height, Shape.C width) => - Shape.C (Banded vert horiz height width) where + (Extent.Measure meas, Extent.C vert, Extent.C horiz, + Shape.C height, Shape.C width) => + Shape.C (Banded meas vert horiz height width) where + size (Banded sh) = Shape.size sh - uncheckedSize (Banded sh) = Shape.uncheckedSize sh instance - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.Indexed height, Shape.Indexed width) => - Shape.Indexed (Banded vert horiz height width) where - type Index (Banded vert horiz height width) = - MatrixShape.BandedIndex (Shape.Index height) (Shape.Index width) + Shape.Indexed (Banded meas vert horiz height width) where + type Index (Banded meas vert horiz height width) = + Layout.BandedIndex (Shape.Index height) (Shape.Index width) indices (Banded sh) = Shape.indices sh - offset (Banded sh) = Shape.offset sh - uncheckedOffset (Banded sh) = Shape.uncheckedOffset sh + unifiedOffset (Banded sh) = Shape.unifiedOffset sh inBounds (Banded sh) = Shape.inBounds sh - sizeOffset (Banded sh) = Shape.sizeOffset sh - uncheckedSizeOffset (Banded sh) = Shape.uncheckedSizeOffset sh + unifiedSizeOffset (Banded sh) = Shape.unifiedSizeOffset sh instance - (Extent.C vert, Extent.C horiz, + (Extent.Measure meas, Extent.C vert, Extent.C horiz, Shape.InvIndexed height, Shape.InvIndexed width) => - Shape.InvIndexed (Banded vert horiz height width) where + Shape.InvIndexed (Banded meas vert horiz height width) where - indexFromOffset (Banded sh) = Shape.indexFromOffset sh - uncheckedIndexFromOffset (Banded sh) = Shape.uncheckedIndexFromOffset sh + unifiedIndexFromOffset (Banded sh) = Shape.unifiedIndexFromOffset sh genBanded :: - MatrixShape.Full vert horiz height width -> - QC.Gen (Banded vert horiz height width) + Layout.Full meas vert horiz height width -> + QC.Gen (Banded meas vert horiz height width) genBanded sh = do kl <- QC.choose (0,10) ku <- QC.choose (0,10) Unary.reifyNatural kl $ \sub -> Unary.reifyNatural ku $ \super -> - return $ Banded $ MatrixShape.bandedFromFull (unary sub, unary super) sh + return $ Banded $ Layout.bandedFromFull (unary sub, unary super) sh data BandedHermitian size = forall offDiag. (Unary.Natural offDiag) => - BandedHermitian (MatrixShape.BandedHermitian offDiag size) + BandedHermitian (Layout.BandedHermitian offDiag size) instance (Show size, Shape.C size) => Show (BandedHermitian size) where showsPrec p (BandedHermitian sh) = showsPrec p sh instance (Shape.C size) => Shape.C (BandedHermitian size) where size (BandedHermitian sh) = Shape.size sh - uncheckedSize (BandedHermitian sh) = Shape.uncheckedSize sh instance (Shape.Indexed size) => Shape.Indexed (BandedHermitian size) where type Index (BandedHermitian size) = - MatrixShape.BandedIndex (Shape.Index size) (Shape.Index size) + Layout.BandedIndex (Shape.Index size) (Shape.Index size) indices (BandedHermitian sh) = Shape.indices sh - offset (BandedHermitian sh) = Shape.offset sh - uncheckedOffset (BandedHermitian sh) = Shape.uncheckedOffset sh + unifiedOffset (BandedHermitian sh) = Shape.unifiedOffset sh inBounds (BandedHermitian sh) = Shape.inBounds sh - sizeOffset (BandedHermitian sh) = Shape.sizeOffset sh - uncheckedSizeOffset (BandedHermitian sh) = Shape.uncheckedSizeOffset sh + unifiedSizeOffset (BandedHermitian sh) = Shape.unifiedSizeOffset sh instance (Shape.InvIndexed size) => Shape.InvIndexed (BandedHermitian size) where - indexFromOffset (BandedHermitian sh) = - Shape.indexFromOffset sh - uncheckedIndexFromOffset (BandedHermitian sh) = - Shape.uncheckedIndexFromOffset sh + unifiedIndexFromOffset (BandedHermitian sh) = + Shape.unifiedIndexFromOffset sh genBandedHermitian :: QC.Gen (BandedHermitian ShapeInt) @@ -183,13 +181,25 @@ k <- QC.choose (0,10) Unary.reifyNatural k $ \numOff -> return $ BandedHermitian $ - MatrixShape.bandedHermitian (unary numOff) order (shapeInt n) + Layout.bandedHermitian (unary numOff) order (shapeInt n) +mosaicTests :: Layout.PackingSingleton pack -> [(String, QC.Property)] +mosaicTests pack = + prefix ("LowerTriangular." ++ show pack) + (ShapeTest.tests $ genLowerTriangular pack) ++ + prefix ("UpperTriangular." ++ show pack) + (ShapeTest.tests $ genUpperTriangular pack) ++ + prefix ("Symmetric." ++ show pack) + (ShapeTest.tests $ genSymmetric pack) ++ + prefix ("Hermitian." ++ show pack) + (ShapeTest.tests $ genHermitian pack) ++ + [] + tests :: [(String, QC.Property)] tests = - prefix "Min" (ShapeTest.tests genMin) ++ prefix "Permutation" (ShapeTest.tests genPermutation) ++ + prefix "IntIndexed" (ShapeTest.tests genIntIndexed) ++ prefix "General" (ShapeTest.tests genGeneral) ++ prefix "Tall" (ShapeTest.tests genTall) ++ @@ -198,35 +208,33 @@ prefix "Split.Reflector.General" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Reflector <$> genGeneral) ++ + Layout.splitFromFull Layout.Reflector <$> genGeneral) ++ prefix "Split.Reflector.Tall" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Reflector <$> genTall) ++ + Layout.splitFromFull Layout.Reflector <$> genTall) ++ prefix "Split.Reflector.Wide" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Reflector <$> genWide) ++ + Layout.splitFromFull Layout.Reflector <$> genWide) ++ prefix "Split.Reflector.Square" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Reflector <$> genSquare) ++ + Layout.splitFromFull Layout.Reflector <$> genSquare) ++ prefix "Split.Triangle.General" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Triangle <$> genGeneral) ++ + Layout.splitFromFull Layout.Triangle <$> genGeneral) ++ prefix "Split.Triangle.Tall" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Triangle <$> genTall) ++ + Layout.splitFromFull Layout.Triangle <$> genTall) ++ prefix "Split.Triangle.Wide" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Triangle <$> genWide) ++ + Layout.splitFromFull Layout.Triangle <$> genWide) ++ prefix "Split.Triangle.Square" (ShapeTest.tests $ - MatrixShape.splitFromFull MatrixShape.Triangle <$> genSquare) ++ + Layout.splitFromFull Layout.Triangle <$> genSquare) ++ - prefix "Hermitian" (ShapeTest.tests genHermitian) ++ - prefix "Diagonal" (ShapeTest.tests genDiagonal) ++ - prefix "LowerTriangular" (ShapeTest.tests genLowerTriangular) ++ - prefix "UpperTriangular" (ShapeTest.tests genUpperTriangular) ++ - prefix "Symmetric" (ShapeTest.tests genSymmetric) ++ + mosaicTests Layout.Packed ++ + mosaicTests Layout.Unpacked ++ + prefix "Diagonal" (ShapeTest.tests genDiagonal) ++ prefix "Banded.General" (ShapeTest.tests $ genBanded =<< genGeneral) ++ prefix "Banded.Tall" (ShapeTest.tests $ genBanded =<< genTall) ++ prefix "Banded.Wide" (ShapeTest.tests $ genBanded =<< genWide) ++ diff --git a/test/Test/Singular.hs b/test/Test/Singular.hs --- a/test/Test/Singular.hs +++ b/test/Test/Singular.hs @@ -9,6 +9,7 @@ import qualified Numeric.LAPACK.Singular as Singular import qualified Numeric.LAPACK.Orthogonal as Ortho +import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix import qualified Numeric.LAPACK.Matrix as Matrix import Numeric.LAPACK.Matrix (General, ShapeInt, shapeInt, (##*#), (#*#), (#*##)) @@ -68,7 +69,8 @@ leastSquaresMinimumNorm :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Matrix.General ShapeInt ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> Bool + (Matrix.General ShapeInt ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> + Bool leastSquaresMinimumNorm (a,b) = let (no,xo) = Ortho.leastSquaresMinimumNormRCond 1e-5 a b (ns,xs) = Singular.leastSquaresMinimumNormRCond 1e-5 a b @@ -80,12 +82,13 @@ (Class.Floating a, RealOf a ~ ar, Class.Real ar) => Matrix.General ShapeInt ShapeInt a -> Bool decompose a = - let (u,s,vt) = Singular.decompose a + let (u,sm,vt) = Singular.decompose a + s = ArrMatrix.toVector sm mn = Shape.size $ Array.shape s in approxArrayTol 1e-3 a (Matrix.takeColumns mn (Matrix.generalizeWide u) #*# Matrix.scaleRowsReal - (Array.mapShape (shapeInt . Shape.size) s) + (Array.reshape (shapeInt mn) s) (Matrix.takeRows mn (Matrix.generalizeTall vt))) && isUnitary 1e-3 u diff --git a/test/Test/Square.hs b/test/Test/Square.hs --- a/test/Test/Square.hs +++ b/test/Test/Square.hs @@ -102,7 +102,8 @@ Square ShapeInt a -> Bool schur a = let (q,r) = Square.schur a - in approxMatrix 1e-4 a $ Square.congruenceAdjoint (Matrix.fromFull q) r + in approxMatrix 1e-4 a $ + Square.congruenceAdjoint (Matrix.fromFull q) (Matrix.toFull r) schurComplex :: (Class.Real a) => Square ShapeInt (Complex a) -> Bool schurComplex a = @@ -114,7 +115,7 @@ (Class.Floating a, RealOf a ~ ar, Class.Real ar) => Gen.MatrixInt a (Square ShapeInt a) genDiagonalizable = flip Gen.mapQC Gen.invertible $ \a -> do - d <- Util.genDistinct 3 10 (Square.size a) + d <- Util.genDistinct [-3..3] [-10..10] (Square.size a) return $ a #\## d \*# a diff --git a/test/Test/Symmetric.hs b/test/Test/Symmetric.hs --- a/test/Test/Symmetric.hs +++ b/test/Test/Symmetric.hs @@ -1,20 +1,28 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module Test.Symmetric (testsVar) where +{-# LANGUAGE GADTs #-} +module Test.Symmetric (testsVar, genSymmetric) where +import qualified Test.Mosaic as Mosaic +import qualified Test.Divide as Divide +import qualified Test.Generic as Generic +import qualified Test.Indexed as Indexed import qualified Test.Generator as Gen +import qualified Test.Logic as Logic import qualified Test.Utility as Util -import Test.Generator ((<-*#>), (<#*|>), (<#*#>), (<#=#>)) +import Test.Mosaic (repack) +import Test.Generator ((<-*#>), (<#*|>), (<.*#>), (<#*#>), (<#\#>), (<#=#>)) import Test.Utility (approxArray, approxMatrix, equalArray, Tagged, genOrder, (!===)) import qualified Numeric.LAPACK.Matrix.Symmetric as Symmetric -import qualified Numeric.LAPACK.Matrix.Triangular as Triangular import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector -import Numeric.LAPACK.Matrix.Symmetric (Symmetric) -import Numeric.LAPACK.Matrix.Shape (Order) +import Numeric.LAPACK.Matrix.Layout (Order) import Numeric.LAPACK.Matrix (General, ShapeInt, (#+#), (|||)) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf) @@ -22,10 +30,13 @@ import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Control.Applicative ((<$>)) +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List as List import Data.Semigroup ((<>)) import Data.Tuple.HT (uncurry3) @@ -33,125 +44,234 @@ +type SymmetricP pack sh = ArrMatrix.FullQuadratic pack Omni.Symmetric sh + +genSymmetric :: + (Logic.Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a) => + Layout.PackingSingleton pack -> + Gen.Square sh a (SymmetricP pack sh a) +genSymmetric p = repack p <$> Gen.symmetric + generalFromSymmetric :: - (Shape.C sh, Class.Floating a) => Symmetric sh a -> General sh sh a -generalFromSymmetric = Matrix.fromFull . Triangular.toSquare + (Layout.Packing pack, Shape.C sh, Class.Floating a) => + SymmetricP pack sh a -> General sh sh a +generalFromSymmetric = Matrix.fromFull . Symmetric.toSquare stack :: - (Class.Floating a) => - (Symmetric ShapeInt a, General ShapeInt ShapeInt a, Symmetric ShapeInt a) -> + (Layout.Packing pack, Class.Floating a) => + (SymmetricP pack ShapeInt a, + General ShapeInt ShapeInt a, + SymmetricP pack ShapeInt a) -> Bool stack (a,b,c) = - let abc = generalFromSymmetric $ Symmetric.stack a b c - in equalArray abc $ - (Matrix.fromFull (Triangular.toSquare a) ||| b - !=== - Matrix.transpose b ||| Matrix.fromFull (Triangular.toSquare c)) + equalArray + (generalFromSymmetric $ Symmetric.stack a b c) + (generalFromSymmetric a ||| b + !=== + Matrix.transpose b ||| generalFromSymmetric c) -split :: (Class.Floating a) => Symmetric (ShapeInt:+:ShapeInt) a -> Bool +split :: + (Layout.Packing pack, Class.Floating a) => + SymmetricP pack (ShapeInt::+ShapeInt) a -> Bool split abc = equalArray abc $ uncurry3 Symmetric.stack $ Symmetric.split abc gramian :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramian x = +gramian pack x = approxArray - (generalFromSymmetric $ Symmetric.gramian x) + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.gramian x) (Matrix.transpose x <> x) gramianTransposed :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramianTransposed x = +gramianTransposed pack x = approxArray - (generalFromSymmetric $ Symmetric.gramianTransposed x) + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.gramianTransposed x) (Matrix.adaptOrder x $ x <> Matrix.transpose x) gramianNonTransposed :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -gramianNonTransposed x = +gramianNonTransposed pack x = approxArray - (Matrix.forceOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape x) $ + (Matrix.forceOrder (ArrMatrix.order x) $ Symmetric.gramian $ Matrix.transpose x) - (Symmetric.gramianTransposed x) + (ArrMatrix.requirePacking pack $ Symmetric.gramianTransposed x) congruenceDiagonal :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (Vector ShapeInt a, General ShapeInt ShapeInt a) -> Bool -congruenceDiagonal (d,a) = +congruenceDiagonal pack (d,a) = approxArray - (generalFromSymmetric $ Symmetric.congruenceDiagonal d a) + (generalFromSymmetric $ ArrMatrix.requirePacking pack $ + Symmetric.congruenceDiagonal d a) (Matrix.transpose a <> Matrix.scaleRows d a) congruenceDiagonalTransposed :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, Vector ShapeInt a) -> Bool -congruenceDiagonalTransposed (a,d) = +congruenceDiagonalTransposed pack (a,d) = approxMatrix 1e-5 - (generalFromSymmetric $ Symmetric.congruenceDiagonalTransposed a d) + (generalFromSymmetric $ ArrMatrix.requirePacking pack $ + Symmetric.congruenceDiagonalTransposed a d) (Matrix.scaleColumns d a <> Matrix.transpose a) congruenceDiagonalGramian :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> General ShapeInt ShapeInt a -> Bool -congruenceDiagonalGramian a = +congruenceDiagonalGramian pack a = approxArray (Symmetric.congruenceDiagonal (Vector.one $ Matrix.height a) a) - (Symmetric.gramian a) + (ArrMatrix.requirePacking pack $ Symmetric.gramian a) congruence :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Symmetric ShapeInt a, General ShapeInt ShapeInt a) -> Bool + (SymmetricP pack ShapeInt a, General ShapeInt ShapeInt a) -> Bool congruence (b,a) = approxArray (generalFromSymmetric $ Symmetric.congruence b a) (Matrix.transpose a <> generalFromSymmetric b <> a) congruenceTransposed :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (General ShapeInt ShapeInt a, Symmetric ShapeInt a) -> Bool + (General ShapeInt ShapeInt a, SymmetricP pack ShapeInt a) -> Bool congruenceTransposed (a,b) = approxMatrix 1e-5 (generalFromSymmetric $ Symmetric.congruenceTransposed a b) (a <> generalFromSymmetric b <> Matrix.transpose a) congruenceCongruenceDiagonal :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> Order -> (Vector ShapeInt a, General ShapeInt ShapeInt a) -> Bool -congruenceCongruenceDiagonal order (d,a) = +congruenceCongruenceDiagonal pack order (d,a) = approxArray (Symmetric.congruenceDiagonal d a) - (Symmetric.congruence (Triangular.diagonal order d) a) + (Symmetric.congruence (repack pack $ Symmetric.diagonal order d) a) anticommutator :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutator (a,b) = +anticommutator pack (a,b) = approxArray - (generalFromSymmetric $ Symmetric.anticommutator a b) + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.anticommutator a b) ((Matrix.transpose b <> a) #+# (Matrix.transpose a <> b)) anticommutatorCommutative :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutatorCommutative (a,b) = +anticommutatorCommutative pack (a,b) = approxMatrix 1e-5 - (Symmetric.anticommutator a b) + (ArrMatrix.requirePacking pack $ + Symmetric.anticommutator a b) (Symmetric.anticommutator b a) anticommutatorTransposed :: + (Layout.Packing pack) => (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> (General ShapeInt ShapeInt a, General ShapeInt ShapeInt a) -> Bool -anticommutatorTransposed (a,b) = +anticommutatorTransposed pack (a,b) = approxArray - (Matrix.forceOrder (ArrMatrix.shapeOrder $ ArrMatrix.shape b) $ + (Matrix.forceOrder (ArrMatrix.order b) $ Symmetric.anticommutator (Matrix.transpose a) (Matrix.transpose b)) - (Symmetric.anticommutatorTransposed a b) + (ArrMatrix.requirePacking pack $ Symmetric.anticommutatorTransposed a b) +tensorProduct :: + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Order -> Vector ShapeInt a -> Bool +tensorProduct pack order x = + approxArray + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.tensorProduct order x) + (Matrix.tensorProduct order x x) + +genScaledVectors :: + (NonEmptyC.Gen f, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Gen.VectorInt a (ShapeInt, f (a, Vector ShapeInt a)) +genScaledVectors = Gen.listOfVector ((,) <$> Gen.scalar <.*#> Gen.vector) + +sumRank1 :: + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Order -> (ShapeInt, [(a, Vector ShapeInt a)]) -> Bool +sumRank1 pack order (sh,xs) = + approxArray + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.sumRank1 order sh xs) + (Util.addMatrices (MatrixShape.general order sh sh) $ + fmap (rank1 order) xs) + +sumRank1NonEmpty :: + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Order -> NonEmpty.T [] (a, Vector ShapeInt a) -> Bool +sumRank1NonEmpty pack order xs = + approxArray + (generalFromSymmetric $ + ArrMatrix.requirePacking pack $ Symmetric.sumRank1NonEmpty order xs) + (NonEmpty.foldl1 (ArrMatrix.lift2 Vector.add) $ fmap (rank1 order) xs) + +rank1 :: + (Eq size, Shape.C size, Class.Floating a) => + Order -> (a, Vector size a) -> Matrix.General size size a +rank1 order (r,x) = Matrix.scale r $ Matrix.tensorProduct order x x + + +addTransposed :: + (Layout.Packing pack) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Matrix.Square ShapeInt a -> Bool +addTransposed pack x = + approxArray + (Symmetric.toSquare $ ArrMatrix.requirePacking pack $ + Symmetric.addTransposed x) + (Matrix.transpose x #+# x) + + + +genInvertible :: + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> + Gen.MatrixInt a (SymmetricP pack ShapeInt a) +genInvertible pack = + repack pack <$> Gen.condition Util.invertible Gen.symmetric + + + checkForAll :: (Show a, QC.Testable test) => Gen.T dim tag a -> (a -> test) -> Tagged tag QC.Property @@ -168,38 +288,93 @@ (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => [(String, Tagged a QC.Property)] testsVar = + concat $ + List.transpose + [Util.suffix "Packed" (testsVarPacking Layout.Packed), + Util.suffix "Unpacked" (testsVarPacking Layout.Unpacked)] + +testsVarPacking :: + (Layout.Packing pack) => + (Show a, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsVarPacking p = + ("index", + checkForAll (Indexed.genMatrixIndex $ genSymmetric p) Indexed.unitDot) : + ("forceOrder", + checkForAllExtra genOrder + ((,) <$> genSymmetric p <#*|> Gen.vector) Generic.forceOrder) : + ("forceOrderInverse", + checkForAll (genSymmetric p) Generic.forceOrderInverse) : + ("addDistributive", + checkForAll + (Generic.genDistribution (genSymmetric p)) + Generic.addDistributive) : + ("subDistributive", + checkForAll + (Generic.genDistribution (genSymmetric p)) + Generic.subDistributive) : + ("stack", - checkForAll (Gen.stack3 Gen.triangular Gen.matrix Gen.triangular) stack) : + checkForAll + (Gen.stack3 (genSymmetric p) Gen.matrix (genSymmetric p)) + stack) : ("split", - checkForAll Gen.triangular split) : + checkForAll (genSymmetric p) split) : ("gramian", - checkForAll Gen.matrix gramian) : + checkForAll Gen.matrix (gramian p)) : ("gramianTransposed", - checkForAll Gen.matrix gramianTransposed) : + checkForAll Gen.matrix (gramianTransposed p)) : ("gramianNonTransposed", - checkForAll Gen.matrix gramianNonTransposed) : + checkForAll Gen.matrix (gramianNonTransposed p)) : ("congruenceDiagonal", - checkForAll ((,) <$> Gen.vector <-*#> Gen.matrix) congruenceDiagonal) : + checkForAll ((,) <$> Gen.vector <-*#> Gen.matrix) + (congruenceDiagonal p)) : ("congruence", - checkForAll ((,) <$> Gen.triangular <#*#> Gen.matrix) congruence) : + checkForAll ((,) <$> genSymmetric p <#*#> Gen.matrix) congruence) : ("congruenceDiagonalTransposed", checkForAll ((,) <$> Gen.matrix <#*|> Gen.vector) - congruenceDiagonalTransposed) : + (congruenceDiagonalTransposed p)) : ("congruenceDiagonalGramian", - checkForAll Gen.matrix congruenceDiagonalGramian) : + checkForAll Gen.matrix (congruenceDiagonalGramian p)) : ("congruenceTransposed", - checkForAll ((,) <$> Gen.matrix <#*#> Gen.triangular) + checkForAll ((,) <$> Gen.matrix <#*#> genSymmetric p) congruenceTransposed) : ("congruenceCongruenceDiagonal", checkForAllExtra genOrder - ((,) <$> Gen.vector <-*#> Gen.matrix) congruenceCongruenceDiagonal) : + ((,) <$> Gen.vector <-*#> Gen.matrix) + (congruenceCongruenceDiagonal p)) : ("anticommutator", - checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) anticommutator) : + checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) (anticommutator p)) : ("anticommutatorCommutative", checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) - anticommutatorCommutative) : + (anticommutatorCommutative p)) : ("anticommutatorTransposed", checkForAll ((,) <$> Gen.matrix <#=#> Gen.matrix) - anticommutatorTransposed) : + (anticommutatorTransposed p)) : + ("tensorProduct", + checkForAllExtra genOrder Gen.vector (tensorProduct p)) : + ("sumRank1", + checkForAllExtra genOrder genScaledVectors (sumRank1 p)) : + ("sumRank1NonEmpty", + checkForAllExtra genOrder + (snd <$> genScaledVectors) (sumRank1NonEmpty p)) : + ("addTransposed", + checkForAll Gen.square (addTransposed p)) : + + Mosaic.testsVar Mosaic.Symmetric p ++ + + ("determinant", + checkForAll (genSymmetric p) Divide.determinant) : + ("solve", + checkForAll ((,) <$> genInvertible p <#\#> Gen.matrix) Divide.solve) : + ("solveIdentity", + checkForAll + ((,) <$> + (repack p <$> Gen.identity `asTypeOf` Gen.symmetric) + <#\#> Gen.matrix) + Divide.solveIdentity) : + ("inverse", + checkForAll (genInvertible p) Divide.inverse) : + Divide.testsVar (genInvertible p) ++ [] diff --git a/test/Test/Triangular.hs b/test/Test/Triangular.hs --- a/test/Test/Triangular.hs +++ b/test/Test/Triangular.hs @@ -1,80 +1,84 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE Rank2Types #-} -module Test.Triangular (testsVar) where +{-# LANGUAGE GADTs #-} +module Test.Triangular ( + testsVar, + genTriangular, + PowerStrip(..), + diagonal, + ) where +import qualified Test.Mosaic as Mosaic import qualified Test.Divide as Divide -import qualified Test.Multiply as Multiply import qualified Test.Generic as Generic import qualified Test.Indexed as Indexed import qualified Test.Generator as Gen +import qualified Test.Logic as Logic import qualified Test.Utility as Util -import Test.Generator ((<-*#>), (<#*|>), (<#*#>), (<#\#>)) +import Test.Mosaic (repack) +import Test.Generator ((<#*|>), (<#*#>), (<#\#>)) import Test.Utility - (approx, approxArray, approxArrayTol, approxMatrix, - approxVector, equalArray, Tagged, (!|||), (!===)) + (approx, approxArray, approxMatrix, + equalArray, Tagged, (!|||), (!===)) +import qualified Numeric.LAPACK.Matrix.Quadratic as Quadratic import qualified Numeric.LAPACK.Matrix.Triangular as Triangular -import qualified Numeric.LAPACK.Matrix.Square as Square +import qualified Numeric.LAPACK.Matrix.Diagonal as Diagonal import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Layout as Layout import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import Numeric.LAPACK.Matrix.Triangular (Triangular) -import Numeric.LAPACK.Matrix - (General, ShapeInt, (#+#), (#-#), - (-*#), (##*#), (#*##), (#*|), (|||), (===)) -import Numeric.LAPACK.Vector (Vector, (|+|), (|-|)) +import Numeric.LAPACK.Matrix (General, ShapeInt, (|||), (===)) +import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, selectReal) import qualified Numeric.Netlib.Class as Class import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable ((!)) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import Control.Applicative ((<$>)) -import Data.Tuple.HT (mapFst, uncurry3) +import qualified Data.List as List +import Data.Tuple.HT (uncurry3) import Data.Semigroup ((<>)) import qualified Test.QuickCheck as QC --- cf. Test.Generic.addDistributive -addDistributive :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Eq lo, Eq up, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ((Triangular lo diag up ShapeInt a, - Triangular lo diag up ShapeInt a), - Vector ShapeInt a) -> - Bool -addDistributive ((a,b),x) = - approxVector - ((Triangular.strictNonUnitDiagonal a #+# - Triangular.strictNonUnitDiagonal b) #*| x) - (a#*|x |+| b#*|x) +data PowerStrip lower upper where + Diagonal :: PowerStrip MatrixShape.Empty MatrixShape.Empty + Lower :: PowerStrip MatrixShape.Filled MatrixShape.Empty + Upper :: PowerStrip MatrixShape.Empty MatrixShape.Filled -subDistributive :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Eq lo, Eq up, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ((Triangular lo diag up ShapeInt a, - Triangular lo diag up ShapeInt a), - Vector ShapeInt a) -> - Bool -subDistributive ((a,b),x) = - approxVector - ((Triangular.strictNonUnitDiagonal a #-# - Triangular.strictNonUnitDiagonal b) #*| x) - (a#*|x |-| b#*|x) +genTriangular :: + (MatrixShape.TriDiag diag, MatrixShape.DiagUpLo lo up) => + (Logic.Dim sh, Shape.Indexed sh, Shape.Index sh ~ ix, Eq ix, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + PowerStrip lo up -> + MatrixShape.DiagSingleton diag -> + Layout.PackingSingleton pack -> + Gen.Square sh a (ArrMatrix.Quadratic pack diag lo up sh a) +genTriangular _ _ p = repack p <$> Gen.triangular +type TriangularP pack lo diag up sh = ArrMatrix.Quadratic pack diag lo up sh +type FlexDiagonalP pack diag sh = + ArrMatrix.Quadratic pack diag MatrixShape.Empty MatrixShape.Empty sh +type FlexLowerP pack diag sh = + ArrMatrix.Quadratic pack diag MatrixShape.Filled MatrixShape.Empty sh +type FlexUpperP pack diag sh = + ArrMatrix.Quadratic pack diag MatrixShape.Empty MatrixShape.Filled sh + expandTriangle :: - (MatrixShape.Content lo, MatrixShape.TriDiag diag, MatrixShape.Content up, + (MatrixShape.PowerStrip lo, MatrixShape.TriDiag diag, MatrixShape.PowerStrip up, Shape.C sh, Class.Floating a) => - Triangular lo diag up sh a -> General sh sh a -expandTriangle = Matrix.fromFull . Triangular.toSquare + TriangularP pack lo diag up sh a -> General sh sh a +expandTriangle = Matrix.fromFull . Matrix.toFull transposedZero :: (Class.Floating a, Shape.C width, Shape.C height) => @@ -82,241 +86,164 @@ transposedZero = ArrMatrix.zero . ArrMatrix.shape . Matrix.transpose stackDiagonal :: + (Layout.Packing pack) => (MatrixShape.TriDiag diag, Class.Floating a) => - (Triangular.FlexDiagonal diag ShapeInt a, - Triangular.FlexDiagonal diag ShapeInt a) -> + (FlexDiagonalP pack diag ShapeInt a, + FlexDiagonalP pack diag ShapeInt a) -> Bool stackDiagonal (a,c) = - let ac = expandTriangle $ Triangular.stackDiagonal a c - b = Matrix.zero $ + let b = Matrix.zero $ MatrixShape.general MatrixShape.RowMajor (Matrix.height a) (Matrix.height c) - in equalArray ac $ + in equalArray + (expandTriangle $ Diagonal.stack a c) (expandTriangle a ||| b === Matrix.transpose b ||| expandTriangle c) stackLower :: + (Layout.Packing pack) => (MatrixShape.TriDiag diag, Class.Floating a) => - (Triangular.FlexLower diag ShapeInt a, + (FlexLowerP pack diag ShapeInt a, General ShapeInt ShapeInt a, - Triangular.FlexLower diag ShapeInt a) -> + FlexLowerP pack diag ShapeInt a) -> Bool stackLower (a,b,c) = - let abc = expandTriangle $ Triangular.stackLower a b c - in equalArray abc $ - (expandTriangle a !||| transposedZero b - === - b !||| expandTriangle c) + equalArray + (expandTriangle $ Triangular.stackLower a b c) + (expandTriangle a !||| transposedZero b + === + b !||| expandTriangle c) stackUpper :: + (Layout.Packing pack) => (MatrixShape.TriDiag diag, Class.Floating a) => - (Triangular.FlexUpper diag ShapeInt a, + (FlexUpperP pack diag ShapeInt a, General ShapeInt ShapeInt a, - Triangular.FlexUpper diag ShapeInt a) -> + FlexUpperP pack diag ShapeInt a) -> Bool stackUpper (a,b,c) = - let abc = expandTriangle $ Triangular.stackUpper a b c - in equalArray abc $ - (expandTriangle a ||| b - !=== - transposedZero b ||| expandTriangle c) - -stackSymmetric :: - (MatrixShape.TriDiag diag, Class.Floating a) => - (Triangular.FlexSymmetric diag ShapeInt a, - General ShapeInt ShapeInt a, - Triangular.FlexSymmetric diag ShapeInt a) -> - Bool -stackSymmetric (a,b,c) = - let abc = expandTriangle $ Triangular.stackSymmetric a b c - in equalArray abc $ - (expandTriangle a ||| b - !=== - Matrix.transpose b ||| expandTriangle c) + equalArray + (expandTriangle $ Triangular.stackUpper a b c) + (expandTriangle a ||| b + !=== + transposedZero b ||| expandTriangle c) splitDiagonal :: - (MatrixShape.TriDiag diag, Eq diag, Class.Floating a) => - Triangular.FlexDiagonal diag (ShapeInt:+:ShapeInt) a -> Bool + (Layout.Packing pack) => + (MatrixShape.TriDiag diag, Class.Floating a) => + FlexDiagonalP pack diag (ShapeInt::+ShapeInt) a -> Bool splitDiagonal abc = equalArray abc $ - uncurry Triangular.stackDiagonal $ Triangular.splitDiagonal abc + uncurry Diagonal.stack $ Diagonal.split abc splitLower :: - (MatrixShape.TriDiag diag, Eq diag, Class.Floating a) => - Triangular.FlexLower diag (ShapeInt:+:ShapeInt) a -> Bool + (Layout.Packing pack) => + (MatrixShape.TriDiag diag, Class.Floating a) => + FlexLowerP pack diag (ShapeInt::+ShapeInt) a -> Bool splitLower abc = equalArray abc $ uncurry3 Triangular.stackLower $ Triangular.splitLower abc splitUpper :: - (MatrixShape.TriDiag diag, Eq diag, Class.Floating a) => - Triangular.FlexUpper diag (ShapeInt:+:ShapeInt) a -> Bool + (Layout.Packing pack) => + (MatrixShape.TriDiag diag, Class.Floating a) => + FlexUpperP pack diag (ShapeInt::+ShapeInt) a -> Bool splitUpper abc = equalArray abc $ uncurry3 Triangular.stackUpper $ Triangular.splitUpper abc -splitSymmetric :: - (MatrixShape.TriDiag diag, Eq diag, Class.Floating a) => - Triangular.FlexSymmetric diag (ShapeInt:+:ShapeInt) a -> Bool -splitSymmetric abc = - equalArray abc $ - uncurry3 Triangular.stackSymmetric $ Triangular.splitSymmetric abc - -multiplyIdentityVector :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Vector ShapeInt a) -> Bool -multiplyIdentityVector (eye,a) = - approxVector a (Triangular.multiplyVector eye a) - -multiplyIdentityFull :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, General ShapeInt ShapeInt a) -> - Bool -multiplyIdentityFull (eye,a) = - approxArray a (Triangular.multiplyFull eye a) - multiplyIdentity :: + (Layout.Packing pack) => (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, - Eq lo, Eq diag, Eq up, + Eq lo, Eq up, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Triangular lo diag up ShapeInt a) -> + (TriangularP pack lo diag up ShapeInt a, + TriangularP pack lo diag up ShapeInt a) -> Bool multiplyIdentity (eye,a) = approxArray a (eye <> a) -multiplyVector :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Vector ShapeInt a) -> Bool -multiplyVector (a,x) = - approxVector - (Triangular.toSquare a #*| x) - (Triangular.multiplyVector a x) - multiply :: + (Layout.Packing pack) => (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Triangular lo diag up ShapeInt a) -> + (TriangularP pack lo diag up ShapeInt a, + TriangularP pack lo diag up ShapeInt a) -> Bool multiply (a,b) = approxArray - (Triangular.toSquare a <> Triangular.toSquare b) - (Triangular.toSquare $ a <> b) - -multiplyFull :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, General ShapeInt ShapeInt a) -> - Bool -multiplyFull (a,b) = - approxArray - (Triangular.toSquare a #*## b) - (Triangular.multiplyFull a b) - - -multiplyVectorLeft :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Vector ShapeInt a, Triangular lo diag up ShapeInt a) -> Bool -multiplyVectorLeft (x,a) = - approxVector (x -*# Triangular.toSquare a) (x -*# a) - -multiplyVectorRight :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Vector ShapeInt a) -> Bool -multiplyVectorRight (a,x) = - approxVector (Triangular.toSquare a #*| x) (a #*| x) - - -multiplyLeft :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (General ShapeInt ShapeInt a, Triangular lo diag up ShapeInt a) -> Bool -multiplyLeft (a,b) = - approxMatrix 1e-5 (a ##*# Triangular.toSquare b) (a ##*# b) - -multiplyRight :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, General ShapeInt ShapeInt a) -> Bool -multiplyRight (a,b) = - approxArray (Triangular.toSquare a #*## b) (a #*## b) + (Matrix.toFull a <> Matrix.toFull b) + (Matrix.toFull $ a <> b) genInvertible :: - (MatrixShape.Content up, MatrixShape.Content lo, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - GenTriangular lo diag up ShapeInt a -genInvertible = Gen.condition Util.invertible Gen.triangular - -inverse :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Triangular lo diag up ShapeInt a -> Bool -inverse a = - approxArrayTol - (selectReal 1 1e-5) - (Triangular.toSquare $ Triangular.inverse a) - (Square.inverse $ Triangular.toSquare a) - - -solve :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> - Bool -solve (a, b) = - approxMatrix (selectReal 1 1e-5) - (Triangular.solve a b) - (Square.solve (Triangular.toSquare a) b) - -solveIdentity :: - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular lo diag up ShapeInt a, Matrix.General ShapeInt ShapeInt a) -> - Bool -solveIdentity (eye, a) = - approxMatrix (selectReal 1e-3 1e-5) a (Triangular.solve eye a) + PowerStrip lo up -> + MatrixShape.DiagSingleton diag -> + Layout.PackingSingleton pack -> + GenTriangularP pack lo diag up ShapeInt a +genInvertible _cont _diag pack = + repack pack <$> Gen.condition Util.invertible Gen.triangular eigenvaluesDeterminant :: + (Layout.Packing pack) => (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Triangular lo diag up ShapeInt a -> Bool + TriangularP pack lo diag up ShapeInt a -> Bool eigenvaluesDeterminant a = approx (selectReal 1e-1 1e-5) - (Triangular.determinant a) + (Matrix.determinant a) (Vector.product $ Triangular.eigenvalues a) genDiagonalizable :: - (MatrixShape.Content lo, MatrixShape.Content up, + (MatrixShape.DiagUpLo lo up, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - GenTriangular lo MatrixShape.NonUnit up ShapeInt a -genDiagonalizable = + PowerStrip lo up -> + Layout.PackingSingleton pack -> + GenTriangularP pack lo MatrixShape.Arbitrary up ShapeInt a +genDiagonalizable _cont pack = + fmap (repack pack) $ flip Gen.mapGen Gen.triangularShape $ \maxElem shape -> do - d <- Util.genDistinct 3 10 $ MatrixShape.triangularSize shape + d <- Util.genDistinct [-3..3] [-10..10] $ MatrixShape.squareSize shape Util.genArrayExtraDiag maxElem shape (\r -> return (d!r)) +diagonal :: + (Layout.Packing pack) => + (MatrixShape.DiagUpLo lo up, Shape.C sh, Class.Floating a) => + MatrixShape.Order -> + Vector sh a -> TriangularP pack lo MatrixShape.Arbitrary up sh a +diagonal order v = + repack Layout.autoPacking $ + getDiagonal $ + MatrixShape.switchDiagUpLo + (Diagonal_ $ Quadratic.diagonal order v) + (Diagonal_ $ Quadratic.diagonal order v) + (Diagonal_ $ Quadratic.diagonal order v) + +newtype Diagonal_ sh a lo up = + Diagonal_ {getDiagonal :: Triangular lo MatrixShape.Arbitrary up sh a} + eigensystem :: + (Layout.Packing pack) => (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - MatrixShape.Order -> Triangular lo MatrixShape.NonUnit up ShapeInt a -> Bool + MatrixShape.Order -> + TriangularP pack lo MatrixShape.Arbitrary up ShapeInt a -> Bool eigensystem order a = let (vr,d,vl) = Triangular.eigensystem a scal = Triangular.takeDiagonal $ vl <> vr in approxMatrix (selectReal 1e-3 1e-5) a (vr <> - Triangular.diagonal order (Vector.divide d scal) + diagonal order (Vector.divide d scal) <> vl) @@ -333,245 +260,128 @@ checkForAllExtra = Gen.withExtra checkForAll -type GenTriangular lo diag up sh a = - Gen.Square sh a (Triangular lo diag up sh a) +type GenTriangularP pack lo diag up sh a = + Gen.Square sh a (TriangularP pack lo diag up sh a) -addSuperName :: String -> [(String, a)] -> [(String, a)] -addSuperName superName = map (mapFst ((superName++) . ("."++))) - -checkAnyFlexDiag :: +propCont :: (MatrixShape.TriDiag diag) => - String -> - (forall lo up. - (MatrixShape.Content lo, MatrixShape.Content up, - Eq lo, Eq up, Show lo, Show up) => - GenTriangular lo diag up sh a -> - Tagged a QC.Property) -> - (forall lo up. - (MatrixShape.Content lo, MatrixShape.Content up, - Eq lo, Eq up, Show lo, Show up) => - GenTriangular lo diag up sh a) -> - [(String, Tagged a QC.Property)] -checkAnyFlexDiag name checker gen = - (checkDiagUpLoFlexDiag name checker gen ++) $ - addSuperName name $ - ("Symmetric", checker (Triangular.asSymmetric <$> gen)) : - [] + MatrixShape.DiagSingleton diag -> + PowerStrip lo up -> Mosaic.Property diag lo up +propCont _diag cont = + case cont of + Diagonal -> Mosaic.Diagonal + Lower -> Mosaic.Lower + Upper -> Mosaic.Upper -checkAny :: - String -> - (forall lo up diag. - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Eq lo, Eq up, Show lo, Show up, Show diag) => - GenTriangular lo diag up sh a -> - Tagged a QC.Property) -> - (forall lo up diag. - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Eq lo, Eq up, Show lo, Show up, Show diag) => - GenTriangular lo diag up sh a) -> +testsVar :: + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => [(String, Tagged a QC.Property)] -checkAny name checker gen = - checkAnyFlexDiag (name++".Unit") checker - (Triangular.requireUnitDiagonal <$> gen) ++ - checkAnyFlexDiag (name++".NonUnit") checker - (Triangular.requireNonUnitDiagonal <$> gen) - +testsVar = + concat $ + List.transpose + [Util.suffix "Packed" (testsVarPacking Layout.Packed), + Util.suffix "Unpacked" (testsVarPacking Layout.Unpacked)] -checkDiagUpLoFlexDiag :: - (MatrixShape.TriDiag diag) => - String -> - (forall lo up. - (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, Show lo, Show up) => - GenTriangular lo diag up sh a -> - Tagged a QC.Property) -> - (forall lo up. - (MatrixShape.DiagUpLo lo up, Eq lo, Eq up, Show lo, Show up) => - GenTriangular lo diag up sh a) -> - [(String, Tagged a QC.Property)] -checkDiagUpLoFlexDiag name checker gen = - addSuperName name $ - ("Diagonal", checker (Triangular.asDiagonal <$> gen)) : - ("Lower", checker (Triangular.asLower <$> gen)) : - ("Upper", checker (Triangular.asUpper <$> gen)) : +testsVarPacking :: + (Layout.Packing pack) => + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsVarPacking p = + Util.prefix "Diagonal" (testsVarPowerStrip Diagonal p) ++ + Util.prefix "Lower" (testsVarPowerStrip Lower p) ++ + Util.prefix "Upper" (testsVarPowerStrip Upper p) ++ [] -checkDiagUpLo :: - String -> - (forall lo up diag. - (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, - Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => - GenTriangular lo diag up sh a -> Tagged a QC.Property) -> - (forall lo up diag. - (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag, - Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => - GenTriangular lo diag up sh a) -> - [(String, Tagged a QC.Property)] -checkDiagUpLo name checker gen = - checkDiagUpLoFlexDiag (name++".Unit") checker - (Triangular.requireUnitDiagonal <$> gen) ++ - checkDiagUpLoFlexDiag (name++".NonUnit") checker - (Triangular.requireNonUnitDiagonal <$> gen) - - -newtype Power diag sh a lo up = - Power {getPower :: GenTriangular lo diag up sh a -> Tagged a QC.Property} - -restrictDiagUpLo :: - (MatrixShape.DiagUpLo lo0 up0, MatrixShape.TriDiag diag0, - Eq lo0, Eq diag0, Eq up0, Show lo0, Show diag0, Show up0) => - (forall lo up diag. - (Triangular.PowerContentDiag lo diag up, - Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => - GenTriangular lo diag up sh a -> Tagged a QC.Property) -> - GenTriangular lo0 diag0 up0 sh a -> Tagged a QC.Property -restrictDiagUpLo f = - getPower $ MatrixShape.switchDiagUpLo (Power f) (Power f) (Power f) - -checkDiagUpLoSym :: - String -> - (forall lo up diag. - (Triangular.PowerContentDiag lo diag up, - Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => - GenTriangular lo diag up ShapeInt a -> Tagged a QC.Property) -> - (forall lo up diag. - (MatrixShape.Content lo, MatrixShape.Content up, MatrixShape.TriDiag diag, - Eq lo, Eq diag, Eq up, Show lo, Show diag, Show up) => - GenTriangular lo diag up ShapeInt a) -> - [(String, Tagged a QC.Property)] -checkDiagUpLoSym name checker gen = - (checkDiagUpLo name (restrictDiagUpLo checker) gen ++) $ - addSuperName name $ - ("Symmetric", checker (Triangular.asSymmetric <$> gen)) : - [] +testsVarPowerStrip :: + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up) => + (Layout.Packing pack) => + (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + PowerStrip lo up -> + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] +testsVarPowerStrip cont p = + Util.prefix "Unit" (testsVarExt cont MatrixShape.Unit p) ++ + Util.prefix "Arbitrary" (testsVarExt cont MatrixShape.Arbitrary p) ++ + ("addDistributive", + let gen = genTriangular cont MatrixShape.Arbitrary p + in checkForAll (Generic.genDistribution gen) Generic.addDistributive) : + ("subDistributive", + let gen = genTriangular cont MatrixShape.Arbitrary p + in checkForAll (Generic.genDistribution gen) Generic.subDistributive) : -checkFlexDiag :: - String -> - (forall diag. - (MatrixShape.TriDiag diag, Eq diag, Show diag) => - GenTriangular lo diag up sh a -> Tagged a QC.Property) -> - (forall diag. - (MatrixShape.TriDiag diag, Eq diag, Show diag) => - GenTriangular lo diag up sh a) -> - [(String, Tagged a QC.Property)] -checkFlexDiag name checker gen = - (name++".Unit", checker (Triangular.requireUnitDiagonal <$> gen)) : - (name++".NonUnit", checker (Triangular.requireNonUnitDiagonal <$> gen)) : + ("eigensystem", + checkForAllExtra Util.genOrder + (genDiagonalizable cont p) eigensystem) : [] - -testsVar :: +testsVarExt :: + (Layout.Packing pack) => + (MatrixShape.DiagUpLo lo up, Eq lo, Eq up) => + (MatrixShape.TriDiag diag) => (Show a, Show ar, Class.Floating a, Eq a, RealOf a ~ ar, Class.Real ar) => + PowerStrip lo up -> + MatrixShape.DiagSingleton diag -> + Layout.PackingSingleton pack -> [(String, Tagged a QC.Property)] -testsVar = - checkAny "index" - (\gen -> checkForAll (Indexed.genMatrixIndex gen) Indexed.unitDot) - Gen.triangular ++ - - checkFlexDiag "stackDiagonal" - (\gen -> checkForAll (Gen.stackDiagonal gen gen) stackDiagonal) - Gen.triangular ++ - checkFlexDiag "stackLower" - (\gen -> - checkForAll (Gen.stack3 gen (Matrix.transpose <$> Gen.matrix) gen) - stackLower) - Gen.triangular ++ - checkFlexDiag "stackUpper" - (\gen -> checkForAll (Gen.stack3 gen Gen.matrix gen) stackUpper) - Gen.triangular ++ - checkFlexDiag "stackSymmetric" - (\gen -> checkForAll (Gen.stack3 gen Gen.matrix gen) stackSymmetric) - Gen.triangular ++ - - checkFlexDiag "splitDiagonal" - (\gen -> checkForAll gen splitDiagonal) - Gen.triangular ++ - checkFlexDiag "splitLower" - (\gen -> checkForAll gen splitLower) - Gen.triangular ++ - checkFlexDiag "splitUpper" - (\gen -> checkForAll gen splitUpper) - Gen.triangular ++ - checkFlexDiag "splitSymmetric" - (\gen -> checkForAll gen splitSymmetric) - Gen.triangular ++ - - checkAny "forceOrder" - (\gen -> - checkForAllExtra Util.genOrder - ((,) <$> gen <#*|> Gen.vector) Generic.forceOrder) - Gen.triangular ++ - checkAny "addDistributive" - (\gen -> checkForAll (Generic.genDistribution gen) addDistributive) - Gen.triangular ++ - checkAny "subDistributive" - (\gen -> checkForAll (Generic.genDistribution gen) subDistributive) - Gen.triangular ++ +testsVarExt cont diag p = + ("index", + checkForAll + (Indexed.genMatrixIndex (genTriangular cont diag p)) + Indexed.unitDot) : + ("stack", + case cont of + Diagonal -> + let gen = genTriangular cont diag p + in checkForAll (Gen.stackDiagonal gen gen) stackDiagonal + Lower -> + let gen = genTriangular cont diag p + in checkForAll + (Gen.stack3 gen (Matrix.transpose <$> Gen.matrix) gen) + stackLower + Upper -> + let gen = genTriangular cont diag p + in checkForAll (Gen.stack3 gen Gen.matrix gen) stackUpper) : + ("split", + case cont of + Diagonal -> checkForAll (genTriangular cont diag p) splitDiagonal + Lower -> checkForAll (genTriangular cont diag p) splitLower + Upper -> checkForAll (genTriangular cont diag p) splitUpper) : + ("forceOrder", + checkForAllExtra Util.genOrder + ((,) <$> genTriangular cont diag p <#*|> Gen.vector) + Generic.forceOrder) : + ("forceOrderInverse", + checkForAll (genTriangular cont diag p) Generic.forceOrderInverse) : - checkAny "multiplyIdentityVector" - (\gen -> checkForAll ((,) <$> gen <#*|> Gen.vector) - multiplyIdentityVector) - (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ - checkAny "multiplyIdentityFull" - (\gen -> checkForAll ((,) <$> gen <#*#> Gen.matrix) multiplyIdentityFull) - (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ - checkDiagUpLo "multiplyIdentity" - (\gen -> checkForAll ((,) <$> gen <#*#> Gen.triangular) multiplyIdentity) - (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ - checkAny "multiplyVector" - (\gen -> checkForAll ((,) <$> gen <#*|> Gen.vector) multiplyVector) - Gen.triangular ++ - checkAny "multiplyFull" - (\gen -> checkForAll ((,) <$> gen <#*#> Gen.matrix) multiplyFull) - Gen.triangular ++ - checkAny "multiplyVectorLeft" - (\gen -> checkForAll ((,) <$> Gen.vector <-*#> gen) multiplyVectorLeft) - Gen.triangular ++ - checkAny "multiplyVectorRight" - (\gen -> checkForAll ((,) <$> gen <#*|> Gen.vector) multiplyVectorRight) - Gen.triangular ++ - checkAny "multiplyLeft" - (\gen -> checkForAll ((,) <$> Gen.matrix <#*#> gen) multiplyLeft) - Gen.triangular ++ - checkAny "multiplyRight" - (\gen -> checkForAll ((,) <$> gen <#*#> Gen.matrix) multiplyRight) - Gen.triangular ++ + Mosaic.testsVar (propCont diag cont) p ++ - checkDiagUpLo "multiply" - (\gen -> checkForAll ((,) <$> gen <#*#> gen) multiply) - Gen.triangular ++ - checkDiagUpLoSym "multiplySquare" - (\gen -> checkForAll gen Multiply.multiplySquare) - Gen.triangular ++ - checkDiagUpLoSym "squareSquare" - (\gen -> checkForAll gen Multiply.squareSquare) - Gen.triangular ++ - checkDiagUpLoSym "power" - (\gen -> checkForAllExtra (QC.choose (0,10::Int)) gen Multiply.power) - Gen.triangular ++ + ("multiplyIdentity", + checkForAll + ((,) <$> Mosaic.genIdentity (propCont diag cont) p + <#*#> genTriangular cont diag p) + multiplyIdentity) : + ("multiply", + let gen = genTriangular cont diag p + in checkForAll ((,) <$> gen <#*#> gen) multiply) : - checkAny "determinant" - (\gen -> checkForAll gen Divide.determinant) - Gen.triangular ++ - checkAny "solve" - (\gen -> checkForAll ((,) <$> gen <#\#> Gen.matrix) solve) - genInvertible ++ - checkAny "solveIdentity" - (\gen -> checkForAll ((,) <$> gen <#\#> Gen.matrix) solveIdentity) - (Triangular.relaxUnitDiagonal <$> Gen.identity) ++ - checkAny "inverse" - (\gen -> checkForAll gen inverse) - genInvertible ++ - concatMap + ("determinant", + checkForAll (genTriangular cont diag p) Divide.determinant) : + ("solve", + checkForAll + ((,) <$> genInvertible cont diag p <#\#> Gen.matrix) + Divide.solve) : + ("solveIdentity", + checkForAll + ((,) <$> Mosaic.genIdentity (propCont diag cont) p <#\#> Gen.matrix) + Divide.solveIdentity) : + ("inverse", + checkForAll (genInvertible cont diag p) Divide.inverse) : + map (\(name,test) -> - checkAny name (test . fmap Divide.SquareMatrix) genInvertible) + (name, test $ fmap Divide.SquareMatrix $ genInvertible cont diag p)) Divide.testsVarAny ++ - checkDiagUpLo "eigenvaluesDeterminant" - (\gen -> checkForAll gen eigenvaluesDeterminant) - Gen.triangular ++ - checkDiagUpLoFlexDiag "eigensystem" - (\gen -> checkForAllExtra Util.genOrder gen eigensystem) - genDiagonalizable ++ + ("eigenvaluesDeterminant", + checkForAll (genTriangular cont diag p) eigenvaluesDeterminant) : [] diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs --- a/test/Test/Utility.hs +++ b/test/Test/Utility.hs @@ -1,16 +1,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ConstraintKinds #-} module Test.Utility where import qualified Numeric.LAPACK.Matrix.Hermitian as Herm import qualified Numeric.LAPACK.Matrix.Array as ArrMatrix +import qualified Numeric.LAPACK.Matrix.Shape as MatrixShape +import qualified Numeric.LAPACK.Matrix.Shape.Omni as Omni import qualified Numeric.LAPACK.Matrix.Extent as Extent import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Orthogonal.Householder as HH import qualified Numeric.LAPACK.Orthogonal as Ortho import Numeric.LAPACK.Matrix.Array (ArrayMatrix) -import Numeric.LAPACK.Matrix.Shape (Order(RowMajor,ColumnMajor)) +import Numeric.LAPACK.Matrix.Shape.Omni (Omni) +import Numeric.LAPACK.Matrix.Layout (Order(RowMajor,ColumnMajor)) import Numeric.LAPACK.Matrix (Matrix, ShapeInt) import Numeric.LAPACK.Vector (Vector) import Numeric.LAPACK.Scalar (RealOf, absolute) @@ -20,7 +24,7 @@ import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable (Array) -import Data.Array.Comfort.Shape ((:+:)) +import Data.Array.Comfort.Shape ((::+)) import qualified Control.Monad.Trans.State as MS import Control.Monad (replicateM) @@ -32,6 +36,7 @@ import Data.Traversable (traverse) import Data.Monoid (Monoid(mempty,mappend)) import Data.Semigroup (Semigroup((<>))) +import Data.Tuple.HT (mapFst) import Data.Eq.HT (equating) import qualified Test.QuickCheck as QC @@ -73,13 +78,18 @@ else error "equalArray: shapes mismatch" equalArray :: - (Shape.C shape, Eq shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -> Bool -equalArray x y = equalVector (ArrMatrix.toVector x) (ArrMatrix.toVector y) + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool +equalArray x y = equalVector (ArrMatrix.unwrap x) (ArrMatrix.unwrap y) equalMatrix :: - (ArrMatrix.ShapeOrder shape, Eq shape, Class.Floating a) => - ArrayMatrix shape a -> ArrayMatrix shape a -> Bool + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width, Class.Floating a) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool equalMatrix x y = equalArray (Matrix.adaptOrder y x) y @@ -114,33 +124,48 @@ approxArrayTol :: - (Shape.C shape, Eq shape, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ar -> ArrayMatrix shape a -> ArrayMatrix shape a -> Bool + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool approxArrayTol tol x y = - approxVectorTol tol (ArrMatrix.toVector x) (ArrMatrix.toVector y) + approxVectorTol tol (ArrMatrix.unwrap x) (ArrMatrix.unwrap y) approxArray :: - (Shape.C shape, Eq shape, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ArrayMatrix shape a -> ArrayMatrix shape a -> Bool -approxArray x y = approxVector (ArrMatrix.toVector x) (ArrMatrix.toVector y) + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool +approxArray x y = approxVector (ArrMatrix.unwrap x) (ArrMatrix.unwrap y) approxMatrix :: - (ArrMatrix.ShapeOrder shape, Eq shape, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ar -> ArrayMatrix shape a -> ArrayMatrix shape a -> Bool + (MatrixShape.PowerStrip lower, MatrixShape.PowerStrip upper) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Eq height, Eq width) => + (Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> + ArrayMatrix pack property lower upper meas vert horiz height width a -> Bool approxMatrix tol x y = approxArrayTol tol x $ Matrix.adaptOrder x y maybeConjugate :: - (Matrix.Complex typ, Class.Floating a) => - HH.Conjugation -> Matrix typ a -> Matrix typ a + (Matrix.Complex typ) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + HH.Conjugation -> + Matrix typ xl xu lower upper meas vert horiz height width a -> + Matrix typ xl xu lower upper meas vert horiz height width a maybeConjugate HH.NonConjugated = id maybeConjugate HH.Conjugated = Matrix.conjugate -type NonEmptyInt = ():+:ShapeInt +type NonEmptyInt = ()::+ShapeInt type EInt = Either () Int @@ -161,39 +186,76 @@ Array.fromList shape <$> replicateM (Shape.size shape) (genElement maxElem) genArray :: - (Shape.C shape, Class.Floating a) => - Integer -> shape -> QC.Gen (ArrayMatrix shape a) -genArray maxElem shape = fmap ArrMatrix.lift0 $ genVector maxElem shape + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width, Class.Floating a) => + Integer -> + Omni pack property lower upper meas vert horiz height width -> + QC.Gen (ArrayMatrix pack property lower upper meas vert horiz height width a) +genArray maxElem shape = fmap ArrMatrix.Array $ genVector maxElem shape genArrayIndexed :: (Shape.Indexed shape, Class.Floating a) => - shape -> (Shape.Index shape -> QC.Gen a) -> QC.Gen (ArrayMatrix shape a) + shape -> (Shape.Index shape -> QC.Gen a) -> QC.Gen (Array shape a) genArrayIndexed shape f = - ArrMatrix.lift0 . Array.fromList shape <$> traverse f (Shape.indices shape) + Array.fromList shape <$> traverse f (Shape.indices shape) -genArrayExtraDiag :: +genArrayExtraDiag_ :: + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Shape.C width) => (Shape.Indexed shape, Shape.Index shape ~ (i,i), Eq i, Class.Floating a) => - Integer -> shape -> (i -> QC.Gen a) -> QC.Gen (ArrayMatrix shape a) -genArrayExtraDiag maxElem shape diag = - genArrayIndexed shape $ + Integer -> + (Omni pack property lower upper meas vert horiz height width -> shape) -> + Omni pack property lower upper meas vert horiz height width -> + (i -> QC.Gen a) -> + QC.Gen (ArrayMatrix pack property lower upper meas vert horiz height width a) +genArrayExtraDiag_ maxElem toPlainShape shape diag = + fmap (ArrMatrix.Array . Array.reshape shape) $ + genArrayIndexed (toPlainShape shape) $ \(r,c) -> if r==c then diag r else genElement maxElem +genArrayExtraDiag :: + (MatrixShape.Packing pack) => + (MatrixShape.DiagUpLo lo up, MatrixShape.TriDiag diag) => + (Shape.C sh, Shape.Indexed sh, Shape.Index sh ~ i, Eq i) => + (Class.Floating a) => + Integer -> + MatrixShape.Quadratic pack diag lo up sh -> + (i -> QC.Gen a) -> + QC.Gen (ArrMatrix.Quadratic pack diag lo up sh a) +genArrayExtraDiag maxElem shape0 diag = + flip runGenTriangularLoUp shape0 $ + MatrixShape.switchDiagUpLo + (GenTriangularLoUp $ + \shape -> + fmap (ArrMatrix.Array . Array.reshape shape) $ + genArrayIndexed (MatrixShape.squareSize shape) diag) + (GenTriangularLoUp $ + \shape -> genArrayExtraDiag_ maxElem Omni.toPlain shape diag) + (GenTriangularLoUp $ + \shape -> genArrayExtraDiag_ maxElem Omni.toPlain shape diag) +newtype GenTriangularLoUp pack diag sh a lo up = + GenTriangularLoUp { + runGenTriangularLoUp :: + MatrixShape.Quadratic pack diag lo up sh -> + QC.Gen (ArrMatrix.Quadratic pack diag lo up sh a) + } + + select :: [a] -> QC.Gen (a, [a]) select = QC.elements . ListHT.removeEach genDistinct :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Integer -> Integer -> ShapeInt -> QC.Gen (Vector ShapeInt a) -genDistinct maxElemS maxElemD size@(Shape.ZeroBased n) = do - let range k = map fromInteger [(-k)..k] + [Integer] -> [Integer] -> ShapeInt -> QC.Gen (Vector ShapeInt a) +genDistinct elemsS elemsD size@(Shape.ZeroBased n) = do + let range ks = map fromInteger ks fmap (Vector.fromList size) $ MS.evalStateT (replicateM n $ MS.StateT select) $ Class.switchFloating - (range maxElemS) - (range maxElemD) - (liftA2 (:+) (range maxElemS) (range maxElemS)) - (liftA2 (:+) (range maxElemD) (range maxElemD)) + (range elemsS) (range elemsD) + (liftA2 (:+) (range elemsS) (range elemsS)) + (liftA2 (:+) (range elemsD) (range elemsD)) genOrder :: QC.Gen Order @@ -202,8 +264,10 @@ invertible :: - (Matrix.Determinant typ, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - Matrix typ a -> Bool + (Matrix.Determinant typ xl xu, + MatrixShape.Strip lower, MatrixShape.Strip upper, + Shape.C sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + Matrix.Quadratic typ xl xu lower upper sh a -> Bool invertible a = absolute (Matrix.determinant a) > 0.1 fullRankTall :: @@ -214,22 +278,31 @@ isIdentity :: - (ArrMatrix.SquareShape shape, ArrMatrix.ShapeOrder shape, Eq shape, - Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ar -> ArrayMatrix shape a -> Bool + (Omni.Quadratic pack property lower upper, + Omni.Quadratic pack property upper lower, + Shape.C sh, Eq sh, Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> + ArrMatrix.Quadratic pack property lower upper sh a -> + Bool isIdentity tol eye = approxArrayTol tol eye (Matrix.identityFrom eye) isUnitary :: - (Extent.C vert, Class.Floating a, RealOf a ~ ar, Class.Real ar) => - ar -> Matrix.Full vert Extent.Small ShapeInt ShapeInt a -> Bool -isUnitary tol = isIdentity tol . Herm.gramian . Matrix.fromFull + (Extent.Measure meas, Extent.C vert, + Class.Floating a, RealOf a ~ ar, Class.Real ar) => + ar -> Matrix.Full meas vert Extent.Small ShapeInt ShapeInt a -> Bool +isUnitary tol = + isIdentity tol . ArrMatrix.asPacked . Herm.gramian . Matrix.fromFull addMatrices :: - (ArrMatrix.Homogeneous sh, Eq sh, Class.Floating a) => - sh -> [ArrayMatrix sh a] -> ArrayMatrix sh a -addMatrices sh = foldl (ArrMatrix.lift2 Vector.add) (ArrMatrix.zero sh) + (ArrMatrix.Homogeneous property) => + (Extent.Measure meas, Extent.C vert, Extent.C horiz) => + (Shape.C height, Eq height, Shape.C width, Eq width, Class.Floating a) => + Omni pack property lower upper meas vert horiz height width -> + [ArrayMatrix pack property lower upper meas vert horiz height width a] -> + ArrayMatrix pack property lower upper meas vert horiz height width a +addMatrices sh = foldl (ArrMatrix.liftOmni2 Vector.add) (ArrMatrix.zero sh) @@ -241,7 +314,7 @@ Class.Floating a) => Matrix.General height widthA a -> Matrix.General height widthB a -> - Matrix.General height (widthA:+:widthB) a + Matrix.General height (widthA::+widthB) a (!|||) = Matrix.beside Matrix.leftBias Extent.appendAny (!===) :: @@ -249,7 +322,7 @@ Class.Floating a) => Matrix.General heightA width a -> Matrix.General heightB width a -> - Matrix.General (heightA:+:heightB) width a + Matrix.General (heightA::+heightB) width a (!===) = Matrix.above Matrix.leftBias Extent.appendAny @@ -308,5 +381,7 @@ prefix :: String -> [(String, test)] -> [(String, test)] -prefix msg = - map (\(str,test) -> (msg ++ "." ++ str, test)) +prefix msg = map $ mapFst (\str -> msg ++ "." ++ str) + +suffix :: String -> [(String, test)] -> [(String, test)] +suffix msg = map $ mapFst (\str -> str ++ "." ++ msg) diff --git a/test/Test/Vector.hs b/test/Test/Vector.hs --- a/test/Test/Vector.hs +++ b/test/Test/Vector.hs @@ -7,6 +7,7 @@ import Test.Utility (Tagged, NonEmptyInt, EInt) import qualified Numeric.LAPACK.Matrix.Triangular as Triangular +import qualified Numeric.LAPACK.Matrix as Matrix import qualified Numeric.LAPACK.Vector as Vector import qualified Numeric.LAPACK.Scalar as Scalar import Numeric.LAPACK.Matrix (ShapeInt, shapeInt, (-/#)) @@ -182,9 +183,22 @@ Util.equalVector (Vector.mac a xs ys) (a.*|xs |+| ys) +mul :: + (Eq a, Class.Floating a) => (Vector ShapeInt a, Vector ShapeInt a) -> Bool +mul (xs,ys) = + Vector.toList (Vector.mul xs ys) + == + zipWith (*) (Vector.toList xs) (Vector.toList ys) + +mulConj :: + (Eq a, Class.Floating a) => (Vector ShapeInt a, Vector ShapeInt a) -> Bool +mulConj (xs,ys) = + Util.equalVector (Vector.mulConj xs ys) (Vector.mul (Vector.conjugate xs) ys) + + divide :: (Class.Floating a, RealOf a ~ ar, Class.Real ar) => - (Triangular.Diagonal ShapeInt a, Vector ShapeInt a) -> Bool + (Matrix.Diagonal ShapeInt a, Vector ShapeInt a) -> Bool divide (a,b) = Util.approxVector (b -/# a) @@ -248,6 +262,10 @@ checkForAll ((,,) <$> Gen.scalar <.*#> Gen.vector <|=|> Gen.vector) addScaleMac) : + ("mul", + checkForAll ((,) <$> Gen.vector <|=|> Gen.vector) mul) : + ("mulConj", + checkForAll ((,) <$> Gen.vector <|=|> Gen.vector) mulConj) : ("divide", checkForAll ((,) <$> Gen.condition Util.invertible Gen.diagonal <#*|> Gen.vector)