├── .gitmodules
├── sparse-linear
    ├── default.nix
    ├── Setup.hs
    ├── shell.nix
    ├── src
    │   └── Data
    │   │   ├── Vector
    │   │       ├── Sparse.hs-boot
    │   │       ├── Util.hs
    │   │       ├── Sparse
    │   │       │   └── ScatterGather.hs
    │   │       └── Sparse.hs
    │   │   ├── Complex
    │   │       └── Enhanced.hs
    │   │   └── Matrix
    │   │       ├── Sparse
    │   │           └── Foreign.hs
    │   │       └── Sparse.hs
    ├── shell-profiling.nix
    ├── sparse-linear.nix
    ├── README.md
    ├── sparse-linear.cabal
    ├── LICENSE
    └── tests
    │   ├── Test
    │       └── LinearAlgebra.hs
    │   └── Sparse.hs
├── .gitignore
├── feast
    ├── Setup.hs
    ├── shell.nix
    ├── default.nix
    ├── tests
    │   └── test-feast.hs
    ├── feast.cabal
    ├── src
    │   └── Numeric
    │   │   └── LinearAlgebra
    │   │       ├── Feast
    │   │           └── Internal.hs
    │   │       └── Feast.hs
    └── LICENSE
├── suitesparse
    ├── Setup.hs
    ├── shell.nix
    ├── tests
    │   ├── test-umfpack.hs
    │   └── Test
    │   │   └── LinearAlgebra.hs
    ├── default.nix
    ├── suitesparse.cabal
    ├── src
    │   └── Numeric
    │   │   └── LinearAlgebra
    │   │       ├── Umfpack.hs
    │   │       └── Umfpack
    │   │           └── Internal.hs
    └── LICENSE
├── .travis.yml
├── TODO.org
└── README.md


/.gitmodules:
--------------------------------------------------------------------------------
1 | 


--------------------------------------------------------------------------------
/sparse-linear/default.nix:
--------------------------------------------------------------------------------
1 | sparse-linear.nix


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | dist/
2 | .*.sw*
3 | *.prof
4 | .result*
5 | .shell*
6 | 


--------------------------------------------------------------------------------
/feast/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/sparse-linear/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/suitesparse/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/sparse-linear/shell.nix:
--------------------------------------------------------------------------------
1 | with (import <nixpkgs> {});
2 | haskellPackages.callPackage ./. {}
3 | 


--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
 1 | language: haskell
 2 | sudo: false
 3 | ghc:
 4 |   - 7.8
 5 | 
 6 | addons:
 7 |   apt:
 8 |     packages:
 9 |       - libblas-dev
10 |       - liblapack-dev
11 | 
12 | before_install:
13 |   - cd sparse-linear


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Vector/Sparse.hs-boot:
--------------------------------------------------------------------------------
 1 | module Data.Vector.Sparse where
 2 | 
 3 | import qualified Data.Vector.Unboxed as U
 4 | 
 5 | data Vector v a
 6 |   = Vector { length :: !Int
 7 |            , indices :: U.Vector Int
 8 |            , values :: v a
 9 |            }
10 | 


--------------------------------------------------------------------------------
/TODO.org:
--------------------------------------------------------------------------------
1 | * TODO Export type synonyms
2 |   Specifying the underlying storage type for `Matrix` and `Vector` is
3 |   inconvenient and abstraction-breaking. We should export modules that
4 |   have `Matrix` and `Vector` defined as type synonyms for common
5 |   storage types, like Unboxed or Storable.
6 | 


--------------------------------------------------------------------------------
/sparse-linear/shell-profiling.nix:
--------------------------------------------------------------------------------
 1 | with (import <nixpkgs> {});
 2 | let
 3 |   enableProfiling = drv: drv.overrideScope (self: super: {
 4 |     mkDerivation = drv: super.mkDerivation (drv // {
 5 |       enableLibraryProfiling = true;
 6 |     });
 7 |     inherit (pkgs) stdenv;
 8 |   });
 9 | in (enableProfiling (haskellngPackages.callPackage ./. {})).env
10 | 


--------------------------------------------------------------------------------
/suitesparse/shell.nix:
--------------------------------------------------------------------------------
 1 | with (import <nixpkgs> {});
 2 | let
 3 |   inherit (pkgs.haskell.lib) dontCheck;
 4 |   haskellPackages = pkgs.haskellPackages.override {
 5 |     overrides = self: super: {
 6 |       sparse-linear = self.callPackage ../sparse-linear {};
 7 |       suitesparse = self.callPackage ../suitesparse {
 8 |         inherit (pkgs) suitesparse;
 9 |         openblas = pkgs.openblasCompat;
10 |       };
11 |     };
12 |   };
13 | in haskellPackages.suitesparse
14 | 


--------------------------------------------------------------------------------
/feast/shell.nix:
--------------------------------------------------------------------------------
 1 | with (import <nixpkgs> {});
 2 | let
 3 |   inherit (pkgs.haskell.lib) dontCheck;
 4 |   haskellPackages = pkgs.haskellPackages.override {
 5 |     overrides = self: super: {
 6 |       feast = self.callPackage ./. {
 7 |         inherit (pkgs) feast;
 8 |       };
 9 |       sparse-linear = self.callPackage ../sparse-linear {};
10 |       suitesparse = self.callPackage ../suitesparse {
11 |         inherit (pkgs) suitesparse;
12 |         openblas = pkgs.openblasCompat;
13 |       };
14 |     };
15 |   };
16 | in haskellPackages.feast
17 | 


--------------------------------------------------------------------------------
/suitesparse/tests/test-umfpack.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import Data.Vector.Unboxed (Vector)
 4 | import qualified Data.Vector.Unboxed as V
 5 | import Test.Hspec
 6 | import Test.QuickCheck
 7 | 
 8 | import Data.Matrix.Sparse
 9 | import Numeric.LinearAlgebra.Umfpack
10 | import Test.LinearAlgebra ()
11 | 
12 | main :: IO ()
13 | main = hspec $ do
14 |   describe "Numeric.LinearAlgebra.Umfpack" $ do
15 | 
16 |     it "ident <\\> v == v" $ property prop_linSolveId
17 | 
18 | prop_linSolveId :: Vector (Complex Double) -> Bool
19 | prop_linSolveId v = ident (V.length v) <\> v == v
20 | 


--------------------------------------------------------------------------------
/sparse-linear/sparse-linear.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, base, base-orphans, binary, hmatrix, hspec
 2 | , mono-traversable, primitive, QuickCheck, stdenv, tagged, vector
 3 | , vector-algorithms
 4 | }:
 5 | mkDerivation {
 6 |   pname = "sparse-linear";
 7 |   version = "0.1.0.0";
 8 |   src = ./.;
 9 |   buildDepends = [
10 |     base base-orphans binary hmatrix mono-traversable primitive tagged
11 |     vector vector-algorithms
12 |   ];
13 |   testDepends = [ base hspec mono-traversable QuickCheck vector ];
14 |   description = "Sparse linear algebra primitives in Haskell";
15 |   license = stdenv.lib.licenses.bsd3;
16 | }
17 | 


--------------------------------------------------------------------------------
/feast/default.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, base, feast, global-lock, hmatrix, hspec, mtl
 2 | , primitive, QuickCheck, sparse-linear, stdenv, suitesparse
 3 | , transformers, vector
 4 | }:
 5 | mkDerivation {
 6 |   pname = "feast";
 7 |   version = "0.1.0.0";
 8 |   src = ./.;
 9 |   libraryHaskellDepends = [
10 |     base global-lock hmatrix mtl primitive sparse-linear suitesparse
11 |     transformers vector
12 |   ];
13 |   librarySystemDepends = [ feast ];
14 |   testHaskellDepends = [
15 |     base hspec QuickCheck sparse-linear suitesparse vector
16 |   ];
17 |   description = "Haskell bindings to the FEAST eigensolver library";
18 |   license = stdenv.lib.licenses.gpl2;
19 | }
20 | 


--------------------------------------------------------------------------------
/suitesparse/default.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, base, hmatrix, hspec, mono-traversable, openblas
 2 | , primitive, QuickCheck, sparse-linear, stdenv, suitesparse, vector
 3 | , vector-algorithms
 4 | }:
 5 | mkDerivation {
 6 |   pname = "suitesparse";
 7 |   version = "0.1.0.0";
 8 |   src = ./.;
 9 |   buildDepends = [
10 |     base hmatrix mono-traversable primitive sparse-linear vector
11 |     vector-algorithms
12 |   ];
13 |   testDepends = [ base hspec QuickCheck sparse-linear vector ];
14 |   extraLibraries = [ openblas suitesparse ];
15 |   description = "Haskell bindings to the SuiteSparse library of sparse linear algebra routines";
16 |   license = stdenv.lib.licenses.gpl2;
17 | }
18 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # sparse-linear
 2 | 
 3 | The libraries herein are works-in-progress, but suitable for
 4 | experimentation.
 5 | 
 6 | `sparse-linear` aims to be a basic set of routines for constructing
 7 | and manipulating sparse and dense matrices in a variety of
 8 | formats. Matrices can be constructed using high-level combinators
 9 | because stream fusion (provided by the `vector` library) is effective
10 | at eliminating intermediate values. Low-level operations akin to
11 | BLAS are also provided.
12 | 
13 | `suitesparse` is a set of bindings to the SuiteSparse libraries. At this
14 | time, only bindings for the UMFPACK library (sparse, multifrontal LU
15 | factorization) are implemented. The bindings utilize the data formats
16 | provided by `sparse-linear`.
17 | 
18 | `feast` is a set of bindings to the FEAST eigensolver. The bindings
19 | utilize `sparse-linear` for data formats and `suitesparse` for
20 | factorization.


--------------------------------------------------------------------------------
/sparse-linear/README.md:
--------------------------------------------------------------------------------
 1 | sparse-linear
 2 | =============
 3 | 
 4 | Traditional sparse linear algebra in Haskell
 5 | 
 6 | [![Build Status](https://travis-ci.org/ttuegel/sparse-linear.svg?branch=master)](https://travis-ci.org/ttuegel/sparse-linear)
 7 | 
 8 | `sparse-linear` provides sparse matrices in Haskell. Traditional matrix formats
 9 | (coordinate list, compressed row, compressed column) are provided for
10 | interoperability with existing libraries in other languages.
11 | 
12 | Unlike other sparse linear algebra libraries in Haskell, `sparse-linear` uses
13 | the type system to ensure efficiency. The provided `Matrix` type reflects the
14 | storage format used so that the most efficient types for each operation can be
15 | required at compile-time. By supporting multiple matrix formats, `sparse-linear`
16 | can also efficiently support a wider variety of operations than other Haskell
17 | sparse linear algebra libraries. For example, `sparse-linear` is the only
18 | library at this time to support sparse-matrix/dense-vector products, a common
19 | idiom in sparse algorithms.
20 | 


--------------------------------------------------------------------------------
/feast/tests/test-feast.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DataKinds #-}
 2 | {-# LANGUAGE FlexibleContexts #-}
 3 | 
 4 | module Main where
 5 | 
 6 | import qualified Data.Vector.Storable as V
 7 | import qualified Data.Vector.Unboxed as U
 8 | import Test.Hspec
 9 | import Test.QuickCheck
10 | 
11 | import Data.Matrix.Sparse
12 | import Numeric.LinearAlgebra.Feast
13 | 
14 | (~==) :: (IsReal a, Eq a, Fractional a, Fractional (RealOf a), Num a, Ord (RealOf a), Show a, V.Storable a, V.Storable (RealOf a)) => V.Vector a -> V.Vector a -> Property
15 | (~==) a b =
16 |   counterexample (show a ++ " /= " ++ show b)
17 |   $ V.and (V.zipWith (\x y -> x == y || x `closeEnoughTo` y) a b)
18 |   where
19 |     closeEnoughTo x y = mag (x - y) / mag (x + y) < 1E-10
20 | 
21 | main :: IO ()
22 | main = hspec $ do
23 |   describe "eigSH" $ do
24 |     let m :: Matrix U.Vector (Complex Double)
25 |         m = fromTriples 2 2 [(0, 0, 2), (0, 1, -1), (1, 0, -1), (1, 1, 2)]
26 |         params = defaultFeastParams { feastDebug = True }
27 |         eigenvalues = fst $ eigSHParams params 2 (0, 4) m
28 |         correct = V.fromList [1, 3]
29 |     it "gives the correct number of eigenvalues"
30 |       $ property (V.length eigenvalues === V.length correct)
31 |     it "gives the correct eigenvalues"
32 |       $ property (eigenvalues ~== correct)
33 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Complex/Enhanced.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE CPP #-}
 2 | {-# LANGUAGE ConstrainedClassMethods #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | {-# LANGUAGE FlexibleInstances #-}
 5 | {-# LANGUAGE TypeFamilies #-}
 6 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 7 | 
 8 | module Data.Complex.Enhanced
 9 |        ( RealOf, ComplexOf, IsReal(..), IsImag(..)
10 |        , Complex(..)
11 |        , realPart, imagPart
12 |        ) where
13 | 
14 | #if __GLASGOW_HASKELL__ < 710
15 | import Control.Applicative
16 | #endif
17 | import Data.Complex
18 | import Data.Orphans ()
19 | 
20 | type family RealOf a where
21 |   RealOf (Complex a) = a
22 |   RealOf a = a
23 | 
24 | type family ComplexOf a where
25 |   ComplexOf (Complex a) = Complex a
26 |   ComplexOf a = a
27 | 
28 | class IsReal a where
29 |   real :: Num (RealOf a) => RealOf a -> a
30 |   conj :: a -> a
31 |   mag :: a -> RealOf a
32 | 
33 | class IsImag a where
34 |   imag :: Num (RealOf a) => RealOf a -> a
35 | 
36 | instance IsReal Double where
37 |   {-# INLINE real #-}
38 |   {-# INLINE conj #-}
39 |   {-# INLINE mag #-}
40 |   real = id
41 |   conj = id
42 |   mag = abs
43 | 
44 | instance IsReal (Complex Double) where
45 |   {-# INLINE real #-}
46 |   {-# INLINE conj #-}
47 |   {-# INLINE mag #-}
48 |   real = (:+ 0)
49 |   conj = conjugate
50 |   mag = magnitude
51 | 
52 | instance IsImag (Complex Double) where
53 |   {-# INLINE imag #-}
54 |   imag = (0 :+)
55 | 


--------------------------------------------------------------------------------
/feast/feast.cabal:
--------------------------------------------------------------------------------
 1 | name:                feast
 2 | version:             0.1.0.0
 3 | synopsis: Haskell bindings to the FEAST eigensolver library
 4 | license:             GPL-2
 5 | license-file:        LICENSE
 6 | author:              Thomas Tuegel
 7 | maintainer:          ttuegel@gmail.com
 8 | copyright:           (c) 2014 Thomas Tuegel
 9 | category:            Math
10 | build-type:          Simple
11 | cabal-version:       >=1.10
12 | 
13 | library
14 |   exposed-modules:
15 |     Numeric.LinearAlgebra.Feast
16 |     Numeric.LinearAlgebra.Feast.Internal
17 |   build-depends:
18 |       base >= 4.7 && < 5
19 |     , global-lock >=0.1 && <1
20 |     , hmatrix >=0.16 && <1
21 |     , mtl >= 2.1 && <3
22 |     , primitive >=0.5 && <1
23 |     , sparse-linear >=0.1 && <1
24 |     , suitesparse >=0.1 && <1
25 |     , transformers >=0.3 && <1
26 |     , vector >=0.10 && <1
27 |   hs-source-dirs: src
28 |   default-language: Haskell2010
29 |   ghc-options: -Wall
30 |   ghc-prof-options: -fprof-auto
31 |   extra-libraries:
32 |     feast
33 | 
34 | test-suite test-feast
35 |   type: exitcode-stdio-1.0
36 |   hs-source-dirs: tests
37 |   main-is: test-feast.hs
38 |   default-language: Haskell2010
39 |   ghc-options: -Wall -threaded
40 |   ghc-prof-options: -fprof-auto
41 |   build-depends:
42 |       base
43 |     , feast
44 |     , hspec >=2.1 && <3
45 |     , QuickCheck >=2.7 && <3
46 |     , sparse-linear
47 |     , suitesparse
48 |     , vector >=0.10 && <1
49 | 


--------------------------------------------------------------------------------
/sparse-linear/sparse-linear.cabal:
--------------------------------------------------------------------------------
 1 | name: sparse-linear
 2 | version: 0.1.0.0
 3 | synopsis: Sparse linear algebra primitives in Haskell
 4 | license: BSD3
 5 | license-file: LICENSE
 6 | author: Thomas Tuegel
 7 | maintainer: ttuegel@gmail.com
 8 | copyright: (c) 2014 Thomas Tuegel
 9 | category: Math
10 | build-type: Simple
11 | cabal-version: >=1.10
12 | 
13 | library
14 |   exposed-modules:
15 |     Data.Complex.Enhanced
16 |     Data.Matrix.Sparse
17 |     Data.Matrix.Sparse.Foreign
18 |     Data.Vector.Sparse
19 |     Data.Vector.Sparse.ScatterGather
20 |     Data.Vector.Util
21 |   build-depends:
22 |       base >=4.6
23 |     , base-orphans >= 0.4 && < 1
24 |     , binary >=0.7
25 |     , hmatrix >=0.16 && <1
26 |     , mono-traversable >=0.6 && <2
27 |     , primitive >=0.5 && <1
28 |     , tagged >=0.7 && <1
29 |     , transformers >=0.4
30 |     , vector >=0.11 && <1
31 |     , vector-algorithms >=0.6 && <1
32 |   hs-source-dirs: src
33 |   default-language: Haskell2010
34 |   ghc-options: -Wall -msse2
35 |   ghc-prof-options: -fprof-auto
36 | 
37 | test-suite sparse
38 |   type: exitcode-stdio-1.0
39 |   hs-source-dirs: tests
40 |   main-is: Sparse.hs
41 |   other-modules:
42 |     Test.LinearAlgebra
43 |   default-language: Haskell2010
44 |   ghc-options: -Wall -msse2
45 |   ghc-prof-options: -fprof-auto
46 |   build-depends:
47 |       base
48 |     , hspec >=2.1 && <3
49 |     , QuickCheck >=2.7 && <3
50 |     , mono-traversable >=0.6 && <2
51 |     , sparse-linear
52 |     , vector >=0.10 && <1
53 | 


--------------------------------------------------------------------------------
/suitesparse/suitesparse.cabal:
--------------------------------------------------------------------------------
 1 | name:                suitesparse
 2 | version:             0.1.0.0
 3 | synopsis:
 4 |   Haskell bindings to the SuiteSparse library of sparse linear algebra routines
 5 | license:             GPL-2
 6 | license-file:        LICENSE
 7 | author:              Thomas Tuegel
 8 | maintainer:          ttuegel@gmail.com
 9 | copyright:           (c) 2014 Thomas Tuegel
10 | category:            Math
11 | build-type:          Simple
12 | cabal-version:       >=1.10
13 | 
14 | library
15 |   exposed-modules:
16 |     Numeric.LinearAlgebra.Umfpack
17 |     Numeric.LinearAlgebra.Umfpack.Internal
18 |   build-depends:
19 |       base >= 4.7 && < 5
20 |     , hmatrix >= 0.16 && < 1
21 |     , mono-traversable >= 0.6 && < 2
22 |     , primitive >= 0.5 && < 1
23 |     , sparse-linear >= 0.1 && < 1
24 |     , vector >= 0.10 && < 1
25 |     , vector-algorithms >= 0.6 && < 1
26 |   hs-source-dirs: src
27 |   default-language: Haskell2010
28 |   ghc-options: -Wall
29 |   ghc-prof-options: -fprof-auto
30 |   extra-libraries:
31 |     openblas
32 |     suitesparse
33 | 
34 | test-suite test-umfpack
35 |   type: exitcode-stdio-1.0
36 |   hs-source-dirs: tests
37 |   main-is: test-umfpack.hs
38 |   other-modules:
39 |     Test.LinearAlgebra
40 |   default-language: Haskell2010
41 |   ghc-options: -Wall
42 |   ghc-prof-options: -fprof-auto
43 |   build-depends:
44 |       base
45 |     , hspec >=2.1 && <3
46 |     , QuickCheck >=2.7 && <3
47 |     , sparse-linear
48 |     , suitesparse
49 |     , vector >=0.10 && <1
50 | 


--------------------------------------------------------------------------------
/sparse-linear/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2014, Thomas Tuegel
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Thomas Tuegel nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/feast/src/Numeric/LinearAlgebra/Feast/Internal.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ConstraintKinds #-}
 2 | {-# LANGUAGE FlexibleContexts #-}
 3 | {-# LANGUAGE FlexibleInstances #-}
 4 | {-# LANGUAGE ForeignFunctionInterface #-}
 5 | {-# LANGUAGE TypeFamilies #-}
 6 | 
 7 | module Numeric.LinearAlgebra.Feast.Internal
 8 |        ( FeastRci
 9 |        , Feast(..)
10 |        , feastinit
11 |        ) where
12 | 
13 | import Data.Vector.Storable.Mutable (IOVector)
14 | import qualified Data.Vector.Storable.Mutable as MV
15 | import Foreign.C.Types
16 | import Foreign.Ptr
17 | import Foreign.Storable
18 | import Prelude hiding (concat, mapM)
19 | 
20 | import Data.Complex.Enhanced
21 | import qualified Numeric.LinearAlgebra as Dense
22 | import Numeric.LinearAlgebra.Umfpack
23 | 
24 | type FeastRci a
25 |   =  Ptr CInt  -- ^ ijob
26 |   -> Ptr CInt  -- ^ N
27 |   -> Ptr a  -- ^ Ze
28 |   -> Ptr a  -- ^ work
29 |   -> Ptr (ComplexOf a)  -- ^ workc
30 |   -> Ptr a  -- ^ Aq
31 |   -> Ptr a  -- ^ Sq
32 |   -> Ptr CInt  -- ^ feastparam
33 |   -> Ptr (RealOf a)  -- ^ epsout
34 |   -> Ptr CInt  -- ^ loop
35 |   -> Ptr (RealOf a)  -- ^ Emin
36 |   -> Ptr (RealOf a)  -- ^ Emax
37 |   -> Ptr CInt  -- ^ M0
38 |   -> Ptr (RealOf a)  -- ^ lambda
39 |   -> Ptr a  -- ^ q
40 |   -> Ptr CInt  -- ^ mode
41 |   -> Ptr (RealOf a)  -- ^ res
42 |   -> Ptr CInt  -- ^ info
43 |   -> IO ()
44 | 
45 | type FeastConstraint a =
46 |   ( Dense.Element a
47 |   , Eq a
48 |   , IsReal a
49 |   , Num a
50 |   , Num (ComplexOf a)
51 |   , Num (RealOf a)
52 |   , Storable a
53 |   , Storable (ComplexOf a)
54 |   , Storable (RealOf a)
55 |   , Umfpack a
56 |   )
57 | 
58 | class FeastConstraint a => Feast a where
59 |   feast_rci :: FeastRci a
60 | 
61 | foreign import ccall "zfeast_hrci_" zfeast_hrci :: FeastRci (Complex Double)
62 | 
63 | instance Feast (Complex Double) where
64 |   {-# INLINE feast_rci #-}
65 |   feast_rci = zfeast_hrci
66 | 
67 | foreign import ccall "dfeast_srci_" dfeast_srci :: FeastRci Double
68 | 
69 | instance Feast Double where
70 |   {-# INLINE feast_rci #-}
71 |   feast_rci = dfeast_srci
72 | 
73 | foreign import ccall "feastinit_" feastinit_ :: Ptr CInt -> IO ()
74 | 
75 | feastinit :: IO (IOVector CInt)
76 | feastinit = do
77 |   fpm <- MV.replicate 64 0
78 |   MV.unsafeWith fpm feastinit_
79 |   return fpm
80 | 


--------------------------------------------------------------------------------
/sparse-linear/tests/Test/LinearAlgebra.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DataKinds #-}
 2 | {-# LANGUAGE FlexibleInstances #-}
 3 | {-# LANGUAGE RecordWildCards #-}
 4 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 5 | 
 6 | module Test.LinearAlgebra where
 7 | 
 8 | import qualified Data.Vector.Generic as V
 9 | import Data.Vector.Unboxed (Vector)
10 | import Test.Hspec
11 | import Test.QuickCheck hiding ((><))
12 | 
13 | import Data.Matrix.Sparse
14 | import qualified Data.Vector.Sparse as S
15 | import Data.Vector.Util (increasing, nondecreasing)
16 | 
17 | instance (Arbitrary a, Unbox a) => Arbitrary (Vector a) where
18 |     arbitrary = fmap V.fromList $ suchThat arbitrary $ \v -> length v > 0
19 | 
20 | instance (Arbitrary a, Num a, Unbox a) => Arbitrary (Matrix Vector a) where
21 |     arbitrary = do
22 |       m <- arbdim
23 |       n <- arbdim
24 |       arbitraryMatrix m n
25 | 
26 | arbdim :: Gen Int
27 | arbdim = arbitrary `suchThat` (> 0)
28 | 
29 | arbitraryMatrix
30 |   :: (Arbitrary a, Num a, Unbox a)
31 |   => Int -> Int -> Gen (Matrix Vector a)
32 | arbitraryMatrix nr nc = do
33 |   triples <- vectorOf (nr * nc `div` 4 + 1) $ do
34 |     r <- choose (0, nr - 1)
35 |     c <- choose (0, nc - 1)
36 |     x <- arbitrary
37 |     return (r, c, x)
38 |   return $ (nr >< nc) triples
39 | 
40 | checkMatrix :: Gen (Matrix Vector Int) -> SpecWith ()
41 | checkMatrix arbmat =
42 |   it "format properties" $ property $ do
43 |     mat@Matrix {..} <- arbmat
44 |     let dieUnless str = counterexample ("failed: " ++ str ++ " " ++ show mat)
45 |         slices = map (slice mat) [0..(ncols - 1)]
46 |     return $ conjoin
47 |       [ dieUnless "nondecreasing pointers"
48 |         (nondecreasing pointers)
49 | 
50 |       , dieUnless "length pointers == ncols + 1"
51 |         (V.length pointers == ncols + 1)
52 | 
53 |       , dieUnless "length values == last pointers"
54 |         (V.length values == V.last pointers)
55 | 
56 |       , dieUnless "length indices == last pointers"
57 |         (V.length indices == V.last pointers)
58 | 
59 |       , dieUnless "increasing indices in slice"
60 |         (all (increasing . (\(S.Vector _ idx _) -> idx)) slices)
61 | 
62 |       , dieUnless "all indices >= 0"
63 |         (V.all (>= 0) indices)
64 | 
65 |       , dieUnless "all indices < nrows"
66 |         (V.all (< nrows) indices)
67 |       ]
68 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Vector/Util.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE BangPatterns #-}
 2 | {-# LANGUAGE FlexibleContexts #-}
 3 | {-# LANGUAGE TypeFamilies #-}
 4 | 
 5 | module Data.Vector.Util
 6 |        ( zipWithM3_
 7 |        , shiftR
 8 |        , preincrement
 9 |        , forSlicesM2_
10 |        , increasing, nondecreasing
11 |        ) where
12 | 
13 | import Control.Monad (liftM)
14 | import Control.Monad.Primitive (PrimMonad, PrimState)
15 | import Data.Vector.Generic (Vector)
16 | import qualified Data.Vector.Generic as G
17 | import Data.Vector.Generic.Mutable (MVector)
18 | import qualified Data.Vector.Generic.Mutable as GM
19 | import qualified Data.Vector.Unboxed as U
20 | 
21 | zipWithM3_
22 |   :: (Monad m, Vector u a, Vector v b, Vector w c)
23 |   => (a -> b -> c -> m d) -> u a -> v b -> w c -> m ()
24 | {-# INLINE zipWithM3_ #-}
25 | zipWithM3_ f as bs cs = do
26 |   let len = minimum [G.length as, G.length bs, G.length cs]
27 |   U.forM_ (U.enumFromN 0 len) $ \ix -> do
28 |     a <- G.unsafeIndexM as ix
29 |     b <- G.unsafeIndexM bs ix
30 |     c <- G.unsafeIndexM cs ix
31 |     f a b c
32 | 
33 | -- | Shift the right part (relative to the given index) of a mutable vector by
34 | -- the given offset. Positive (negative) offsets shift to the right (left).
35 | shiftR
36 |   :: (PrimMonad m, MVector v a)
37 |   => v (PrimState m) a
38 |   -> Int  -- ^ index
39 |   -> Int  -- ^ offset
40 |   -> m ()
41 | {-# INLINE shiftR #-}
42 | shiftR = \v ix off -> do
43 |   let len' = GM.length v - ix - abs off
44 |       src
45 |         | off >= 0 = GM.unsafeSlice ix len' v
46 |         | otherwise = GM.unsafeSlice (ix + abs off) len' v
47 |       dst
48 |         | off >= 0 = GM.unsafeSlice (ix + abs off) len' v
49 |         | otherwise = GM.unsafeSlice ix len' v
50 |   GM.move dst src
51 | 
52 | preincrement
53 |   :: (Num a, PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a
54 | {-# INLINE preincrement #-}
55 | preincrement = \v ix -> do
56 |   count <- GM.unsafeRead v ix
57 |   GM.unsafeWrite v ix $! count + 1
58 |   return count
59 | 
60 | forSlicesM2_
61 |   :: (Integral i, Monad m, Vector u i, Vector v a, Vector w b)
62 |   => u i -> v a -> w b -> (Int -> v a -> w b -> m c) -> m ()
63 | {-# INLINE forSlicesM2_ #-}
64 | forSlicesM2_ = \ptrs as bs f -> do
65 |   U.forM_ (U.enumFromN 0 $ G.length ptrs - 1) $ \c -> do
66 |     start <- liftM fromIntegral $ G.unsafeIndexM ptrs c
67 |     end <- liftM fromIntegral $ G.unsafeIndexM ptrs (c + 1)
68 |     let as' = G.unsafeSlice start (end - start) as
69 |         bs' = G.unsafeSlice start (end - start) bs
70 |     f c as' bs'
71 | 
72 | nondecreasing :: (Ord a, Vector v Bool, Vector v a) => v a -> Bool
73 | nondecreasing vec
74 |   | G.null vec = True
75 |   | otherwise = G.and $ G.zipWith (<=) (G.init vec) (G.tail vec)
76 | 
77 | increasing :: (Ord a, Vector v Bool, Vector v a) => v a -> Bool
78 | increasing vec
79 |   | G.null vec = True
80 |   | otherwise = G.and $ G.zipWith (<) (G.init vec) (G.tail vec)
81 | 


--------------------------------------------------------------------------------
/suitesparse/tests/Test/LinearAlgebra.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleInstances #-}
 2 | {-# LANGUAGE RecordWildCards #-}
 3 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 4 | 
 5 | module Test.LinearAlgebra where
 6 | 
 7 | import Data.Traversable
 8 | import qualified Data.Vector.Generic as V
 9 | import Data.Vector.Unboxed (Vector, Unbox)
10 | import Test.Hspec
11 | import Test.QuickCheck
12 | 
13 | import Data.Matrix.Sparse
14 | import qualified Data.Vector.Sparse as S
15 | import Data.Vector.Util (increasing, nondecreasing)
16 | 
17 | instance (Arbitrary a, Unbox a) => Arbitrary (Vector a) where
18 |     arbitrary = fmap V.fromList $ suchThat arbitrary $ \v -> length v > 0
19 | 
20 | instance (Arbitrary a, Num a, Unbox a) => Arbitrary (Matrix Vector a) where
21 |     arbitrary = do
22 |       nr <- arbitrary `suchThat` (> 0)
23 |       let nc = nr
24 |       triples <- forM [0..(nr * nr `div` 4)] $ \_ -> do
25 |         r <- arbitrary `suchThat` (\r -> r >= 0 && r < nr)
26 |         c <- arbitrary `suchThat` (\c -> c >= 0 && c < nc)
27 |         x <- arbitrary
28 |         return (r, c, x)
29 |       return $ fromTriples nr nc triples
30 | 
31 | prop_pointersNondecreasing :: Matrix Vector a -> Bool
32 | prop_pointersNondecreasing Matrix{..} = nondecreasing pointers
33 | 
34 | prop_pointersLength :: Matrix Vector a -> Bool
35 | prop_pointersLength Matrix{..} = V.length pointers == ncols + 1
36 | 
37 | prop_valuesLength :: Unbox a => Matrix Vector a -> Bool
38 | prop_valuesLength Matrix{..} =
39 |   V.length values == fromIntegral (V.last pointers)
40 | 
41 | prop_indicesIncreasing :: Unbox a => Matrix Vector a -> Bool
42 | prop_indicesIncreasing mat =
43 |   all (increasing . S.indices) $ map (slice mat) [0..(ncols mat - 1)]
44 | 
45 | prop_indicesNonNegative :: Unbox a => Matrix Vector a -> Bool
46 | prop_indicesNonNegative = V.all (>= 0) . indices
47 | 
48 | prop_indicesInRange :: Unbox a => Matrix Vector a -> Bool
49 | prop_indicesInRange Matrix{..} = V.all (< nrows) indices
50 | 
51 | checkFunMat1
52 |   :: (Arbitrary a, Num a, Show a, Unbox a)
53 |   => (Matrix Vector a -> Matrix Vector a) -> SpecWith ()
54 | checkFunMat1 f = do
55 |   it "nondecreasing pointers" $ property $ prop_pointersNondecreasing . f
56 |   it "pointers length" $ property $ prop_pointersLength . f
57 |   it "values length" $ property $ prop_valuesLength . f
58 |   it "increasing indices per slice" $ property $ prop_indicesIncreasing . f
59 |   it "non-negative indices" $ property $ prop_indicesNonNegative . f
60 |   it "indices < dim" $ property $ prop_indicesInRange . f
61 | 
62 | checkFunMat2
63 |   :: (Arbitrary a, Num a, Show a, Unbox a)
64 |   => (Matrix Vector a -> Matrix Vector a -> Matrix Vector a) -> SpecWith ()
65 | checkFunMat2 f = do
66 |   it "nondecreasing pointers" $ property $ \a b ->
67 |     prop_pointersNondecreasing (f a b)
68 | 
69 |   it "pointers length" $ property $ \a b ->
70 |     prop_pointersLength (f a b)
71 | 
72 |   it "values length" $ property $ \a b ->
73 |     prop_valuesLength (f a b)
74 | 
75 |   it "increasing indices per slice" $ property $ \a b ->
76 |     prop_indicesIncreasing (f a b)
77 | 
78 |   it "non-negative indices" $ property $ \a b ->
79 |     prop_indicesNonNegative (f a b)
80 | 
81 |   it "indices < dim" $ property $ \a b ->
82 |     prop_indicesInRange (f a b)
83 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Matrix/Sparse/Foreign.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE RecordWildCards #-}
 2 | {-# LANGUAGE ViewPatterns #-}
 3 | 
 4 | module Data.Matrix.Sparse.Foreign
 5 |        ( Storable
 6 |        , withConstMatrix
 7 |        , fromForeign
 8 |        ) where
 9 | 
10 | import Data.Vector.Generic (Vector)
11 | import qualified Data.Vector.Generic as VG
12 | import qualified Data.Vector.Unboxed as VU
13 | import qualified Data.Vector.Unboxed.Mutable as UM
14 | import Data.Vector.Storable (Storable)
15 | import qualified Data.Vector.Storable as VS
16 | import Foreign.C.Types (CInt)
17 | import Foreign.ForeignPtr (newForeignPtr)
18 | import Foreign.Marshal.Alloc (finalizerFree)
19 | import Foreign.Marshal.Array (copyArray, mallocArray)
20 | import Foreign.Ptr (Ptr)
21 | 
22 | import Data.Matrix.Sparse
23 | 
24 | withConstMatrix
25 |   :: (Storable a, Unbox a, Vector v a)
26 |   => Matrix v a
27 |   -> (CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr a -> IO b)
28 |   -> IO b
29 | {-# SPECIALIZE withConstMatrix :: Matrix VU.Vector Double -> (CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr Double -> IO b) -> IO b #-}
30 | {-# SPECIALIZE withConstMatrix :: Matrix VU.Vector (Complex Double) -> (CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr (Complex Double) -> IO b) -> IO b #-}
31 | {-# SPECIALIZE withConstMatrix :: Matrix VS.Vector Double -> (CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr Double -> IO b) -> IO b #-}
32 | {-# SPECIALIZE withConstMatrix :: Matrix VS.Vector (Complex Double) -> (CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr (Complex Double) -> IO b) -> IO b #-}
33 | withConstMatrix Matrix {..} action =
34 |   VS.unsafeWith _ptrs $ \_ptrs ->
35 |   VS.unsafeWith _rows $ \_rows ->
36 |   VS.unsafeWith _vals $ \_vals ->
37 |     action (fromIntegral nrows) (fromIntegral ncols) _ptrs _rows _vals
38 |   where
39 |     _ptrs = VS.map fromIntegral $ VS.convert pointers
40 |     _rows = VS.map fromIntegral $ VS.convert indices
41 |     _vals = VS.convert values
42 | 
43 | fromForeign
44 |   :: (Num a, Storable a, Unbox a, Vector v a)
45 |   => Bool -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr a -> IO (Matrix v a)
46 | fromForeign copy (fromIntegral -> nrows) (fromIntegral -> ncols) ptrs rows vals
47 |   = do
48 |     let maybeCopyArray src len
49 |           | copy = do
50 |               dst <- mallocArray len
51 |               copyArray dst src len
52 |               return dst
53 |           | otherwise = return src
54 |         toForeignPtr src len
55 |           = maybeCopyArray src len >>= newForeignPtr finalizerFree
56 | 
57 |     let nptrs = ncols + 1
58 |     _ptrs <- toForeignPtr ptrs nptrs
59 |     let pointers
60 |           = (VU.convert . VS.map fromIntegral)
61 |             (VS.unsafeFromForeignPtr0 _ptrs nptrs)
62 | 
63 |     let nz = VU.last pointers
64 |     _rows <- toForeignPtr rows nz
65 |     _rows <- (VU.unsafeThaw . VU.convert . VS.map fromIntegral)
66 |              (VS.unsafeFromForeignPtr0 _rows nz)
67 | 
68 |     _vals <- toForeignPtr vals nz
69 |     _vals <- (VU.unsafeThaw . VU.convert)
70 |              (VS.unsafeFromForeignPtr0 _vals nz)
71 | 
72 |     let _entries = UM.zip _rows _vals
73 | 
74 |     VU.forM_ (VU.enumFromN 0 ncols) $ \m -> do
75 |       start <- VU.unsafeIndexM pointers m
76 |       end <- VU.unsafeIndexM pointers (m + 1)
77 |       let len = end - start
78 |       dedupInPlace nrows (UM.unsafeSlice start len _entries)
79 | 
80 |     entries <- VU.unsafeFreeze _entries
81 |     let (indices, VG.convert -> values) = VU.unzip entries
82 |     return Matrix {..}
83 | 
84 | {-# NOINLINE fromForeign #-} -- uses unsafeFreeze and unsafeThaw
85 | {-# SPECIALIZE fromForeign :: Bool -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr Double -> IO (Matrix VU.Vector Double) #-}
86 | {-# SPECIALIZE fromForeign :: Bool -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr (Complex Double) -> IO (Matrix VU.Vector (Complex Double)) #-}
87 | {-# SPECIALIZE fromForeign :: Bool -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr Double -> IO (Matrix VS.Vector Double) #-}
88 | {-# SPECIALIZE fromForeign :: Bool -> CInt -> CInt -> Ptr CInt -> Ptr CInt -> Ptr (Complex Double) -> IO (Matrix VS.Vector (Complex Double)) #-}
89 | 


--------------------------------------------------------------------------------
/suitesparse/src/Numeric/LinearAlgebra/Umfpack.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DataKinds #-}
  2 | {-# LANGUAGE RecordWildCards #-}
  3 | {-# LANGUAGE ScopedTypeVariables #-}
  4 | 
  5 | module Numeric.LinearAlgebra.Umfpack
  6 |     ( -- * Simple interface
  7 |       Umfpack()
  8 |     , linearSolve, (<\>)
  9 |       -- * Advanced interface
 10 |     , Analysis, analyze
 11 |     , Factors, factor
 12 |     , UmfpackMode(..), linearSolve_
 13 |     ) where
 14 | 
 15 | import Control.Applicative
 16 | import Control.Monad (when)
 17 | import Data.Traversable
 18 | import Data.Vector.Generic (Vector)
 19 | import qualified Data.Vector.Storable as V
 20 | import Data.Vector.Storable.Mutable (IOVector)
 21 | import qualified Data.Vector.Storable.Mutable as MV
 22 | import Foreign.Marshal.Alloc
 23 | import Foreign.Ptr
 24 | import Foreign.Storable
 25 | import GHC.Stack (errorWithStackTrace)
 26 | import Prelude hiding (mapM)
 27 | import System.IO.Unsafe (unsafePerformIO)
 28 | 
 29 | import Data.Matrix.Sparse
 30 | import Data.Matrix.Sparse.Foreign
 31 | import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr)
 32 | import Numeric.LinearAlgebra.Umfpack.Internal
 33 | 
 34 | -- ------------------------------------------------------------------------
 35 | -- Simple interface
 36 | -- ------------------------------------------------------------------------
 37 | 
 38 | linearSolve :: (Vector v a, Umfpack a) => Matrix v a -> [v a] -> [v a]
 39 | {-# INLINE linearSolve #-}
 40 | linearSolve mat@Matrix{..} bs =
 41 |   unsafePerformIO $ do
 42 |     let fact = factor mat (analyze mat)
 43 |     xs <- forM bs $ \_b -> do
 44 |       _b <- V.thaw (V.convert _b)
 45 |       linearSolve_ fact UmfpackNormal mat _b
 46 |     map V.convert <$> mapM V.freeze xs
 47 | 
 48 | (<\>) :: (Vector v a, Umfpack a) => Matrix v a -> v a -> v a
 49 | {-# INLINE (<\>) #-}
 50 | (<\>) mat b = head $ linearSolve mat [b]
 51 | 
 52 | -- ------------------------------------------------------------------------
 53 | -- Advanced interface
 54 | -- ------------------------------------------------------------------------
 55 | 
 56 | newtype Analysis a = Analysis { fsym :: ForeignPtr (Symbolic a) }
 57 | 
 58 | newtype Factors a = Factors { fnum :: ForeignPtr (Numeric a) }
 59 | 
 60 | analyze :: (Vector v a, Umfpack a) => Matrix v a -> Analysis a
 61 | {-# INLINE analyze #-}
 62 | analyze mat = unsafePerformIO $ withConstMatrix mat $ \m n p i x -> do
 63 |   sym <- malloc
 64 |   _stat <- umfpack_symbolic m n p i x sym nullPtr nullPtr
 65 |   fsym <- newForeignPtr umfpack_free_symbolic sym
 66 |   umfpack_report_status mat nullPtr _stat
 67 |   when (_stat < 0) $ errorWithStackTrace "analyze: umfpack_symbolic failed"
 68 | 
 69 |   return Analysis{..}
 70 | 
 71 | factor :: (Vector v a, Umfpack a) => Matrix v a -> Analysis a -> Factors a
 72 | {-# INLINE factor #-}
 73 | factor mat Analysis{..} =
 74 |   unsafePerformIO $ withConstMatrix mat $ \_ _ p i x -> do
 75 |     num <- malloc
 76 |     _stat <- withForeignPtr fsym $ \_sym -> do
 77 |       _sym <- peek _sym
 78 |       umfpack_numeric p i x _sym num nullPtr nullPtr
 79 |     fnum <- newForeignPtr umfpack_free_numeric num
 80 |     umfpack_report_status mat nullPtr _stat
 81 |     when (_stat < 0) $ errorWithStackTrace "factor: umfpack_numeric failed"
 82 | 
 83 |     return Factors{..}
 84 | 
 85 | data UmfpackMode = UmfpackNormal | UmfpackTrans
 86 | 
 87 | linearSolve_
 88 |   :: (Vector v a, Umfpack a)
 89 |   => Factors a -> UmfpackMode -> Matrix v a -> IOVector a -> IO (IOVector a)
 90 | {-# INLINE linearSolve_ #-}
 91 | linearSolve_ fact mode mat@Matrix{..} _b =
 92 |   withConstMatrix mat $ \_ _ p i x -> do
 93 |     _soln <- MV.replicate ncols 0
 94 |     _ <- MV.unsafeWith _b $ \_b -> MV.unsafeWith _soln $ \_soln -> do
 95 |       let m = case mode of
 96 |                 UmfpackNormal -> 0
 97 |                 UmfpackTrans -> 1
 98 |       _stat <- withNum fact $ \num ->
 99 |         umfpack_solve m p i x _soln _b num nullPtr nullPtr
100 |       umfpack_report_status mat nullPtr _stat
101 |       when (_stat < 0) $ errorWithStackTrace "linearSolve_: umfpack_solve failed"
102 |     return _soln
103 | 
104 | -- ------------------------------------------------------------------------
105 | -- Utilities
106 | -- ------------------------------------------------------------------------
107 | 
108 | withNum :: Factors a -> (Numeric a -> IO b) -> IO b
109 | {-# INLINE withNum #-}
110 | withNum Factors{..} f = withForeignPtr fnum $ \p -> peek p >>= f
111 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Vector/Sparse/ScatterGather.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns #-}
  2 | {-# LANGUAGE CPP #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  5 | {-# LANGUAGE RankNTypes #-}
  6 | 
  7 | module Data.Vector.Sparse.ScatterGather
  8 |        ( SG, run, reset
  9 |        , scatter, unsafeScatter, unsafeScatterIndices, unsafeScatterValues
 10 |        , gather
 11 |        ) where
 12 | 
 13 | #if __GLASGOW_HASKELL__ < 710
 14 | import Control.Applicative
 15 | #endif
 16 | import Control.Monad.ST ( ST, runST )
 17 | import Control.Monad.Trans.Class ( lift )
 18 | import Control.Monad.Trans.Reader ( ReaderT(..), ask )
 19 | import Data.Vector.Generic ( Mutable, Vector )
 20 | import qualified Data.Vector.Generic as G
 21 | import qualified Data.Vector.Generic.Mutable as GM
 22 | import qualified Data.Vector.Unboxed as U
 23 | import qualified Data.Vector.Unboxed.Mutable as UM
 24 | 
 25 | import {-# SOURCE #-} qualified Data.Vector.Sparse as S
 26 | 
 27 | -- * The 'SG' Monad
 28 | 
 29 | data StateSG v s a = StateSG !(U.MVector s Bool) !(Mutable v s a)
 30 | 
 31 | newtype SG v s a b = SG (ReaderT (StateSG v s a) (ST s) b)
 32 |   deriving (Applicative, Functor, Monad)
 33 | 
 34 | -- | Run a computation in 'SG', the scatter-gather monad. The state is not
 35 | -- automatically initialized, so 'reset' must be called before any
 36 | -- scatter-gather operations.
 37 | run :: Vector v a => Int -> (forall s. SG v s a b) -> b
 38 | {-# INLINE run #-}
 39 | run len sg = runST $ do
 40 |   pattern <- UM.new len
 41 |   values <- GM.new len
 42 |   let SG rdr = sg
 43 |   runReaderT rdr (StateSG pattern values)
 44 | 
 45 | -- | Initialize or re-initialize the 'SG' monad state. Use this before any
 46 | -- 'scatter' operations or after a 'gather'.
 47 | reset :: Vector v a => a -> SG v s a ()
 48 | {-# INLINE reset #-}
 49 | reset a0 = SG $ do
 50 |   StateSG pattern values <- ask
 51 |   lift $ do
 52 |     UM.set pattern False
 53 |     GM.set values a0
 54 | 
 55 | -- * Scatter operations
 56 | 
 57 | scatter
 58 |   :: (Vector u a, Vector v b)
 59 |   => S.Vector v b -> (a -> b -> a) -> SG u s a ()
 60 | {-# INLINE scatter #-}
 61 | scatter v@(S.Vector len _ _) add = do
 62 |   StateSG pattern _ <- SG ask
 63 |   if len == UM.length pattern
 64 |     then unsafeScatter v add
 65 |     else oops "vector length does not match workspace length"
 66 |   where
 67 |     oops msg = error ("scatter: " ++ msg)
 68 | 
 69 | unsafeScatter
 70 |   :: (Vector u a, Vector v b)
 71 |   => S.Vector v b -> (a -> b -> a) -> SG u s a ()
 72 | {-# INLINE unsafeScatter #-}
 73 | unsafeScatter (S.Vector _ indices values) add = do
 74 |   unsafeScatterIndices indices
 75 |   unsafeScatterValues indices values add
 76 | 
 77 | unsafeScatterIndices :: Vector u Int => u Int -> SG v s a ()
 78 | {-# INLINE unsafeScatterIndices #-}
 79 | unsafeScatterIndices indices = SG $ do
 80 |   StateSG pattern _ <- ask
 81 |   lift $ G.mapM_ (\i -> UM.unsafeWrite pattern i True) indices
 82 | 
 83 | unsafeScatterValues
 84 |   :: (Vector u a, Vector v b, Vector w Int)
 85 |   => w Int -> v b -> (a -> b -> a) -> SG u s a ()
 86 | {-# INLINE unsafeScatterValues #-}
 87 | unsafeScatterValues indices values add = SG $ do
 88 |   StateSG _ scattered <- ask
 89 |   let scatterValue !iV !iS = do
 90 |         !x <- G.unsafeIndexM values iV
 91 |         !y <- GM.unsafeRead scattered iS
 92 |         GM.unsafeWrite scattered iS (add y x)
 93 |   lift $ G.imapM_ scatterValue indices
 94 | 
 95 | -- * Gather operations
 96 | 
 97 | gather :: Vector v a => SG v s a (S.Vector v a)
 98 | {-# INLINE gather #-}
 99 | gather = do
100 |   pop <- count
101 |   indices <- gatherIndices pop
102 |   values <- gatherValues pop
103 |   StateSG pattern _ <- SG ask
104 |   let len = UM.length pattern
105 |   return (S.Vector len indices values)
106 | 
107 | count :: SG v s a Int
108 | {-# INLINE count #-}
109 | count = SG $ do
110 |   StateSG pattern _ <- ask
111 |   let countTrue !n !i = do
112 |         occupied <- UM.unsafeRead pattern i
113 |         return (if occupied then n + 1 else n)
114 |   lift $ U.foldM' countTrue 0 (U.enumFromN 0 (UM.length pattern))
115 | 
116 | gatherIndices :: Int -> SG v s a (U.Vector Int)
117 | {-# INLINE gatherIndices #-}
118 | gatherIndices pop = SG $ do
119 |   StateSG pattern _ <- ask
120 |   lift $ do
121 |     indices <- UM.new pop
122 |     let gatherIndex !iIdx !iPat = do
123 |           occupied <- UM.unsafeRead pattern iPat
124 |           if not occupied
125 |             then return iIdx
126 |             else do
127 |               UM.unsafeWrite indices iIdx iPat
128 |               return (iIdx + 1)
129 |     _ <- U.foldM' gatherIndex 0 (U.enumFromN 0 (UM.length pattern))
130 |     U.freeze indices
131 | 
132 | gatherValues :: Vector v a => Int -> SG v s a (v a)
133 | {-# INLINE gatherValues #-}
134 | gatherValues pop = SG $ do
135 |   StateSG pattern scattered <- ask
136 |   lift $ do
137 |     values <- GM.new pop
138 |     let gatherValue !iVal !iPat = do
139 |           occupied <- UM.unsafeRead pattern iPat
140 |           if not occupied
141 |             then return iVal
142 |             else do
143 |               !x <- GM.unsafeRead scattered iPat
144 |               GM.unsafeWrite values iVal x
145 |               return (iVal + 1)
146 |     _ <- U.foldM' gatherValue 0 (U.enumFromN 0 (UM.length pattern))
147 |     G.freeze values
148 | 


--------------------------------------------------------------------------------
/suitesparse/src/Numeric/LinearAlgebra/Umfpack/Internal.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances #-}
  2 | {-# LANGUAGE ForeignFunctionInterface #-}
  3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  4 | {-# LANGUAGE LambdaCase #-}
  5 | 
  6 | module Numeric.LinearAlgebra.Umfpack.Internal
  7 |     ( Control, Info, Numeric, Symbolic
  8 |     , Umfpack(..)
  9 |     ) where
 10 | 
 11 | import Data.Vector.Generic (Vector)
 12 | import Data.Vector.Unboxed (Unbox)
 13 | import Foreign.C.Types (CInt(..))
 14 | import Foreign.ForeignPtr (FinalizerPtr)
 15 | import Foreign.Ptr (Ptr, castPtr, nullPtr)
 16 | import Foreign.Storable
 17 | 
 18 | import Data.Complex.Enhanced
 19 | import Data.Matrix.Sparse (Matrix)
 20 | 
 21 | type Control = Ptr Double
 22 | type Info = Ptr Double
 23 | newtype Numeric a = Numeric (Ptr ()) deriving (Storable)
 24 | newtype Symbolic a = Symbolic (Ptr ()) deriving (Storable)
 25 | 
 26 | type UmfpackSymbolic a
 27 |   =  CInt
 28 |   -> CInt
 29 |   -> Ptr CInt
 30 |   -> Ptr CInt
 31 |   -> Ptr a
 32 |   -> Ptr (Symbolic a)
 33 |   -> Control
 34 |   -> Info
 35 |   -> IO CInt  -- ^ status code
 36 | 
 37 | type UmfpackNumeric a
 38 |   =  Ptr CInt
 39 |   -> Ptr CInt
 40 |   -> Ptr a
 41 |   -> Symbolic a
 42 |   -> Ptr (Numeric a)
 43 |   -> Control
 44 |   -> Info
 45 |   -> IO CInt  -- ^ status code
 46 | 
 47 | type UmfpackSolve a
 48 |   =  CInt
 49 |   -> Ptr CInt
 50 |   -> Ptr CInt
 51 |   -> Ptr a
 52 |   -> Ptr a -- ^ solution vector
 53 |   -> Ptr a -- ^ rhs vector
 54 |   -> Numeric a
 55 |   -> Control
 56 |   -> Info
 57 |   -> IO CInt  -- ^ status code
 58 | 
 59 | type UmfpackReport = Control -> CInt -> IO ()
 60 | 
 61 | class (Num a, Storable a, Unbox a) => Umfpack a where
 62 |     umfpack_symbolic :: UmfpackSymbolic a
 63 |     umfpack_numeric :: UmfpackNumeric a
 64 |     umfpack_solve :: UmfpackSolve a
 65 |     umfpack_free_symbolic :: FinalizerPtr (Symbolic a)
 66 |     umfpack_free_numeric :: FinalizerPtr (Numeric a)
 67 |     umfpack_report_status :: Vector v a => Matrix v a -> UmfpackReport
 68 | 
 69 | foreign import ccall "umfpack.h umfpack_zi_symbolic"
 70 |   umfpack_zi_symbolic
 71 |     :: CInt
 72 |     -> CInt
 73 |     -> Ptr CInt
 74 |     -> Ptr CInt
 75 |     -> Ptr Double
 76 |     -> Ptr Double
 77 |     -> Ptr (Symbolic (Complex Double))
 78 |     -> Control
 79 |     -> Info
 80 |     -> IO CInt  -- ^ status code
 81 | 
 82 | foreign import ccall "umfpack.h umfpack_zi_numeric"
 83 |   umfpack_zi_numeric
 84 |     :: Ptr CInt
 85 |     -> Ptr CInt
 86 |     -> Ptr Double
 87 |     -> Ptr Double
 88 |     -> Symbolic (Complex Double)
 89 |     -> Ptr (Numeric (Complex Double))
 90 |     -> Control
 91 |     -> Info
 92 |     -> IO CInt  -- ^ status code
 93 | 
 94 | foreign import ccall "umfpack.h umfpack_zi_solve"
 95 |   umfpack_zi_solve
 96 |     :: CInt
 97 |     -> Ptr CInt
 98 |     -> Ptr CInt
 99 |     -> Ptr Double
100 |     -> Ptr Double
101 |     -> Ptr Double -- ^ solution vector
102 |     -> Ptr Double -- ^ solution vector
103 |     -> Ptr Double -- ^ rhs vector
104 |     -> Ptr Double -- ^ rhs vector
105 |     -> Numeric (Complex Double)
106 |     -> Control
107 |     -> Info
108 |     -> IO CInt  -- ^ status code
109 | 
110 | foreign import ccall "umfpack.h &umfpack_zi_free_symbolic"
111 |   umfpack_zi_free_symbolic :: FinalizerPtr (Symbolic (Complex Double))
112 | foreign import ccall "umfpack.h &umfpack_zi_free_numeric"
113 |   umfpack_zi_free_numeric :: FinalizerPtr (Numeric (Complex Double))
114 | foreign import ccall "umfpack.h umfpack_zi_report_status"
115 |   umfpack_zi_report_status :: UmfpackReport
116 | 
117 | instance Umfpack (Complex Double) where
118 |     {-# INLINE umfpack_symbolic #-}
119 |     {-# INLINE umfpack_numeric #-}
120 |     {-# INLINE umfpack_solve #-}
121 |     {-# INLINE umfpack_free_symbolic #-}
122 |     {-# INLINE umfpack_free_numeric #-}
123 |     {-# INLINE umfpack_report_status #-}
124 |     umfpack_symbolic = \m n p i x ->
125 |       umfpack_zi_symbolic m n p i (castPtr x) nullPtr
126 |     umfpack_numeric = \p i x ->
127 |       umfpack_zi_numeric p i (castPtr x) nullPtr
128 |     umfpack_solve = \mode p i x y b ->
129 |       umfpack_zi_solve mode p i
130 |         (castPtr x) nullPtr
131 |         (castPtr y) nullPtr
132 |         (castPtr b) nullPtr
133 |     umfpack_free_symbolic = umfpack_zi_free_symbolic
134 |     umfpack_free_numeric = umfpack_zi_free_numeric
135 |     umfpack_report_status _ = umfpack_zi_report_status
136 | 
137 | foreign import ccall "umfpack.h umfpack_di_symbolic"
138 |   umfpack_di_symbolic :: UmfpackSymbolic Double
139 | foreign import ccall "umfpack.h umfpack_di_numeric"
140 |   umfpack_di_numeric :: UmfpackNumeric Double
141 | foreign import ccall "umfpack.h umfpack_di_solve"
142 |   umfpack_di_solve :: UmfpackSolve Double
143 | foreign import ccall "umfpack.h &umfpack_di_free_symbolic"
144 |   umfpack_di_free_symbolic :: FinalizerPtr (Symbolic Double)
145 | foreign import ccall "umfpack.h &umfpack_di_free_numeric"
146 |   umfpack_di_free_numeric :: FinalizerPtr (Numeric Double)
147 | foreign import ccall "umfpack.h umfpack_di_report_status"
148 |   umfpack_di_report_status :: UmfpackReport
149 | 
150 | instance Umfpack Double where
151 |     {-# INLINE umfpack_symbolic #-}
152 |     {-# INLINE umfpack_numeric #-}
153 |     {-# INLINE umfpack_solve #-}
154 |     {-# INLINE umfpack_free_symbolic #-}
155 |     {-# INLINE umfpack_free_numeric #-}
156 |     {-# INLINE umfpack_report_status #-}
157 |     umfpack_symbolic = umfpack_di_symbolic
158 |     umfpack_numeric = umfpack_di_numeric
159 |     umfpack_solve = umfpack_di_solve
160 |     umfpack_free_symbolic = umfpack_di_free_symbolic
161 |     umfpack_free_numeric = umfpack_di_free_numeric
162 |     umfpack_report_status _ = umfpack_di_report_status
163 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Vector/Sparse.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns #-}
  2 | {-# LANGUAGE CPP #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE RecordWildCards #-}
  5 | {-# LANGUAGE TypeFamilies #-}
  6 | {-# LANGUAGE ViewPatterns #-}
  7 | {-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}
  8 | 
  9 | module Data.Vector.Sparse
 10 |        ( Vector(..), null, nonZero, cmap
 11 |        , fromPairs, (|>), unsafeFromPairs
 12 |        , lin, glin
 13 |        , iforM_
 14 |        ) where
 15 | 
 16 | #if __GLASGOW_HASKELL__ < 710
 17 | import Control.Applicative
 18 | #endif
 19 | import Data.List ( mapAccumL )
 20 | import Data.Maybe ( fromJust, isJust )
 21 | import Data.Monoid
 22 | import Data.MonoTraversable
 23 | import qualified Data.Vector.Generic as G
 24 | import qualified Data.Vector.Unboxed as U
 25 | import Prelude hiding ( length, null )
 26 | 
 27 | import qualified Data.Vector.Sparse.ScatterGather as SG
 28 | 
 29 | data Vector v a
 30 |   = Vector { length :: !Int
 31 |            , indices :: U.Vector Int
 32 |            , values :: v a
 33 |            }
 34 |   deriving (Eq, Show)
 35 | 
 36 | null :: Vector v a -> Bool
 37 | {-# INLINE null #-}
 38 | null v = nonZero v == 0
 39 | 
 40 | nonZero :: Vector v a -> Int
 41 | {-# INLINE nonZero #-}
 42 | nonZero (Vector _ indices _) = U.length indices
 43 | 
 44 | unsafeFromPairs :: (G.Vector u Int, G.Vector v a)
 45 |                 => Int -> u Int -> v a -> Vector v a
 46 | {-# INLINE unsafeFromPairs #-}
 47 | unsafeFromPairs len idx val = Vector len (G.convert idx) val
 48 | 
 49 | fromPairs :: (G.Vector u Int, G.Vector v a, Num a)
 50 |           => Int -> u Int -> v a -> Vector v a
 51 | {-# INLINE fromPairs #-}
 52 | fromPairs len idx val
 53 |   | nIdx /= nVal = oops (show nIdx ++ " indices and " ++ show nVal ++ "values")
 54 |   | isJust outOfBounds = oops ("index out of bounds at: "
 55 |                                ++ show (fromJust outOfBounds))
 56 |   | otherwise = SG.run len $ do
 57 |       SG.reset 0
 58 |       SG.unsafeScatterIndices idx
 59 |       SG.unsafeScatterValues idx val (+)
 60 |       SG.gather
 61 |   where
 62 |     oops msg = error ("fromPairs: " ++ msg)
 63 |     nIdx = G.length idx
 64 |     nVal = G.length val
 65 | 
 66 |     outOfBounds = G.findIndex (>= len) idx
 67 | 
 68 | (|>) :: (G.Vector v a, Num a) => Int -> [(Int, a)] -> Vector v a
 69 | {-# INLINE (|>) #-}
 70 | (|>) dim pairs = fromPairs dim indices values
 71 |   where
 72 |     (U.fromList -> indices, G.fromList -> values) = unzip pairs
 73 | 
 74 | type instance Element (Vector v a) = a
 75 | 
 76 | instance G.Vector v a => MonoFunctor (Vector v a) where
 77 |   {-# INLINE omap #-}
 78 |   omap f (Vector len indices values) = Vector len indices (G.map f values)
 79 | 
 80 | instance (G.Vector v a) => MonoFoldable (Vector v a) where
 81 |   {-# INLINE ofoldMap #-}
 82 |   {-# INLINE ofoldr #-}
 83 |   {-# INLINE ofoldl' #-}
 84 |   {-# INLINE ofoldr1Ex #-}
 85 |   {-# INLINE ofoldl1Ex' #-}
 86 |   ofoldMap f (Vector _ _ values) = G.foldr (\a -> mappend (f a)) mempty values
 87 |   ofoldr f r (Vector _ _ values) = G.foldr f r values
 88 |   ofoldl' f r (Vector _ _ values) = G.foldl' f r values
 89 |   ofoldr1Ex f (Vector _ _ values) = G.foldr1 f values
 90 |   ofoldl1Ex' f (Vector _ _ values) = G.foldl1' f values
 91 | 
 92 | cmap :: (G.Vector v a, G.Vector v b) => (a -> b) -> Vector v a -> Vector v b
 93 | {-# INLINE cmap #-}
 94 | cmap f (Vector len indices values) = Vector len indices (G.map f values)
 95 | 
 96 | glin :: (G.Vector u a, G.Vector v b, G.Vector w c)
 97 |      => c
 98 |      -> (c -> a -> c) -> Vector u a
 99 |      -> (c -> b -> c) -> Vector v b
100 |      -> Vector w c
101 | {-# INLINE glin #-}
102 | glin c0 adda as addb bs = SG.run len $ do
103 |   SG.reset c0
104 |   SG.unsafeScatter as adda
105 |   SG.unsafeScatter bs addb
106 |   SG.gather
107 |   where
108 |     lenA = length as
109 |     lenB = length bs
110 |     len | lenA == lenB = lenA
111 |         | otherwise = oops "vector lengths differ"
112 |     oops msg = error ("Data.Vector.Sparse.glin: " ++ msg)
113 | 
114 | lin :: (G.Vector u a, G.Vector v a, G.Vector w a, Num a)
115 |     => a -> Vector u a -> a -> Vector v a -> Vector w a
116 | {-# INLINE lin #-}
117 | lin a0 as b0 bs = glin 0 (\c a -> a0 * a + c) as (\c b -> b0 * b + c) bs
118 | 
119 | instance (G.Vector v a, Num a) => Num (Vector v a) where
120 |   {-# INLINE (+) #-}
121 |   {-# INLINE (*) #-}
122 |   {-# INLINE (-) #-}
123 |   {-# INLINE negate #-}
124 |   {-# INLINE abs #-}
125 |   {-# INLINE signum #-}
126 |   (+) as bs = glin 0 (+) as (+) bs
127 |   (*) as bs = glin 0 (+) as (*) bs
128 |   (-) as bs = glin 0 (+) as (-) bs
129 |   negate = omap negate
130 |   abs = omap abs
131 |   signum = omap signum
132 |   fromInteger = error "Data.Vector.Sparse.fromInteger: not implemented"
133 | 
134 | instance G.Vector v a => Monoid (Vector v a) where
135 |   {-# INLINE mempty #-}
136 |   mempty = Vector 0 U.empty G.empty
137 | 
138 |   {-# INLINE mappend #-}
139 |   mappend a b = mconcat [a, b]
140 | 
141 |   {-# INLINE mconcat #-}
142 |   mconcat xs
143 |     = Vector { length = sum (length <$> xs)
144 |              , indices = U.concat (snd (mapAccumL offsetIndices 0 xs))
145 |              , values = G.concat (values <$> xs)
146 |              }
147 |     where
148 |       offsetIndices off x = (off + length x, U.map (+ off) (indices x))
149 | 
150 | iforM_ :: (G.Vector v a, Monad m) => Vector v a -> (Int -> a -> m ()) -> m ()
151 | {-# INLINE iforM_ #-}
152 | iforM_ as f = iforM__go 0 where
153 |   nz = nonZero as
154 |   ixs = indices as
155 |   vals = values as
156 |   iforM__go !i
157 |     | i >= nz = return ()
158 |     | otherwise = do
159 |         !ix <- U.unsafeIndexM ixs i
160 |         !a <- G.unsafeIndexM vals i
161 |         f ix a
162 |         iforM__go (i + 1)
163 | 


--------------------------------------------------------------------------------
/sparse-linear/tests/Sparse.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | {-# LANGUAGE DataKinds #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | 
  5 | module Main (main) where
  6 | 
  7 | #if __GLASGOW_HASKELL__ < 710
  8 | import Control.Applicative
  9 | #endif
 10 | import Data.Vector.Unboxed (Vector)
 11 | import qualified Data.Vector.Unboxed as V
 12 | import System.IO.Unsafe (unsafePerformIO)
 13 | import Test.Hspec
 14 | import Test.QuickCheck
 15 | 
 16 | import Data.Matrix.Sparse
 17 | import Data.Matrix.Sparse.Foreign
 18 | import Test.LinearAlgebra
 19 | 
 20 | main :: IO ()
 21 | main = hspec $ do
 22 |   describe "Data.Matrix.Sparse" $ do
 23 |     describe "fromTriples" (checkMatrix arbitrary)
 24 | 
 25 |     describe "kronecker" $ do
 26 |       it "assembles identity matrices" $ property $ do
 27 |         m <- arbdim
 28 |         n <- arbdim
 29 |         return $ kronecker (ident m) (ident n) === (ident (m * n) :: Matrix Vector Int)
 30 | 
 31 |       checkMatrix (kronecker <$> arbitrary <*> arbitrary)
 32 | 
 33 |     describe "diag" $ do
 34 |       it "takeDiag (diag v) == v" $ property $ do
 35 |         m <- arbdim
 36 |         v <- V.fromList <$> vectorOf m arbitrary
 37 |         return $ takeDiag (diag v) == (v :: Vector Int)
 38 | 
 39 |       checkMatrix (diag <$> arbitrary)
 40 | 
 41 |     describe "mulV" $ do
 42 |       it "ident `mulV` v == v" $ property $ do
 43 |         m <- arbdim
 44 |         v <- V.fromList <$> vectorOf m arbitrary
 45 |         let mat :: Matrix Vector Int
 46 |             mat = ident m
 47 |         return $ mat `mulV` v == v
 48 | 
 49 |     describe "addition" $ do
 50 |       it "a + zeros == a" prop_add_ident
 51 |       it "a - a == 0" prop_add_inv
 52 |       it "a + b == b + a" prop_add_commute
 53 |       it "a + (b + c) == (a + b) + c" prop_add_assoc
 54 |       checkMatrix $ (\(a, b) -> a + b) <$> arbitraryAdd2
 55 | 
 56 |     describe "transpose" $ do
 57 |       it "transpose . diag == diag" $ property $ do
 58 |         mat <- diag <$> arbitrary :: Gen (Matrix Vector Int)
 59 |         return (transpose mat === mat)
 60 | 
 61 |     describe "ctrans" $ do
 62 |       it "preserves hermitian matrices" $ do
 63 |         let m :: Matrix Vector (Complex Double)
 64 |             m = fromTriples 2 2 [(0, 0, 2), (0, 1, -1), (1, 0, -1), (1, 1, 2)]
 65 |         m `shouldBe` ctrans m
 66 |       it "preserves sigma_x" $ do
 67 |         let m :: Matrix Vector (Complex Double)
 68 |             m = fromTriples 2 2 [(0, 1, 1), (1, 0, 1)]
 69 |         m `shouldBe` ctrans m
 70 |       it "preserves sigma_y" $ do
 71 |         let m :: Matrix Vector (Complex Double)
 72 |             m = fromTriples 2 2 [(0, 1, 0 :+ (-1)), (1, 0, 0 :+ 1)]
 73 |         m `shouldBe` ctrans m
 74 | 
 75 |     describe "mul" $ do
 76 |       let mulIdentL :: Matrix Vector Int -> Property
 77 |           mulIdentL a = ident (nrows a) * a === a
 78 |       it "ident * a == a" (property mulIdentL)
 79 | 
 80 |       let mulIdentR :: Matrix Vector Int -> Property
 81 |           mulIdentR a = (a * ident (ncols a) === a)
 82 |       it "a * ident == a" (property mulIdentR)
 83 | 
 84 |       let mulAssoc :: Matrix Vector Int -> Gen Property
 85 |           mulAssoc a = do
 86 |             let m = ncols a
 87 |             n <- arbdim
 88 |             b <- arbitraryMatrix m n
 89 |             p <- arbdim
 90 |             c <- arbitraryMatrix n p
 91 |             return $ ((a * b) * c) === (a * (b * c))
 92 |       it "(a * b) * c == a * (b * c)" (property mulAssoc)
 93 | 
 94 |       let arbitraryMul :: Gen (Matrix Vector Int)
 95 |           arbitraryMul = do
 96 |             m <- arbdim
 97 |             n <- arbdim
 98 |             a <- arbitraryMatrix m n
 99 |             p <- arbdim
100 |             b <- arbitraryMatrix n p
101 |             return $! a * b
102 |       checkMatrix arbitraryMul
103 | 
104 |     describe "fromBlocksDiag" $ do
105 | 
106 |       it "assembles identity matrices" $ property $ do
107 |         m <- arbdim
108 |         n <- arbdim
109 |         let assembled = fromBlocksDiag
110 |                         [ [Just (ident m), Just (ident n)]
111 |                         , [Nothing, Nothing]
112 |                         ]
113 |         return $ assembled === (ident (m + n) :: Matrix Vector Int)
114 | 
115 |       let arbSymBlock :: Matrix Vector Double -> Gen Property
116 |           arbSymBlock arbMN = do
117 |             arbM <- arbitraryMatrix (nrows arbMN) (nrows arbMN)
118 |             arbN <- arbitraryMatrix (ncols arbMN) (ncols arbMN)
119 |             let arbSymM = arbM + ctrans arbM
120 |                 arbSymN = arbN + ctrans arbN
121 |                 assembled = fromBlocksDiag
122 |                             [ [Just arbSymM, Just arbSymN]
123 |                             , [Just arbMN, Just (ctrans arbMN)]
124 |                             ]
125 |             return $ assembled === ctrans assembled
126 | 
127 |       it "symmetric blockwise" (property arbSymBlock)
128 | 
129 |       let arbitraryFromBlocksDiag :: Gen (Matrix Vector Int)
130 |           arbitraryFromBlocksDiag = do
131 |             n <- arbdim
132 |             mats <- vectorOf n arbitrary
133 |             return $ fromBlocksDiag
134 |               $ (map Just mats)
135 |               : replicate (n - 1) (replicate n Nothing)
136 |       checkMatrix arbitraryFromBlocksDiag
137 | 
138 |   describe "Data.Matrix.Sparse.Foreign" $ do
139 |     it "fromForeign . withConstMatrix == id"
140 |       (property (prop_withConstFromForeign :: Matrix Vector Int -> Bool))
141 | 
142 | prop_withConstFromForeign
143 |   :: (Eq a, Num a, Storable a, Unbox a) => Matrix Vector a -> Bool
144 | prop_withConstFromForeign mat =
145 |   unsafePerformIO (withConstMatrix mat $ fromForeign True) == mat
146 | 
147 | prop_add_commute :: Property
148 | prop_add_commute = property $ do
149 |   (a, b) <- arbitraryAdd2
150 |   return (a + b === b + a)
151 | 
152 | prop_add_inv :: Property
153 | prop_add_inv = property $ do
154 |   a <- arbitrary :: Gen (Matrix Vector Int)
155 |   return (a - a === cmap (const 0) a)
156 | 
157 | prop_add_ident :: Property
158 | prop_add_ident = property $ do
159 |   a <- arbitrary :: Gen (Matrix Vector Int)
160 |   return (a + zeros (nrows a) (ncols a) === a)
161 | 
162 | prop_add_assoc :: Property
163 | prop_add_assoc = property $ do
164 |   (a, b, c) <- arbitraryAdd3
165 |   return (a + (b + c) === (a + b) + c)
166 | 
167 | arbitraryAdd2 :: Gen (Matrix Vector Int, Matrix Vector Int)
168 | arbitraryAdd2 = do
169 |   a <- arbitrary
170 |   b <- arbitraryMatrix (nrows a) (ncols a)
171 |   return (a, b)
172 | 
173 | arbitraryAdd3 :: Gen (Matrix Vector Int, Matrix Vector Int, Matrix Vector Int)
174 | arbitraryAdd3 = do
175 |   a <- arbitrary
176 |   b <- arbitraryMatrix (nrows a) (ncols a)
177 |   c <- arbitraryMatrix (nrows a) (ncols a)
178 |   return (a, b, c)
179 | 


--------------------------------------------------------------------------------
/feast/src/Numeric/LinearAlgebra/Feast.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns #-}
  2 | {-# LANGUAGE DataKinds #-}
  3 | {-# LANGUAGE ConstraintKinds #-}
  4 | {-# LANGUAGE FlexibleContexts #-}
  5 | {-# LANGUAGE FlexibleInstances #-}
  6 | {-# LANGUAGE LambdaCase #-}
  7 | {-# LANGUAGE RecordWildCards #-}
  8 | {-# LANGUAGE TypeFamilies #-}
  9 | 
 10 | module Numeric.LinearAlgebra.Feast
 11 |     (
 12 |       -- * Simple interface
 13 |       eigSH
 14 |     , geigSH
 15 |     , Feast
 16 |       -- * Advanced interface
 17 |     , FeastParams(..)
 18 |     , defaultFeastParams
 19 |     , eigSHParams
 20 |     , geigSHParams
 21 |     , geigSH_
 22 |     ) where
 23 | 
 24 | import Control.Applicative
 25 | import Control.Monad (when)
 26 | import Control.Monad.State.Strict (MonadState(..), evalStateT)
 27 | import Control.Monad.IO.Class
 28 | import Data.Maybe (isJust)
 29 | import Data.Traversable
 30 | import qualified Data.Vector.Storable as V
 31 | import qualified Data.Vector.Storable.Mutable as MV
 32 | import qualified Data.Vector.Unboxed as U
 33 | import Foreign.C.Types (CInt)
 34 | import Foreign.Marshal.Utils (with)
 35 | import Foreign.Ptr (Ptr)
 36 | import Foreign.Storable
 37 | import GHC.Stack (errorWithStackTrace)
 38 | import Prelude hiding (concat, error, mapM)
 39 | import System.GlobalLock (lock)
 40 | import System.IO.Unsafe
 41 | 
 42 | import Data.Complex.Enhanced
 43 | import qualified Numeric.LinearAlgebra as Dense
 44 | import qualified Numeric.LinearAlgebra.Devel as Dense
 45 | import Data.Matrix.Sparse
 46 | import Numeric.LinearAlgebra.Feast.Internal
 47 | import Numeric.LinearAlgebra.Umfpack
 48 | 
 49 | -- ------------------------------------------------------------------------
 50 | -- Simple interface
 51 | -- ------------------------------------------------------------------------
 52 | 
 53 | eigSH
 54 |   :: (Feast a, Unbox a)
 55 |   => Int
 56 |   -> (RealOf a, RealOf a)
 57 |   -> Matrix U.Vector a
 58 |   -> (Dense.Vector (RealOf a), Dense.Matrix a)
 59 | {-# INLINE eigSH #-}
 60 | eigSH = eigSHParams defaultFeastParams
 61 | 
 62 | geigSH
 63 |   :: (Feast a, Unbox a)
 64 |   => Int
 65 |   -> (RealOf a, RealOf a)
 66 |   -> Matrix U.Vector a
 67 |   -> Matrix U.Vector a
 68 |   -> (Dense.Vector (RealOf a), Dense.Matrix a)
 69 | {-# INLINE geigSH #-}
 70 | geigSH = geigSHParams defaultFeastParams
 71 | 
 72 | -- ------------------------------------------------------------------------
 73 | -- Advanced interface
 74 | -- ------------------------------------------------------------------------
 75 | 
 76 | data FeastParams
 77 |   = FeastParams
 78 |     { feastDebug :: !Bool
 79 |     , feastContourPoints :: !Int
 80 |     , feastTolerance :: !Int
 81 |     }
 82 | 
 83 | defaultFeastParams :: FeastParams
 84 | defaultFeastParams =
 85 |   FeastParams
 86 |     { feastDebug = False
 87 |     , feastContourPoints = 8
 88 |     , feastTolerance = 12
 89 |     }
 90 | 
 91 | eigSHParams
 92 |   :: (Feast a, Unbox a)
 93 |   => FeastParams
 94 |   -> Int
 95 |   -> (RealOf a, RealOf a)
 96 |   -> Matrix U.Vector a
 97 |   -> (Dense.Vector (RealOf a), Dense.Matrix a)
 98 | {-# INLINE eigSHParams #-}
 99 | eigSHParams = \params m0 bounds matA ->
100 |   geigSHParams params m0 bounds matA (ident (ncols matA))
101 | 
102 | geigSHParams
103 |   :: (Feast a, Unbox a)
104 |   => FeastParams
105 |   -> Int
106 |   -> (RealOf a, RealOf a)
107 |   -> Matrix U.Vector a
108 |   -> Matrix U.Vector a
109 |   -> (Dense.Vector (RealOf a), Dense.Matrix a)
110 | {-# INLINE geigSHParams #-}
111 | geigSHParams = \params m0 bounds matA matB ->
112 |   let (m, evals, evecs) = geigSH_ params m0 bounds Nothing matA matB
113 |   in (V.take m evals, Dense.takeColumns m evecs)
114 | 
115 | geigSH_
116 |   :: (Feast a, Unbox a)
117 |   => FeastParams
118 |   -> Int -> (RealOf a, RealOf a)
119 |   -> Maybe (Dense.Matrix a) -- ^ subspace guess
120 |   -> Matrix U.Vector a -> Matrix U.Vector a
121 |   -> (Int, Dense.Vector (RealOf a), Dense.Matrix a)
122 | {-# INLINE geigSH_ #-}
123 | geigSH_ FeastParams{..} !m0 (!_emin, !_emax) !guess !matA !matB = geigSH_go where
124 |   n = ncols matA
125 |   m0' = maybe m0 Dense.cols guess
126 |   n' = maybe n Dense.rows guess
127 | 
128 |   geigSH_go
129 |     | not (hermitian matA) = error "geigSH: matrix A not hermitian"
130 |     | not (hermitian matB) = error "geigSH: matrix B not hermitian"
131 |     | ncols matA /= ncols matB = error "geigSH: matrix sizes do not match"
132 |     | m0 /= m0' = error "geigSH: subspace guess has wrong column dimension"
133 |     | n /= n' = error "geigSH: subspace guess has wrong row dimension"
134 |     | otherwise = unsafePerformIO $ lock $
135 | 
136 |         -- initialize scalars
137 |         with (-1) $ \_ijob ->
138 |         with (fromIntegral n) $ \n_ ->
139 |         with 0 $ \_ze ->
140 |         with 0 $ \epsout ->
141 |         with 0 $ \loop ->
142 |         with _emin $ \_emin ->
143 |         with _emax $ \_emax ->
144 |         with (fromIntegral m0) $ \m0_ ->
145 |         with 0 $ \mode ->
146 |         with 0 $ \info -> do
147 | 
148 |           -- initialize vectors
149 |           _eigenvalues <- MV.replicate m0 0
150 |           _eigenvectors <- MV.replicate (m0 * n) 0
151 |           _work1 <- MV.replicate (m0 * n) 0
152 |           _work2 <- MV.replicate (m0 * n) 0
153 |           _aq <- MV.replicate (m0 * m0) 0
154 |           _bq <- MV.replicate (m0 * m0) 0
155 |           _res <- MV.replicate m0 0
156 | 
157 |           -- initialize subspace guess
158 |           case guess of
159 |             Nothing -> return ()
160 |             Just mat ->
161 |               V.copy
162 |                 _eigenvectors
163 |                 (Dense.unsafeMatrixToVector (Dense.fmat mat))
164 | 
165 |           -- initialize
166 |           fpm <- feastinit
167 | 
168 |           when (isJust guess) (MV.unsafeWrite fpm 4 1)
169 |           MV.unsafeWrite fpm 0 (if feastDebug then 1 else 0)
170 |           MV.unsafeWrite fpm 1 (fromIntegral feastContourPoints)
171 |           MV.unsafeWrite fpm 2 (fromIntegral feastTolerance)
172 | 
173 |           let feast_go =
174 |                 MV.unsafeWith fpm $ \_fpm ->
175 |                 MV.unsafeWith _work1 $ \_work1 ->
176 |                 MV.unsafeWith _work2 $ \_work2 ->
177 |                 MV.unsafeWith _aq $ \_aq ->
178 |                 MV.unsafeWith _bq $ \_bq ->
179 |                 MV.unsafeWith _eigenvalues $ \_eigenvalues ->
180 |                 MV.unsafeWith _eigenvectors $ \_eigenvectors ->
181 |                 MV.unsafeWith _res $ \_res -> do
182 |                   feast_rci
183 |                     _ijob n_ _ze _work1 _work2 _aq _bq
184 |                     _fpm epsout loop _emin _emax
185 |                     m0_ _eigenvalues _eigenvectors
186 |                     mode _res info
187 |                   peek _ijob
188 | 
189 |           let sliceMat mat =
190 |                 map
191 |                   (\c -> MV.unsafeSlice (c * n) n mat)
192 |                   [0..(m0 - 1)]
193 |           _work1 <- return (sliceMat _work1)
194 |           _work2 <- return (sliceMat _work2)
195 |           _eigenvectors <- return (sliceMat _eigenvectors)
196 | 
197 |           let solveLinear m = do
198 |                 Just (!mat, !fact) <- get
199 |                 liftIO $ mapM_
200 |                   (\work -> linearSolve_ fact m mat work >>= MV.copy work)
201 |                   _work2
202 | 
203 |               multiplyWork mat = liftIO $ do
204 |                 ndrop <- (+ (-1)) . fromIntegral <$> MV.unsafeRead fpm 23
205 |                 ntake <- fromIntegral <$> MV.unsafeRead fpm 24
206 |                 mapM_
207 |                   (\(!dst, !x) -> MV.set dst 0 >> axpy_ mat x dst)
208 |                   (take ntake (drop ndrop (zip _work1 _eigenvectors)))
209 | 
210 |               -- the shape of the result never changes, so the symbolic
211 |               -- analysis never needs to be repeated
212 |               analysis = analyze (lin (-1) matA 0 matB)
213 | 
214 |               factorMatrix = do
215 |                 _ze <- liftIO (peek _ze)
216 |                 let !mat = lin (-1) matA _ze matB
217 |                     !fact = factor mat analysis
218 |                 put (Just (mat, fact))
219 | 
220 |           evalStateT
221 |             (doM
222 |               (do job <- liftIO feast_go
223 |                   case job of
224 |                     10 -> factorMatrix
225 |                     11 -> solveLinear UmfpackNormal
226 |                     20 -> return ()
227 |                     21 -> solveLinear UmfpackTrans
228 |                     30 -> multiplyWork matA
229 |                     40 -> multiplyWork matB
230 |                     _ -> return ()
231 |                   return job)
232 |               (/= 0))
233 |             Nothing
234 | 
235 |           geigSH__decodeInfo info
236 | 
237 |           (,,)
238 |             <$> (fromIntegral <$> peek mode)
239 |             <*> V.freeze _eigenvalues
240 |             <*> (Dense.fromColumns <$> mapM V.freeze _eigenvectors)
241 | 
242 | -- ------------------------------------------------------------------------
243 | -- Utilities
244 | -- ------------------------------------------------------------------------
245 | 
246 | geigSH__decodeInfo :: Ptr CInt -> IO ()
247 | geigSH__decodeInfo info = do
248 |   peek info >>= \case
249 |     (-3) -> error "geigSH: internal error in reduced eigenvalue solver"
250 |     (-2) -> error "geigSH: internal error in inner system solver"
251 |     (-1) -> error "geigSH: internal error in memory allocation"
252 |     0 -> return ()
253 |     1 -> -- no eigenvalues in search interval, not really an error
254 |       return ()
255 |     2 -> putStrLn "geigSH: no convergence"
256 |     3 -> putStrLn "geigSH: subspace too small"
257 |     4 -> putStrLn "geigSH: only subspace returned"
258 |     i -> error ("geigSH: unknown error, info = " ++ show i)
259 | 
260 | error :: String -> a
261 | error = errorWithStackTrace
262 | 
263 | doM :: Monad m => m a -> (a -> Bool) -> m ()
264 | doM body check = doM_go where
265 |   doM_go = do
266 |     a <- body
267 |     when (check a) doM_go
268 | 


--------------------------------------------------------------------------------
/feast/LICENSE:
--------------------------------------------------------------------------------
  1 |              GNU GENERAL PUBLIC LICENSE
  2 |                 Version 2, June 1991
  3 | 
  4 |  Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
  5 |  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  6 |  Everyone is permitted to copy and distribute verbatim copies
  7 |  of this license document, but changing it is not allowed.
  8 | 
  9 |                      Preamble
 10 | 
 11 |   The licenses for most software are designed to take away your
 12 | freedom to share and change it.  By contrast, the GNU General Public
 13 | License is intended to guarantee your freedom to share and change free
 14 | software--to make sure the software is free for all its users.  This
 15 | General Public License applies to most of the Free Software
 16 | Foundation's software and to any other program whose authors commit to
 17 | using it.  (Some other Free Software Foundation software is covered by
 18 | the GNU Lesser General Public License instead.)  You can apply it to
 19 | your programs, too.
 20 | 
 21 |   When we speak of free software, we are referring to freedom, not
 22 | price.  Our General Public Licenses are designed to make sure that you
 23 | have the freedom to distribute copies of free software (and charge for
 24 | this service if you wish), that you receive source code or can get it
 25 | if you want it, that you can change the software or use pieces of it
 26 | in new free programs; and that you know you can do these things.
 27 | 
 28 |   To protect your rights, we need to make restrictions that forbid
 29 | anyone to deny you these rights or to ask you to surrender the rights.
 30 | These restrictions translate to certain responsibilities for you if you
 31 | distribute copies of the software, or if you modify it.
 32 | 
 33 |   For example, if you distribute copies of such a program, whether
 34 | gratis or for a fee, you must give the recipients all the rights that
 35 | you have.  You must make sure that they, too, receive or can get the
 36 | source code.  And you must show them these terms so they know their
 37 | rights.
 38 | 
 39 |   We protect your rights with two steps: (1) copyright the software, and
 40 | (2) offer you this license which gives you legal permission to copy,
 41 | distribute and/or modify the software.
 42 | 
 43 |   Also, for each author's protection and ours, we want to make certain
 44 | that everyone understands that there is no warranty for this free
 45 | software.  If the software is modified by someone else and passed on, we
 46 | want its recipients to know that what they have is not the original, so
 47 | that any problems introduced by others will not reflect on the original
 48 | authors' reputations.
 49 | 
 50 |   Finally, any free program is threatened constantly by software
 51 | patents.  We wish to avoid the danger that redistributors of a free
 52 | program will individually obtain patent licenses, in effect making the
 53 | program proprietary.  To prevent this, we have made it clear that any
 54 | patent must be licensed for everyone's free use or not licensed at all.
 55 | 
 56 |   The precise terms and conditions for copying, distribution and
 57 | modification follow.
 58 | 
 59 |              GNU GENERAL PUBLIC LICENSE
 60 |    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
 61 | 
 62 |   0. This License applies to any program or other work which contains
 63 | a notice placed by the copyright holder saying it may be distributed
 64 | under the terms of this General Public License.  The "Program", below,
 65 | refers to any such program or work, and a "work based on the Program"
 66 | means either the Program or any derivative work under copyright law:
 67 | that is to say, a work containing the Program or a portion of it,
 68 | either verbatim or with modifications and/or translated into another
 69 | language.  (Hereinafter, translation is included without limitation in
 70 | the term "modification".)  Each licensee is addressed as "you".
 71 | 
 72 | Activities other than copying, distribution and modification are not
 73 | covered by this License; they are outside its scope.  The act of
 74 | running the Program is not restricted, and the output from the Program
 75 | is covered only if its contents constitute a work based on the
 76 | Program (independent of having been made by running the Program).
 77 | Whether that is true depends on what the Program does.
 78 | 
 79 |   1. You may copy and distribute verbatim copies of the Program's
 80 | source code as you receive it, in any medium, provided that you
 81 | conspicuously and appropriately publish on each copy an appropriate
 82 | copyright notice and disclaimer of warranty; keep intact all the
 83 | notices that refer to this License and to the absence of any warranty;
 84 | and give any other recipients of the Program a copy of this License
 85 | along with the Program.
 86 | 
 87 | You may charge a fee for the physical act of transferring a copy, and
 88 | you may at your option offer warranty protection in exchange for a fee.
 89 | 
 90 |   2. You may modify your copy or copies of the Program or any portion
 91 | of it, thus forming a work based on the Program, and copy and
 92 | distribute such modifications or work under the terms of Section 1
 93 | above, provided that you also meet all of these conditions:
 94 | 
 95 |     a) You must cause the modified files to carry prominent notices
 96 |     stating that you changed the files and the date of any change.
 97 | 
 98 |     b) You must cause any work that you distribute or publish, that in
 99 |     whole or in part contains or is derived from the Program or any
100 |     part thereof, to be licensed as a whole at no charge to all third
101 |     parties under the terms of this License.
102 | 
103 |     c) If the modified program normally reads commands interactively
104 |     when run, you must cause it, when started running for such
105 |     interactive use in the most ordinary way, to print or display an
106 |     announcement including an appropriate copyright notice and a
107 |     notice that there is no warranty (or else, saying that you provide
108 |     a warranty) and that users may redistribute the program under
109 |     these conditions, and telling the user how to view a copy of this
110 |     License.  (Exception: if the Program itself is interactive but
111 |     does not normally print such an announcement, your work based on
112 |     the Program is not required to print an announcement.)
113 | 
114 | These requirements apply to the modified work as a whole.  If
115 | identifiable sections of that work are not derived from the Program,
116 | and can be reasonably considered independent and separate works in
117 | themselves, then this License, and its terms, do not apply to those
118 | sections when you distribute them as separate works.  But when you
119 | distribute the same sections as part of a whole which is a work based
120 | on the Program, the distribution of the whole must be on the terms of
121 | this License, whose permissions for other licensees extend to the
122 | entire whole, and thus to each and every part regardless of who wrote it.
123 | 
124 | Thus, it is not the intent of this section to claim rights or contest
125 | your rights to work written entirely by you; rather, the intent is to
126 | exercise the right to control the distribution of derivative or
127 | collective works based on the Program.
128 | 
129 | In addition, mere aggregation of another work not based on the Program
130 | with the Program (or with a work based on the Program) on a volume of
131 | a storage or distribution medium does not bring the other work under
132 | the scope of this License.
133 | 
134 |   3. You may copy and distribute the Program (or a work based on it,
135 | under Section 2) in object code or executable form under the terms of
136 | Sections 1 and 2 above provided that you also do one of the following:
137 | 
138 |     a) Accompany it with the complete corresponding machine-readable
139 |     source code, which must be distributed under the terms of Sections
140 |     1 and 2 above on a medium customarily used for software interchange; or,
141 | 
142 |     b) Accompany it with a written offer, valid for at least three
143 |     years, to give any third party, for a charge no more than your
144 |     cost of physically performing source distribution, a complete
145 |     machine-readable copy of the corresponding source code, to be
146 |     distributed under the terms of Sections 1 and 2 above on a medium
147 |     customarily used for software interchange; or,
148 | 
149 |     c) Accompany it with the information you received as to the offer
150 |     to distribute corresponding source code.  (This alternative is
151 |     allowed only for noncommercial distribution and only if you
152 |     received the program in object code or executable form with such
153 |     an offer, in accord with Subsection b above.)
154 | 
155 | The source code for a work means the preferred form of the work for
156 | making modifications to it.  For an executable work, complete source
157 | code means all the source code for all modules it contains, plus any
158 | associated interface definition files, plus the scripts used to
159 | control compilation and installation of the executable.  However, as a
160 | special exception, the source code distributed need not include
161 | anything that is normally distributed (in either source or binary
162 | form) with the major components (compiler, kernel, and so on) of the
163 | operating system on which the executable runs, unless that component
164 | itself accompanies the executable.
165 | 
166 | If distribution of executable or object code is made by offering
167 | access to copy from a designated place, then offering equivalent
168 | access to copy the source code from the same place counts as
169 | distribution of the source code, even though third parties are not
170 | compelled to copy the source along with the object code.
171 | 
172 |   4. You may not copy, modify, sublicense, or distribute the Program
173 | except as expressly provided under this License.  Any attempt
174 | otherwise to copy, modify, sublicense or distribute the Program is
175 | void, and will automatically terminate your rights under this License.
176 | However, parties who have received copies, or rights, from you under
177 | this License will not have their licenses terminated so long as such
178 | parties remain in full compliance.
179 | 
180 |   5. You are not required to accept this License, since you have not
181 | signed it.  However, nothing else grants you permission to modify or
182 | distribute the Program or its derivative works.  These actions are
183 | prohibited by law if you do not accept this License.  Therefore, by
184 | modifying or distributing the Program (or any work based on the
185 | Program), you indicate your acceptance of this License to do so, and
186 | all its terms and conditions for copying, distributing or modifying
187 | the Program or works based on it.
188 | 
189 |   6. Each time you redistribute the Program (or any work based on the
190 | Program), the recipient automatically receives a license from the
191 | original licensor to copy, distribute or modify the Program subject to
192 | these terms and conditions.  You may not impose any further
193 | restrictions on the recipients' exercise of the rights granted herein.
194 | You are not responsible for enforcing compliance by third parties to
195 | this License.
196 | 
197 |   7. If, as a consequence of a court judgment or allegation of patent
198 | infringement or for any other reason (not limited to patent issues),
199 | conditions are imposed on you (whether by court order, agreement or
200 | otherwise) that contradict the conditions of this License, they do not
201 | excuse you from the conditions of this License.  If you cannot
202 | distribute so as to satisfy simultaneously your obligations under this
203 | License and any other pertinent obligations, then as a consequence you
204 | may not distribute the Program at all.  For example, if a patent
205 | license would not permit royalty-free redistribution of the Program by
206 | all those who receive copies directly or indirectly through you, then
207 | the only way you could satisfy both it and this License would be to
208 | refrain entirely from distribution of the Program.
209 | 
210 | If any portion of this section is held invalid or unenforceable under
211 | any particular circumstance, the balance of the section is intended to
212 | apply and the section as a whole is intended to apply in other
213 | circumstances.
214 | 
215 | It is not the purpose of this section to induce you to infringe any
216 | patents or other property right claims or to contest validity of any
217 | such claims; this section has the sole purpose of protecting the
218 | integrity of the free software distribution system, which is
219 | implemented by public license practices.  Many people have made
220 | generous contributions to the wide range of software distributed
221 | through that system in reliance on consistent application of that
222 | system; it is up to the author/donor to decide if he or she is willing
223 | to distribute software through any other system and a licensee cannot
224 | impose that choice.
225 | 
226 | This section is intended to make thoroughly clear what is believed to
227 | be a consequence of the rest of this License.
228 | 
229 |   8. If the distribution and/or use of the Program is restricted in
230 | certain countries either by patents or by copyrighted interfaces, the
231 | original copyright holder who places the Program under this License
232 | may add an explicit geographical distribution limitation excluding
233 | those countries, so that distribution is permitted only in or among
234 | countries not thus excluded.  In such case, this License incorporates
235 | the limitation as if written in the body of this License.
236 | 
237 |   9. The Free Software Foundation may publish revised and/or new versions
238 | of the General Public License from time to time.  Such new versions will
239 | be similar in spirit to the present version, but may differ in detail to
240 | address new problems or concerns.
241 | 
242 | Each version is given a distinguishing version number.  If the Program
243 | specifies a version number of this License which applies to it and "any
244 | later version", you have the option of following the terms and conditions
245 | either of that version or of any later version published by the Free
246 | Software Foundation.  If the Program does not specify a version number of
247 | this License, you may choose any version ever published by the Free Software
248 | Foundation.
249 | 
250 |   10. If you wish to incorporate parts of the Program into other free
251 | programs whose distribution conditions are different, write to the author
252 | to ask for permission.  For software which is copyrighted by the Free
253 | Software Foundation, write to the Free Software Foundation; we sometimes
254 | make exceptions for this.  Our decision will be guided by the two goals
255 | of preserving the free status of all derivatives of our free software and
256 | of promoting the sharing and reuse of software generally.
257 | 
258 |                      NO WARRANTY
259 | 
260 |   11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
268 | REPAIR OR CORRECTION.
269 | 
270 |   12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
278 | POSSIBILITY OF SUCH DAMAGES.
279 | 
280 |               END OF TERMS AND CONDITIONS
281 | 
282 |      How to Apply These Terms to Your New Programs
283 | 
284 |   If you develop a new program, and you want it to be of the greatest
285 | possible use to the public, the best way to achieve this is to make it
286 | free software which everyone can redistribute and change under these terms.
287 | 
288 |   To do so, attach the following notices to the program.  It is safest
289 | to attach them to the start of each source file to most effectively
290 | convey the exclusion of warranty; and each file should have at least
291 | the "copyright" line and a pointer to where the full notice is found.
292 | 
293 |     <one line to give the program's name and a brief idea of what it does.>
294 |     Copyright (C) <year>  <name of author>
295 | 
296 |     This program is free software; you can redistribute it and/or modify
297 |     it under the terms of the GNU General Public License as published by
298 |     the Free Software Foundation; either version 2 of the License, or
299 |     (at your option) any later version.
300 | 
301 |     This program is distributed in the hope that it will be useful,
302 |     but WITHOUT ANY WARRANTY; without even the implied warranty of
303 |     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
304 |     GNU General Public License for more details.
305 | 
306 |     You should have received a copy of the GNU General Public License along
307 |     with this program; if not, write to the Free Software Foundation, Inc.,
308 |     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
309 | 
310 | Also add information on how to contact you by electronic and paper mail.
311 | 
312 | If the program is interactive, make it output a short notice like this
313 | when it starts in an interactive mode:
314 | 
315 |     Gnomovision version 69, Copyright (C) year name of author
316 |     Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
317 |     This is free software, and you are welcome to redistribute it
318 |     under certain conditions; type `show c' for details.
319 | 
320 | The hypothetical commands `show w' and `show c' should show the appropriate
321 | parts of the General Public License.  Of course, the commands you use may
322 | be called something other than `show w' and `show c'; they could even be
323 | mouse-clicks or menu items--whatever suits your program.
324 | 
325 | You should also get your employer (if you work as a programmer) or your
326 | school, if any, to sign a "copyright disclaimer" for the program, if
327 | necessary.  Here is a sample; alter the names:
328 | 
329 |   Yoyodyne, Inc., hereby disclaims all copyright interest in the program
330 |   `Gnomovision' (which makes passes at compilers) written by James Hacker.
331 | 
332 |   <signature of Ty Coon>, 1 April 1989
333 |   Ty Coon, President of Vice
334 | 
335 | This General Public License does not permit incorporating your program into
336 | proprietary programs.  If your program is a subroutine library, you may
337 | consider it more useful to permit linking proprietary applications with the
338 | library.  If this is what you want to do, use the GNU Lesser General
339 | Public License instead of this License.
340 | 


--------------------------------------------------------------------------------
/suitesparse/LICENSE:
--------------------------------------------------------------------------------
  1 |              GNU GENERAL PUBLIC LICENSE
  2 |                 Version 2, June 1991
  3 | 
  4 |  Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
  5 |  51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  6 |  Everyone is permitted to copy and distribute verbatim copies
  7 |  of this license document, but changing it is not allowed.
  8 | 
  9 |                      Preamble
 10 | 
 11 |   The licenses for most software are designed to take away your
 12 | freedom to share and change it.  By contrast, the GNU General Public
 13 | License is intended to guarantee your freedom to share and change free
 14 | software--to make sure the software is free for all its users.  This
 15 | General Public License applies to most of the Free Software
 16 | Foundation's software and to any other program whose authors commit to
 17 | using it.  (Some other Free Software Foundation software is covered by
 18 | the GNU Lesser General Public License instead.)  You can apply it to
 19 | your programs, too.
 20 | 
 21 |   When we speak of free software, we are referring to freedom, not
 22 | price.  Our General Public Licenses are designed to make sure that you
 23 | have the freedom to distribute copies of free software (and charge for
 24 | this service if you wish), that you receive source code or can get it
 25 | if you want it, that you can change the software or use pieces of it
 26 | in new free programs; and that you know you can do these things.
 27 | 
 28 |   To protect your rights, we need to make restrictions that forbid
 29 | anyone to deny you these rights or to ask you to surrender the rights.
 30 | These restrictions translate to certain responsibilities for you if you
 31 | distribute copies of the software, or if you modify it.
 32 | 
 33 |   For example, if you distribute copies of such a program, whether
 34 | gratis or for a fee, you must give the recipients all the rights that
 35 | you have.  You must make sure that they, too, receive or can get the
 36 | source code.  And you must show them these terms so they know their
 37 | rights.
 38 | 
 39 |   We protect your rights with two steps: (1) copyright the software, and
 40 | (2) offer you this license which gives you legal permission to copy,
 41 | distribute and/or modify the software.
 42 | 
 43 |   Also, for each author's protection and ours, we want to make certain
 44 | that everyone understands that there is no warranty for this free
 45 | software.  If the software is modified by someone else and passed on, we
 46 | want its recipients to know that what they have is not the original, so
 47 | that any problems introduced by others will not reflect on the original
 48 | authors' reputations.
 49 | 
 50 |   Finally, any free program is threatened constantly by software
 51 | patents.  We wish to avoid the danger that redistributors of a free
 52 | program will individually obtain patent licenses, in effect making the
 53 | program proprietary.  To prevent this, we have made it clear that any
 54 | patent must be licensed for everyone's free use or not licensed at all.
 55 | 
 56 |   The precise terms and conditions for copying, distribution and
 57 | modification follow.
 58 | 
 59 |              GNU GENERAL PUBLIC LICENSE
 60 |    TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
 61 | 
 62 |   0. This License applies to any program or other work which contains
 63 | a notice placed by the copyright holder saying it may be distributed
 64 | under the terms of this General Public License.  The "Program", below,
 65 | refers to any such program or work, and a "work based on the Program"
 66 | means either the Program or any derivative work under copyright law:
 67 | that is to say, a work containing the Program or a portion of it,
 68 | either verbatim or with modifications and/or translated into another
 69 | language.  (Hereinafter, translation is included without limitation in
 70 | the term "modification".)  Each licensee is addressed as "you".
 71 | 
 72 | Activities other than copying, distribution and modification are not
 73 | covered by this License; they are outside its scope.  The act of
 74 | running the Program is not restricted, and the output from the Program
 75 | is covered only if its contents constitute a work based on the
 76 | Program (independent of having been made by running the Program).
 77 | Whether that is true depends on what the Program does.
 78 | 
 79 |   1. You may copy and distribute verbatim copies of the Program's
 80 | source code as you receive it, in any medium, provided that you
 81 | conspicuously and appropriately publish on each copy an appropriate
 82 | copyright notice and disclaimer of warranty; keep intact all the
 83 | notices that refer to this License and to the absence of any warranty;
 84 | and give any other recipients of the Program a copy of this License
 85 | along with the Program.
 86 | 
 87 | You may charge a fee for the physical act of transferring a copy, and
 88 | you may at your option offer warranty protection in exchange for a fee.
 89 | 
 90 |   2. You may modify your copy or copies of the Program or any portion
 91 | of it, thus forming a work based on the Program, and copy and
 92 | distribute such modifications or work under the terms of Section 1
 93 | above, provided that you also meet all of these conditions:
 94 | 
 95 |     a) You must cause the modified files to carry prominent notices
 96 |     stating that you changed the files and the date of any change.
 97 | 
 98 |     b) You must cause any work that you distribute or publish, that in
 99 |     whole or in part contains or is derived from the Program or any
100 |     part thereof, to be licensed as a whole at no charge to all third
101 |     parties under the terms of this License.
102 | 
103 |     c) If the modified program normally reads commands interactively
104 |     when run, you must cause it, when started running for such
105 |     interactive use in the most ordinary way, to print or display an
106 |     announcement including an appropriate copyright notice and a
107 |     notice that there is no warranty (or else, saying that you provide
108 |     a warranty) and that users may redistribute the program under
109 |     these conditions, and telling the user how to view a copy of this
110 |     License.  (Exception: if the Program itself is interactive but
111 |     does not normally print such an announcement, your work based on
112 |     the Program is not required to print an announcement.)
113 | 
114 | These requirements apply to the modified work as a whole.  If
115 | identifiable sections of that work are not derived from the Program,
116 | and can be reasonably considered independent and separate works in
117 | themselves, then this License, and its terms, do not apply to those
118 | sections when you distribute them as separate works.  But when you
119 | distribute the same sections as part of a whole which is a work based
120 | on the Program, the distribution of the whole must be on the terms of
121 | this License, whose permissions for other licensees extend to the
122 | entire whole, and thus to each and every part regardless of who wrote it.
123 | 
124 | Thus, it is not the intent of this section to claim rights or contest
125 | your rights to work written entirely by you; rather, the intent is to
126 | exercise the right to control the distribution of derivative or
127 | collective works based on the Program.
128 | 
129 | In addition, mere aggregation of another work not based on the Program
130 | with the Program (or with a work based on the Program) on a volume of
131 | a storage or distribution medium does not bring the other work under
132 | the scope of this License.
133 | 
134 |   3. You may copy and distribute the Program (or a work based on it,
135 | under Section 2) in object code or executable form under the terms of
136 | Sections 1 and 2 above provided that you also do one of the following:
137 | 
138 |     a) Accompany it with the complete corresponding machine-readable
139 |     source code, which must be distributed under the terms of Sections
140 |     1 and 2 above on a medium customarily used for software interchange; or,
141 | 
142 |     b) Accompany it with a written offer, valid for at least three
143 |     years, to give any third party, for a charge no more than your
144 |     cost of physically performing source distribution, a complete
145 |     machine-readable copy of the corresponding source code, to be
146 |     distributed under the terms of Sections 1 and 2 above on a medium
147 |     customarily used for software interchange; or,
148 | 
149 |     c) Accompany it with the information you received as to the offer
150 |     to distribute corresponding source code.  (This alternative is
151 |     allowed only for noncommercial distribution and only if you
152 |     received the program in object code or executable form with such
153 |     an offer, in accord with Subsection b above.)
154 | 
155 | The source code for a work means the preferred form of the work for
156 | making modifications to it.  For an executable work, complete source
157 | code means all the source code for all modules it contains, plus any
158 | associated interface definition files, plus the scripts used to
159 | control compilation and installation of the executable.  However, as a
160 | special exception, the source code distributed need not include
161 | anything that is normally distributed (in either source or binary
162 | form) with the major components (compiler, kernel, and so on) of the
163 | operating system on which the executable runs, unless that component
164 | itself accompanies the executable.
165 | 
166 | If distribution of executable or object code is made by offering
167 | access to copy from a designated place, then offering equivalent
168 | access to copy the source code from the same place counts as
169 | distribution of the source code, even though third parties are not
170 | compelled to copy the source along with the object code.
171 | 
172 |   4. You may not copy, modify, sublicense, or distribute the Program
173 | except as expressly provided under this License.  Any attempt
174 | otherwise to copy, modify, sublicense or distribute the Program is
175 | void, and will automatically terminate your rights under this License.
176 | However, parties who have received copies, or rights, from you under
177 | this License will not have their licenses terminated so long as such
178 | parties remain in full compliance.
179 | 
180 |   5. You are not required to accept this License, since you have not
181 | signed it.  However, nothing else grants you permission to modify or
182 | distribute the Program or its derivative works.  These actions are
183 | prohibited by law if you do not accept this License.  Therefore, by
184 | modifying or distributing the Program (or any work based on the
185 | Program), you indicate your acceptance of this License to do so, and
186 | all its terms and conditions for copying, distributing or modifying
187 | the Program or works based on it.
188 | 
189 |   6. Each time you redistribute the Program (or any work based on the
190 | Program), the recipient automatically receives a license from the
191 | original licensor to copy, distribute or modify the Program subject to
192 | these terms and conditions.  You may not impose any further
193 | restrictions on the recipients' exercise of the rights granted herein.
194 | You are not responsible for enforcing compliance by third parties to
195 | this License.
196 | 
197 |   7. If, as a consequence of a court judgment or allegation of patent
198 | infringement or for any other reason (not limited to patent issues),
199 | conditions are imposed on you (whether by court order, agreement or
200 | otherwise) that contradict the conditions of this License, they do not
201 | excuse you from the conditions of this License.  If you cannot
202 | distribute so as to satisfy simultaneously your obligations under this
203 | License and any other pertinent obligations, then as a consequence you
204 | may not distribute the Program at all.  For example, if a patent
205 | license would not permit royalty-free redistribution of the Program by
206 | all those who receive copies directly or indirectly through you, then
207 | the only way you could satisfy both it and this License would be to
208 | refrain entirely from distribution of the Program.
209 | 
210 | If any portion of this section is held invalid or unenforceable under
211 | any particular circumstance, the balance of the section is intended to
212 | apply and the section as a whole is intended to apply in other
213 | circumstances.
214 | 
215 | It is not the purpose of this section to induce you to infringe any
216 | patents or other property right claims or to contest validity of any
217 | such claims; this section has the sole purpose of protecting the
218 | integrity of the free software distribution system, which is
219 | implemented by public license practices.  Many people have made
220 | generous contributions to the wide range of software distributed
221 | through that system in reliance on consistent application of that
222 | system; it is up to the author/donor to decide if he or she is willing
223 | to distribute software through any other system and a licensee cannot
224 | impose that choice.
225 | 
226 | This section is intended to make thoroughly clear what is believed to
227 | be a consequence of the rest of this License.
228 | 
229 |   8. If the distribution and/or use of the Program is restricted in
230 | certain countries either by patents or by copyrighted interfaces, the
231 | original copyright holder who places the Program under this License
232 | may add an explicit geographical distribution limitation excluding
233 | those countries, so that distribution is permitted only in or among
234 | countries not thus excluded.  In such case, this License incorporates
235 | the limitation as if written in the body of this License.
236 | 
237 |   9. The Free Software Foundation may publish revised and/or new versions
238 | of the General Public License from time to time.  Such new versions will
239 | be similar in spirit to the present version, but may differ in detail to
240 | address new problems or concerns.
241 | 
242 | Each version is given a distinguishing version number.  If the Program
243 | specifies a version number of this License which applies to it and "any
244 | later version", you have the option of following the terms and conditions
245 | either of that version or of any later version published by the Free
246 | Software Foundation.  If the Program does not specify a version number of
247 | this License, you may choose any version ever published by the Free Software
248 | Foundation.
249 | 
250 |   10. If you wish to incorporate parts of the Program into other free
251 | programs whose distribution conditions are different, write to the author
252 | to ask for permission.  For software which is copyrighted by the Free
253 | Software Foundation, write to the Free Software Foundation; we sometimes
254 | make exceptions for this.  Our decision will be guided by the two goals
255 | of preserving the free status of all derivatives of our free software and
256 | of promoting the sharing and reuse of software generally.
257 | 
258 |                      NO WARRANTY
259 | 
260 |   11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
268 | REPAIR OR CORRECTION.
269 | 
270 |   12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
278 | POSSIBILITY OF SUCH DAMAGES.
279 | 
280 |               END OF TERMS AND CONDITIONS
281 | 
282 |      How to Apply These Terms to Your New Programs
283 | 
284 |   If you develop a new program, and you want it to be of the greatest
285 | possible use to the public, the best way to achieve this is to make it
286 | free software which everyone can redistribute and change under these terms.
287 | 
288 |   To do so, attach the following notices to the program.  It is safest
289 | to attach them to the start of each source file to most effectively
290 | convey the exclusion of warranty; and each file should have at least
291 | the "copyright" line and a pointer to where the full notice is found.
292 | 
293 |     <one line to give the program's name and a brief idea of what it does.>
294 |     Copyright (C) <year>  <name of author>
295 | 
296 |     This program is free software; you can redistribute it and/or modify
297 |     it under the terms of the GNU General Public License as published by
298 |     the Free Software Foundation; either version 2 of the License, or
299 |     (at your option) any later version.
300 | 
301 |     This program is distributed in the hope that it will be useful,
302 |     but WITHOUT ANY WARRANTY; without even the implied warranty of
303 |     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
304 |     GNU General Public License for more details.
305 | 
306 |     You should have received a copy of the GNU General Public License along
307 |     with this program; if not, write to the Free Software Foundation, Inc.,
308 |     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
309 | 
310 | Also add information on how to contact you by electronic and paper mail.
311 | 
312 | If the program is interactive, make it output a short notice like this
313 | when it starts in an interactive mode:
314 | 
315 |     Gnomovision version 69, Copyright (C) year name of author
316 |     Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
317 |     This is free software, and you are welcome to redistribute it
318 |     under certain conditions; type `show c' for details.
319 | 
320 | The hypothetical commands `show w' and `show c' should show the appropriate
321 | parts of the General Public License.  Of course, the commands you use may
322 | be called something other than `show w' and `show c'; they could even be
323 | mouse-clicks or menu items--whatever suits your program.
324 | 
325 | You should also get your employer (if you work as a programmer) or your
326 | school, if any, to sign a "copyright disclaimer" for the program, if
327 | necessary.  Here is a sample; alter the names:
328 | 
329 |   Yoyodyne, Inc., hereby disclaims all copyright interest in the program
330 |   `Gnomovision' (which makes passes at compilers) written by James Hacker.
331 | 
332 |   <signature of Ty Coon>, 1 April 1989
333 |   Ty Coon, President of Vice
334 | 
335 | This General Public License does not permit incorporating your program into
336 | proprietary programs.  If your program is a subroutine library, you may
337 | consider it more useful to permit linking proprietary applications with the
338 | library.  If this is what you want to do, use the GNU Lesser General
339 | Public License instead of this License.
340 | 


--------------------------------------------------------------------------------
/sparse-linear/src/Data/Matrix/Sparse.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE BangPatterns #-}
  2 | {-# LANGUAGE CPP #-}
  3 | {-# LANGUAGE FlexibleContexts #-}
  4 | {-# LANGUAGE FlexibleInstances #-}
  5 | {-# LANGUAGE GADTs #-}
  6 | {-# LANGUAGE ForeignFunctionInterface #-}
  7 | {-# LANGUAGE RecordWildCards #-}
  8 | {-# LANGUAGE StandaloneDeriving #-}
  9 | {-# LANGUAGE TypeFamilies #-}
 10 | {-# LANGUAGE UndecidableInstances #-}
 11 | {-# LANGUAGE ViewPatterns #-}
 12 | 
 13 | module Data.Matrix.Sparse
 14 |        ( Matrix(..), cmap, scale, nonZero, slice
 15 |        , compress, decompress, dedupInPlace
 16 |        , fromTriples, (><)
 17 |        , transpose, ctrans, hermitian
 18 |        , outer
 19 |        , axpy_, axpy, mulV
 20 |        , glin, lin
 21 |        , hjoin, hcat, vjoin, vcat
 22 |        , toColumns, unsafeFromColumns
 23 |        , fromBlocks, fromBlocksDiag
 24 |        , kronecker
 25 |        , takeDiag, diag, blockDiag
 26 |        , ident, zeros
 27 |        , pack
 28 |        , subMatrix
 29 |        , Unbox, module Data.Complex.Enhanced
 30 |        ) where
 31 | 
 32 | #if __GLASGOW_HASKELL__ < 710
 33 | import Control.Applicative
 34 | #endif
 35 | import Control.Monad (when)
 36 | import Control.Monad.Primitive (PrimMonad, PrimState)
 37 | import Control.Monad.ST (runST)
 38 | import qualified Data.Foldable as F
 39 | import qualified Data.List as L
 40 | import Data.Maybe (catMaybes)
 41 | #if __GLASGOW_HASKELL__ < 710
 42 | import Data.Monoid ((<>), Monoid(..), First(..))
 43 | #else
 44 | import Data.Monoid ((<>), First(..))
 45 | #endif
 46 | import Data.MonoTraversable (Element, MonoFoldable(..), MonoFunctor(..))
 47 | import Data.Ord (comparing)
 48 | import qualified Data.Vector as Boxed
 49 | import qualified Data.Vector.Algorithms.Intro as Intro
 50 | import qualified Data.Vector.Generic as G
 51 | import qualified Data.Vector.Generic.Mutable as GM
 52 | import qualified Data.Vector.Storable as VS
 53 | import qualified Data.Vector.Storable.Mutable as VSM
 54 | import Data.Vector.Unboxed (Vector, Unbox)
 55 | import qualified Data.Vector.Unboxed as U
 56 | import Data.Vector.Unboxed.Mutable (MVector)
 57 | import qualified Data.Vector.Unboxed.Mutable as UM
 58 | import Foreign.Storable (Storable)
 59 | import GHC.Stack (errorWithStackTrace)
 60 | import qualified Numeric.LinearAlgebra.HMatrix as Dense
 61 | 
 62 | import Data.Complex.Enhanced
 63 | import qualified Data.Vector.Sparse as S
 64 | import qualified Data.Vector.Sparse.ScatterGather as SG
 65 | import Data.Vector.Util
 66 | 
 67 | -- | Matrix in compressed sparse column (CSC) format.
 68 | data Matrix v a = Matrix
 69 |   { ncols :: !Int -- ^ number of columns
 70 |   , nrows :: !Int -- ^ number of rows
 71 |   , pointers :: !(Vector Int)
 72 |                 -- ^ starting index of each slice,
 73 |                 -- last element is number of non-zero entries
 74 |   , indices :: Vector Int
 75 |   , values :: v a
 76 |   }
 77 | 
 78 | deriving instance Eq (v a) => Eq (Matrix v a)
 79 | deriving instance Show (v a) => Show (Matrix v a)
 80 | deriving instance Read (v a) => Read (Matrix v a)
 81 | 
 82 | type instance Element (Matrix v a) = a
 83 | 
 84 | instance Unbox a => MonoFunctor (Matrix Vector a) where
 85 |   {-# INLINE omap #-}
 86 |   omap = cmap
 87 | 
 88 | instance Unbox a => MonoFoldable (Matrix Vector a) where
 89 |   {-# INLINE ofoldMap #-}
 90 |   {-# INLINE ofoldr #-}
 91 |   {-# INLINE ofoldl' #-}
 92 |   {-# INLINE ofoldr1Ex #-}
 93 |   {-# INLINE ofoldl1Ex' #-}
 94 |   ofoldMap = \f mat -> ofoldMap f (values mat)
 95 |   ofoldr = \f r mat -> G.foldr f r (values mat)
 96 |   ofoldl' = \f r mat -> G.foldl' f r (values mat)
 97 |   ofoldr1Ex = \f mat -> G.foldr1 f (values mat)
 98 |   ofoldl1Ex' = \f mat -> G.foldl1' f (values mat)
 99 | 
100 | instance (Num a, Unbox a) => Num (Matrix Vector a) where
101 |   {-# INLINE (+) #-}
102 |   {-# INLINE (-) #-}
103 |   {-# INLINE (*) #-}
104 |   {-# INLINE negate #-}
105 |   {-# INLINE abs #-}
106 |   {-# INLINE signum #-}
107 |   (+) = \a b -> glin 0 (+) a (+) b
108 |   (-) = \a b -> glin 0 (+) a (-) b
109 |   (*) = mm
110 |   negate = omap negate
111 |   abs = omap abs
112 |   signum = omap signum
113 |   fromInteger = errorWithStackTrace "fromInteger: not implemented"
114 | 
115 | nonZero :: Unbox a => Matrix Vector a -> Int
116 | {-# INLINE nonZero #-}
117 | nonZero = \Matrix {..} -> U.last pointers
118 | 
119 | cmap :: (G.Vector v a, G.Vector v b) => (a -> b) -> Matrix v a -> Matrix v b
120 | {-# INLINE cmap #-}
121 | cmap = \f m -> m { values = G.map f (values m) }
122 | 
123 | scale :: (Num a, Unbox a) => a -> Matrix Vector a -> Matrix Vector a
124 | {-# INLINE scale #-}
125 | scale = \x -> cmap (* x)
126 | 
127 | -- | Given a vector of pointers to slices in an array, return the indexed slice.
128 | -- The following requirements are not checked:
129 | -- * @index + 1 < length pointers@
130 | -- * @last pointers == length data@
131 | -- * for all @0 <= i < length pointers@, @pointers ! i <= pointers ! (i + 1)@
132 | basicUnsafeSlice
133 |   :: G.Vector v a
134 |   => Vector Int -- ^ pointers
135 |   -> v a -- ^ data
136 |   -> Int -- ^ index of slice
137 |   -> v a
138 | {-# INLINE basicUnsafeSlice #-}
139 | basicUnsafeSlice = \ptrs dat ix ->
140 |   let start = U.unsafeIndex ptrs ix
141 |       end = U.unsafeIndex ptrs (ix + 1)
142 |   in G.unsafeSlice start (end - start) dat
143 | 
144 | -- | Given a vector of pointers to slices in an array, return the indexed slice.
145 | -- The following requirements are not checked:
146 | -- * @index + 1 < length pointers@
147 | -- * @last pointers == length data@
148 | -- * for all @0 <= i < length pointers@, @pointers ! i <= pointers ! (i + 1)@
149 | basicUnsafeSliceM
150 |   :: Unbox a
151 |   => Vector Int -- ^ pointers
152 |   -> Int -- ^ index of slice
153 |   -> MVector s a -- ^ data
154 |   -> MVector s a
155 | {-# INLINE basicUnsafeSliceM #-}
156 | basicUnsafeSliceM = \ptrs ix dat ->
157 |   let start = U.unsafeIndex ptrs ix
158 |       end = U.unsafeIndex ptrs (ix + 1)
159 |   in UM.unsafeSlice start (end - start) dat
160 | 
161 | -- | Return a sparse vector representing the indexed column from the matrix.
162 | -- The following requirements are not checked:
163 | -- * @index < ncols matrix@
164 | unsafeSlice
165 |   :: G.Vector v a
166 |   => Matrix v a
167 |   -> Int  -- ^ column index
168 |   -> S.Vector v a
169 | {-# INLINE unsafeSlice #-}
170 | unsafeSlice Matrix {..} c
171 |   = S.Vector { S.length = nrows
172 |              , S.indices = basicUnsafeSlice pointers indices c
173 |              , S.values = basicUnsafeSlice pointers values c
174 |              }
175 | 
176 | slice :: Unbox a => Matrix Vector a -> Int -> S.Vector Vector a
177 | {-# INLINE slice #-}
178 | slice mat c
179 |   | c >= ncols mat = oops "column out of range"
180 |   | otherwise = unsafeSlice mat c
181 |   where
182 |     oops msg = error ("slice: " ++ msg)
183 | 
184 | compress :: (Num a, Unbox a) =>
185 |             Int  -- ^ number of rows
186 |          -> Int  -- ^ number of columns
187 |          -> Vector Int -- ^ row indices
188 |          -> Vector Int -- ^ column indices
189 |          -> Vector a -- ^ values
190 |          -> Matrix Vector a
191 | compress nrows ncols _rows _cols _vals
192 |   | U.length _rows /= U.length _cols = oops "row and column array lengths differ"
193 |   | U.length _rows /= G.length _vals = oops "row and value array lengths differ"
194 |   | otherwise = runST $ do
195 | 
196 |     let checkBounds bound prev ix this
197 |           | this >= 0 && this < bound = prev <> mempty
198 |           | otherwise = prev <> First (Just ix)
199 | 
200 |     -- check bounds of row indices
201 |     case getFirst (U.ifoldl' (checkBounds nrows) mempty _rows) of
202 |       Nothing -> return ()
203 |       Just ix ->
204 |         let bounds = show (0 :: Int, nrows)
205 |         in oops ("row index out of bounds " ++ bounds ++ " at " ++ show ix)
206 | 
207 |     -- check bounds of column indices
208 |     case getFirst (U.ifoldl' (checkBounds ncols) mempty _cols) of
209 |       Nothing -> return ()
210 |       Just ix ->
211 |         let bounds = show (0 :: Int, ncols)
212 |         in oops ("column index out of bounds " ++ bounds ++ " at " ++ show ix)
213 | 
214 |     _rows <- U.thaw _rows
215 |     _cols <- U.thaw _cols
216 |     _vals <- U.thaw _vals
217 |     let _entries = UM.zip _rows _vals
218 | 
219 |     Intro.sortBy (comparing fst) $ UM.zip _cols _entries
220 | 
221 |     -- deduplicate columns
222 |     -- sum entries so there is at most one entry for each row and column
223 |     -- ndel is a vector holding the number of entries removed from each column
224 |     ndel <- U.forM (U.enumFromN 0 ncols) $ \m ->
225 |       dedupInPlace nrows $ basicUnsafeSliceM ptrs m _entries
226 | 
227 |     let
228 |       -- the number of indices each column should be shifted down in the
229 |       -- entries vector
230 |       shifts = U.scanl' (+) 0 ndel
231 |       -- the final column-start pointers into the entries matrix
232 |       pointers = U.zipWith (-) ptrs shifts
233 | 
234 |     -- perform the shifts
235 |     U.forM_ (U.enumFromN 0 ncols) $ \m -> do
236 |       shift <- U.unsafeIndexM shifts m
237 |       when (shift > 0) $ do
238 |         start <- U.unsafeIndexM ptrs m
239 |         end <- U.unsafeIndexM ptrs (m + 1)
240 |         let len = end - start
241 |             start' = start - shift
242 |         UM.move
243 |           (UM.unsafeSlice start' len _entries)
244 |           (UM.unsafeSlice start len _entries)
245 | 
246 |     let nz' = U.last pointers
247 |     entries <- U.force <$> U.unsafeFreeze (UM.unsafeSlice 0 nz' _entries)
248 |     let (indices, values) = U.unzip entries
249 | 
250 |     return Matrix {..}
251 |     where
252 |       oops str = errorWithStackTrace ("compress: " ++ str)
253 |       ptrs = computePtrs ncols _cols
254 | 
255 | {-# NOINLINE compress #-}
256 | 
257 | dedupInPlace
258 |   :: (Num a, PrimMonad m, Unbox a)
259 |   => Int -> MVector (PrimState m) (Int, a) -> m Int
260 | {-# INLINE dedupInPlace #-}
261 | dedupInPlace idim _entries = do
262 |   Intro.sortBy (comparing fst) _entries
263 |   let len = UM.length _entries
264 |       (ixs, xs) = UM.unzip _entries
265 |       dedup_go w r del
266 |         | r < len = do
267 |             ixr <- UM.unsafeRead ixs r
268 |             ixw <- UM.unsafeRead ixs w
269 |             if ixr == ixw
270 |               then do
271 |                 UM.unsafeWrite ixs r idim
272 |                 x <- UM.unsafeRead xs r
273 |                 x' <- UM.unsafeRead xs w
274 |                 UM.unsafeWrite xs w (x' + x)
275 |                 dedup_go w (r + 1) (del + 1)
276 |               else dedup_go r (r + 1) del
277 |         | otherwise = return del
278 |   del <- dedup_go 0 1 0
279 |   Intro.sortBy (comparing fst) _entries
280 |   return del
281 | 
282 | computePtrs :: Int -> Vector Int -> Vector Int
283 | {-# INLINE computePtrs #-}
284 | computePtrs n indices = runST $ do
285 |   counts <- UM.replicate n 0
286 |   -- scan the indices once, counting the occurrences of each index
287 |   U.forM_ indices $ \ix -> do
288 |     count <- UM.unsafeRead counts ix
289 |     UM.unsafeWrite counts ix (count + 1)
290 |   -- compute the index pointers by prefix-summing the occurrence counts
291 |   U.scanl (+) 0 <$> U.freeze counts
292 | 
293 | decompress :: Vector Int -> Vector Int
294 | {-# INLINE decompress #-}
295 | decompress = \ptrs -> U.create $ do
296 |   indices <- UM.new $ U.last ptrs
297 |   U.forM_ (U.enumFromN 0 $ U.length ptrs - 1) $ \c ->
298 |     UM.set (basicUnsafeSliceM ptrs c indices) c
299 |   return indices
300 | 
301 | transpose :: Unbox a => Matrix Vector a -> Matrix Vector a
302 | {-# INLINE transpose #-}
303 | transpose Matrix {..} = runST $ do
304 |   let nz = U.length values
305 |       ptrs = computePtrs nrows indices
306 | 
307 |   -- re-initialize row counts from row pointers
308 |   count <- U.thaw $ U.unsafeSlice 0 nrows ptrs
309 | 
310 |   _ixs <- UM.new nz
311 |   _xs <- UM.new nz
312 | 
313 |   -- copy each column into place
314 |   U.forM_ (U.enumFromN 0 ncols) $ \m -> do
315 |     U.forM_ (basicUnsafeSlice pointers (U.zip indices values) m) $ \(n, x) -> do
316 |       ix <- preincrement count n
317 |       UM.unsafeWrite _ixs ix m
318 |       UM.unsafeWrite _xs ix x
319 | 
320 |   _ixs <- U.freeze _ixs
321 |   _xs <- U.freeze _xs
322 | 
323 |   return Matrix
324 |     { ncols = nrows
325 |     , nrows = ncols
326 |     , pointers = ptrs
327 |     , indices = _ixs
328 |     , values = _xs
329 |     }
330 | 
331 | outer
332 |   :: (Num a, Unbox a)
333 |   => S.Vector Vector a -- ^ sparse column vector
334 |   -> S.Vector Vector a -- ^ sparse row vector
335 |   -> Matrix Vector a
336 | {-# INLINE outer #-}
337 | outer = \sliceC sliceR ->
338 |   let -- indices of sliceM are outer (major) indices of result
339 |       -- indices of sliceN are inner (minor) indices of result
340 |       S.Vector nrows indicesR valuesR = sliceR
341 |       S.Vector ncols indicesC valuesC = sliceC
342 |       lenR = U.length valuesR
343 |       lenC = U.length valuesC
344 |       lengths = U.create $ do
345 |         lens <- UM.replicate (ncols + 1) 0
346 |         U.forM_ indicesC $ \m -> UM.unsafeWrite lens m lenR
347 |         return lens
348 |       pointers = U.scanl' (+) 0 lengths
349 |       indices = U.concat $ replicate lenC indicesR
350 |       values = U.create $ do
351 |         vals <- UM.new (lenC * lenR)
352 |         U.forM_ (U.zip indicesC valuesC) $ \(ix, a) ->
353 |           U.copy (basicUnsafeSliceM pointers ix vals) $ U.map (* a) valuesR
354 |         return vals
355 |   in Matrix {..}
356 | 
357 | fromTriples
358 |   :: (Num a, Unbox a)
359 |   => Int -> Int -> [(Int, Int, a)] -> Matrix Vector a
360 | {-# INLINE fromTriples #-}
361 | fromTriples = \nr nc triples ->
362 |   let (rows, cols, vals) = unzip3 triples
363 |   in compress nr nc (U.fromList rows) (U.fromList cols) (U.fromList vals)
364 | 
365 | (><)
366 |   :: (Num a, Unbox a)
367 |   => Int -> Int -> [(Int, Int, a)] -> Matrix Vector a
368 | {-# INLINE (><) #-}
369 | (><) = fromTriples
370 | 
371 | ctrans
372 |   :: (IsReal a, Num a, Unbox a)
373 |   => Matrix Vector a -> Matrix Vector a
374 | {-# INLINE ctrans #-}
375 | ctrans = omap conj . transpose
376 | 
377 | hermitian :: (Eq a, IsReal a, Num a, Unbox a) => Matrix Vector a -> Bool
378 | {-# INLINE hermitian #-}
379 | hermitian m = (ctrans m) == m
380 | 
381 | toColumns :: Unbox a => Matrix Vector a -> Boxed.Vector (S.Vector Vector a)
382 | {-# INLINE toColumns #-}
383 | toColumns mat = Boxed.generate (ncols mat) (slice mat)
384 | 
385 | unsafeFromColumns :: Unbox a
386 |                   => Boxed.Vector (S.Vector Vector a)
387 |                   -> Matrix Vector a
388 | {-# INLINE unsafeFromColumns #-}
389 | unsafeFromColumns cols
390 |   = Matrix
391 |     { nrows = U.head lengths
392 |     , ncols = Boxed.length cols
393 |     , pointers = U.scanl' (+) 0 nonZeros
394 |     , indices = U.concat (S.indices <$> Boxed.toList cols)
395 |     , values = U.concat (S.values <$> Boxed.toList cols)
396 |     }
397 |   where
398 |     lengths = U.convert (Boxed.map S.length cols)
399 |     nonZeros = U.convert (Boxed.map S.nonZero cols)
400 | 
401 | glin :: (Unbox a, Unbox b, Unbox c)
402 |      => c
403 |      -> (c -> a -> c) -> Matrix Vector a
404 |      -> (c -> b -> c) -> Matrix Vector b
405 |      -> Matrix Vector c
406 | {-# INLINE glin #-}
407 | glin c fA matA fB matB
408 |   | nrows matA /= nrows matB = oops "row number mismatch"
409 |   | ncols matA /= ncols matB = oops "column number mismatch"
410 |   | otherwise
411 |       = unsafeFromColumns $ SG.run (nrows matA) $ do
412 |         let scatterColumns colA colB
413 |               | S.null colA = return (S.cmap (fB c) colB)
414 |               | S.null colB = return (S.cmap (fA c) colA)
415 |               | otherwise = do
416 |                   SG.reset c
417 |                   SG.unsafeScatter colA fA
418 |                   SG.unsafeScatter colB fB
419 |                   SG.gather
420 |         Boxed.zipWithM scatterColumns colsA colsB
421 |   where
422 |     oops str = errorWithStackTrace ("glin: " ++ str)
423 |     colsA = toColumns matA
424 |     colsB = toColumns matB
425 | 
426 | lin
427 |   :: (Num a, Unbox a)
428 |   => a -> Matrix Vector a -> a -> Matrix Vector a -> Matrix Vector a
429 | {-# INLINE lin #-}
430 | lin alpha matA beta matB
431 |   = glin 0 (\r a -> r + alpha * a) matA (\r b -> r + beta * b) matB
432 | 
433 | axpy_
434 |   :: (GM.MVector v a, Num a, PrimMonad m, Unbox a)
435 |   => Matrix Vector a -> v (PrimState m) a -> v (PrimState m) a -> m ()
436 | {-# INLINE axpy_ #-}
437 | axpy_ Matrix {..} xs ys
438 |   | GM.length xs /= ncols = oops ("column dimension "
439 |                                   ++ show ncols
440 |                                   ++ " does not match operand dimension "
441 |                                   ++ show (GM.length xs))
442 |   | GM.length ys /= nrows = oops ("row dimension "
443 |                                   ++ show nrows
444 |                                   ++ " does not match result dimension "
445 |                                   ++ show (GM.length ys))
446 |   | otherwise =
447 |       U.forM_ (U.enumFromN 0 ncols) $ \c -> do
448 |         U.forM_ (basicUnsafeSlice pointers (U.zip indices values) c) $ \(r, a) -> do
449 |           x <- GM.unsafeRead xs c
450 |           y <- GM.unsafeRead ys r
451 |           GM.unsafeWrite ys r (a * x + y)
452 |   where
453 |     oops str = errorWithStackTrace ("axpy_: " ++ str)
454 | 
455 | axpy :: (Num a, Unbox a) => Matrix Vector a -> Vector a -> Vector a -> Vector a
456 | {-# SPECIALIZE axpy :: Matrix Vector Double -> Vector Double -> Vector Double -> Vector Double #-}
457 | {-# SPECIALIZE axpy :: Matrix Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-}
458 | axpy = \a _x _y -> runST $ do
459 |   _y <- U.thaw _y
460 |   _x <- U.thaw _x
461 |   axpy_ a _x _y
462 |   U.freeze _y
463 | 
464 | mulV :: (G.Vector v a, Num a, Unbox a) => Matrix Vector a -> v a -> v a
465 | {-# SPECIALIZE mulV :: Matrix Vector Double -> Vector Double -> Vector Double #-}
466 | {-# SPECIALIZE mulV :: Matrix Vector (Complex Double) -> Vector (Complex Double) -> Vector (Complex Double) #-}
467 | mulV = \a _x -> runST $ do
468 |   _x <- G.thaw _x
469 |   y <- GM.replicate (nrows a) 0
470 |   axpy_ a _x y
471 |   G.freeze y
472 | 
473 | mulM :: (Dense.Container VS.Vector a, Dense.Element a, Num a, Dense.Transposable (Dense.Matrix a) (Dense.Matrix a), Unbox a) => Matrix Vector a -> Dense.Matrix a -> Dense.Matrix a
474 | {-# SPECIALIZE mulM :: Matrix Vector Double -> Dense.Matrix Double -> Dense.Matrix Double #-}
475 | {-# SPECIALIZE mulM :: Matrix Vector (Complex Double) -> Dense.Matrix (Complex Double) -> Dense.Matrix (Complex Double) #-}
476 | mulM matA matB
477 |     | ncols matA /= Dense.rows matB = oops "inner dimension mismatch"
478 |     | otherwise = runST $ do
479 |         -- unpack matB column-wise into a mutable array
480 |         unpackedB <- (VS.thaw . Dense.flatten . Dense.tr') matB
481 |         resultC <- VSM.replicate (nrowsC * ncolsC) 0
482 |         let mulCols i
483 |                 | i >= ncolsC = pure ()
484 |                 | otherwise = do
485 |                     let inp = VSM.slice (i * nrowsB) nrowsB unpackedB
486 |                         outp = VSM.slice (i * nrowsC) nrowsC resultC
487 |                     axpy_ matA inp outp
488 |                     mulCols (i + 1)
489 |         mulCols 0
490 |         Dense.tr' . Dense.reshape nrowsC <$> VS.freeze resultC
491 |   where
492 |     oops str = errorWithStackTrace ("mulM: " ++ str)
493 |     nrowsA = nrows matA
494 |     nrowsB = Dense.rows matB
495 |     nrowsC = nrowsA
496 |     ncolsA = ncols matA
497 |     ncolsB = Dense.cols matB
498 |     ncolsC = ncolsB
499 | 
500 | hjoin :: Unbox a => Matrix Vector a -> Matrix Vector a -> Matrix Vector a
501 | {-# INLINE hjoin #-}
502 | hjoin a b = hcat [a, b]
503 | 
504 | hcat :: Unbox a => [Matrix Vector a] -> Matrix Vector a
505 | {-# SPECIALIZE hcat :: [Matrix Vector Double] -> Matrix Vector Double #-}
506 | {-# SPECIALIZE hcat :: [Matrix Vector (Complex Double)] -> Matrix Vector (Complex Double) #-}
507 | hcat mats
508 |   | null mats = oops "empty list"
509 |   | any (/= _nrows) (map nrows mats) = oops "nrows mismatch"
510 |   | otherwise =
511 |       Matrix
512 |       { ncols = F.foldl' (+) 0 $ map ncols mats
513 |       , nrows = _nrows
514 |       , pointers = U.scanl' (+) 0 $ U.concat $ map lengths mats
515 |       , indices = U.concat (indices <$> mats)
516 |       , values = U.concat (values <$> mats)
517 |       }
518 |   where
519 |     _nrows = nrows $ head mats
520 |     lengths m = let ptrs = pointers m in U.zipWith (-) (U.tail ptrs) ptrs
521 |     oops str = errorWithStackTrace ("hcat: " ++ str)
522 | 
523 | vjoin :: Unbox a => Matrix Vector a -> Matrix Vector a -> Matrix Vector a
524 | {-# INLINE vjoin #-}
525 | vjoin a b = vcat [a, b]
526 | 
527 | vcat :: Unbox a => [Matrix Vector a] -> Matrix Vector a
528 | {-# SPECIALIZE vcat :: [Matrix Vector Double] -> Matrix Vector Double #-}
529 | {-# SPECIALIZE vcat :: [Matrix Vector (Complex Double)] -> Matrix Vector (Complex Double) #-}
530 | vcat mats
531 |   | null mats = oops "empty list"
532 |   | any (/= _ncols) (map ncols mats) = oops "ncols mismatch"
533 |   | otherwise =
534 |       Matrix
535 |       { ncols = _ncols
536 |       , nrows = F.foldl' (+) 0 (map nrows mats)
537 |       , pointers = _pointers
538 |       , indices = _indices
539 |       , values = _values
540 |       }
541 |   where
542 |     oops str = errorWithStackTrace ("vcat: " ++ str)
543 |     _ncols = ncols (head mats)
544 |     _pointers = F.foldr1 (U.zipWith (+)) (map pointers mats)
545 |     (_indices, _values) = U.unzip $ U.create $ do
546 |       _entries <- UM.new (U.last _pointers)
547 |       let -- when concatenating matrices vertically, their row indices
548 |           -- must be offset according to their position in the final matrix
549 |           offsets = L.scanl' (+) 0 (map nrows mats)
550 |       U.forM_ (U.enumFromN 0 _ncols) $ \c -> do
551 |         let copyMatrix !ixD (Matrix {..}, off) = do
552 |               let copyWithOffset !ix (row, x) = do
553 |                     UM.unsafeWrite _entries ix (row + off, x)
554 |                     return (ix + 1)
555 |               U.foldM' copyWithOffset ixD (basicUnsafeSlice pointers (U.zip indices values) c)
556 |         F.foldlM copyMatrix (_pointers U.! c) (zip mats offsets)
557 |       return _entries
558 | 
559 | fromBlocks :: (Num a, Unbox a) => [[Maybe (Matrix Vector a)]] -> Matrix Vector a
560 | {-# SPECIALIZE fromBlocks :: [[Maybe (Matrix Vector Double)]] -> Matrix Vector Double #-}
561 | {-# SPECIALIZE fromBlocks :: [[Maybe (Matrix Vector (Complex Double))]] -> Matrix Vector (Complex Double) #-}
562 | fromBlocks = vcat . map hcat . adjustDims
563 |   where
564 |     adjustDims rows = do
565 |       (r, row) <- zip [0..] rows
566 |       return $ do
567 |         (c, mat) <- zip [0..] row
568 |         return $ case mat of
569 |           Nothing -> zeros (heights U.! r) (widths U.! c)
570 |           Just x -> x
571 |       where
572 |         cols = L.transpose rows
573 |         incompatible = any (\xs -> let x = head xs in any (/= x) xs)
574 |         underspecified = any null
575 |         heightSpecs = map (map nrows . catMaybes) rows
576 |         widthSpecs = map (map ncols . catMaybes) cols
577 |         oops str = errorWithStackTrace ("fromBlocks: " ++ str)
578 |         heights
579 |           | underspecified heightSpecs = oops "underspecified heights"
580 |           | incompatible heightSpecs = oops "incompatible heights"
581 |           | otherwise = U.fromList $ map head heightSpecs
582 |         widths
583 |           | underspecified widthSpecs = oops "underspecified widths"
584 |           | incompatible widthSpecs = oops "incompatible widths"
585 |           | otherwise = U.fromList $ map head widthSpecs
586 | 
587 | fromBlocksDiag
588 |   :: (Num a, Unbox a) => [[Maybe (Matrix Vector a)]] -> Matrix Vector a
589 | {-# INLINE fromBlocksDiag #-}
590 | fromBlocksDiag blocks =
591 |     (fromBlocks . zipWith rejoin [0..] . map pad . L.transpose) blocks
592 |   where
593 |     len = length blocks
594 |     pad as = as ++ replicate (len - length as) Nothing
595 |     rejoin = \n as -> let (rs, ls) = splitAt (length as - n) as in ls ++ rs
596 | 
597 | kronecker :: (Num a, Unbox a) => Matrix Vector a -> Matrix Vector a -> Matrix Vector a
598 | {-# SPECIALIZE kronecker :: Matrix Vector Double -> Matrix Vector Double -> Matrix Vector Double #-}
599 | {-# SPECIALIZE kronecker :: Matrix Vector (Complex Double) -> Matrix Vector (Complex Double) -> Matrix Vector (Complex Double) #-}
600 | kronecker matA matB =
601 |   let _nrows = nrows matA * nrows matB
602 |       _ncols = ncols matA * ncols matB
603 | 
604 |       ptrsA = pointers matA
605 |       ptrsB = pointers matB
606 |       lengthsA = U.zipWith (-) (U.tail ptrsA) ptrsA
607 |       lengthsB = U.zipWith (-) (U.tail ptrsB) ptrsB
608 |       ptrs = U.scanl' (+) 0
609 |              $ U.concatMap (\nzA -> U.map (* nzA) lengthsB) lengthsA
610 | 
611 |       indicesA = indices matA
612 |       indicesB = indices matB
613 |       valuesA = values matA
614 |       valuesB = values matB
615 | 
616 |       nbs = U.enumFromStepN 0 1 $ ncols matB
617 |       nas = U.enumFromStepN 0 1 $ ncols matA
618 |       ns = U.concatMap (\na -> U.map ((,) na) nbs) nas
619 | 
620 |       kronecker_ixs (!na, !nb) =
621 |         let as = basicUnsafeSlice ptrsA indicesA na
622 |             bs = basicUnsafeSlice ptrsB indicesB nb
623 |         in U.concatMap (\n -> U.map (+ n) bs) (U.map (* (nrows matB)) as)
624 |       ixs = U.concatMap kronecker_ixs ns
625 | 
626 |       kronecker_xs (!na, !nb) =
627 |         let as = basicUnsafeSlice ptrsA valuesA na
628 |             bs = basicUnsafeSlice ptrsB valuesB nb
629 |         in U.concatMap (\a -> U.map (* a) bs) as
630 |       xs = U.concatMap kronecker_xs ns
631 | 
632 |   in Matrix
633 |     { ncols = _ncols
634 |     , nrows = _nrows
635 |     , pointers = ptrs
636 |     , indices = ixs
637 |     , values = xs
638 |     }
639 | 
640 | takeDiag :: (Num a, Unbox a) => Matrix Vector a -> Vector a
641 | {-# INLINE takeDiag #-}
642 | takeDiag mat@Matrix {..}
643 |   = U.generate (min nrows ncols) takeDiagFromColumn
644 |   where
645 |     takeDiagFromColumn c
646 |       = case U.elemIndex c (S.indices column) of
647 |           Nothing -> 0
648 |           Just ix -> S.values column U.! ix
649 |       where
650 |         column = slice mat c
651 | 
652 | diag :: Unbox a => Vector a -> Matrix Vector a
653 | {-# INLINE diag #-}
654 | diag values = Matrix {..}
655 |   where
656 |     ncols = U.length values
657 |     nrows = ncols
658 |     pointers = U.iterateN (ncols + 1) (+1) 0
659 |     indices = U.iterateN ncols (+1) 0
660 | 
661 | blockDiag :: (Num a, Unbox a) => [Matrix Vector a] -> Matrix Vector a
662 | {-# INLINE blockDiag #-}
663 | blockDiag mats
664 |   = fromBlocksDiag ((Just <$> mats) : offDiagonal)
665 |   where
666 |     len = length mats
667 |     offDiagonal = replicate (len - 1) (replicate len Nothing)
668 | 
669 | ident :: (Num a, Unbox a) => Int -> Matrix Vector a
670 | {-# INLINE ident #-}
671 | ident n = diag $ U.replicate n 1
672 | 
673 | zeros :: Unbox a => Int -> Int -> Matrix Vector a
674 | {-# INLINE zeros #-}
675 | zeros nrows ncols = Matrix {..}
676 |   where
677 |     pointers = U.replicate (ncols + 1) 0
678 |     indices = U.empty
679 |     values = U.empty
680 | 
681 | pack :: (Dense.Container Dense.Vector a, Num a, Storable a, Unbox a)
682 |      => Matrix Vector a -> Dense.Matrix a
683 | {-# INLINE pack #-}
684 | pack Matrix {..} =
685 |   Dense.assoc (nrows, ncols) 0 $ do
686 |     c <- [0..(ncols - 1)]
687 |     let ixs = basicUnsafeSlice pointers indices c
688 |         xs = basicUnsafeSlice pointers values c
689 |     U.toList (U.zip (U.map (flip (,) c) ixs) xs)
690 | 
691 | mm :: (Num a, Unbox a) => Matrix Vector a -> Matrix Vector a -> Matrix Vector a
692 | {-# INLINE mm #-}
693 | mm matA matB
694 |   | ncols matA /= nrows matB = oops "inner dimension mismatch"
695 |   | otherwise = unsafeFromColumns $ SG.run (nrows matA) $ do
696 |       Boxed.forM (toColumns matB) $ \colB -> do
697 |         SG.reset 0
698 |         S.iforM_ colB $ \rB b ->
699 |           SG.scatter (slice matA rB) (\c a -> c + a * b)
700 |         SG.gather
701 |   where
702 |     oops msg = error ("mm: " ++ msg)
703 | 
704 | subMatrix :: Unbox a =>
705 |              (Int, Int) -> (Int, Int)
706 |           -> Matrix Vector a -> Matrix Vector a
707 | subMatrix (r0, c0) (nr, nc) mat
708 |     | r0 + nr > nrows mat = oops "range exceeds input row size"
709 |     | c0 + nc > ncols mat = oops "range exceeds input column size"
710 |     | otherwise =
711 |         let
712 |             rf = r0 + nr
713 |             ix0 = pointers mat U.! c0
714 |             nix = pointers mat U.! (c0 + nc)
715 |             (_indices, _values) =
716 |                 ( U.unzip
717 |                 . U.filter (\(r, _) -> r >= r0 && r < rf)
718 |                 . U.slice ix0 nix )
719 |                 (U.zip (indices mat) (values mat))
720 |             _pointers = computePtrs nc _indices
721 |         in
722 |           Matrix { nrows = nr
723 |                  , ncols = nc
724 |                  , pointers = _pointers
725 |                  , indices = _indices
726 |                  , values = _values
727 |                  }
728 |   where
729 |     oops msg = error ("subMatrix: " ++ msg)
730 | 


--------------------------------------------------------------------------------