├── .gitignore
├── INSTALL
├── LICENSE
├── README.md
├── Setup.lhs
├── hTensor.cabal
└── lib
    └── Numeric
        └── LinearAlgebra
            ├── Array.hs
            ├── Array
                ├── Decomposition.hs
                ├── Display.hs
                ├── Internal.hs
                ├── Simple.hs
                ├── Solve.hs
                └── Util.hs
            ├── Exterior.hs
            ├── Multivector.hs
            └── Tensor.hs


/.gitignore:
--------------------------------------------------------------------------------
 1 | _darcs
 2 | dist
 3 | cabal-dev
 4 | *.o
 5 | *.hi
 6 | *.chi
 7 | *.chs.h
 8 | 
 9 | examples
10 | push.sh
11 | hTensor.html
12 | 
13 | 


--------------------------------------------------------------------------------
/INSTALL:
--------------------------------------------------------------------------------
1 | INSTALLATION
2 | 
3 | $ cabal install hTensor
4 | 


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


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | hTensor
 2 | =======
 3 | 
 4 | A Haskell package for multidimensional arrays, simple tensor computations and multilinear algebra.
 5 | 
 6 | Array dimensions have an "identity" which is preserved in data manipulation. Indices are explicitly selected by name in expressions, and Einstein's summation convention for repeated indices is automatically applied.
 7 | 
 8 | The library has a purely functional interface: arrays are immutable, and operations work on whole structures which can be assembled and decomposed using simple primitives. Arguments are automatically made conformable by replicating them along extra dimensions appearing in an operation.
 9 | 
10 | There is preliminary support for geometric algebra, multidimensional linear systems of equations, and tensor decompositions.
11 | 
12 | - [Source code and documentation][source]
13 | 
14 | - [Tutorial][tutorial]
15 | 
16 | - Application to Multiview Geometry:
17 | 
18 |   - part 1: [tensor diagrams][ap1]
19 |   - part 2: (in construction)
20 |   
21 | 
22 | Installation
23 | ------------
24 | 
25 |         $ sudo apt-get install haskell-platform libgsl0-dev liblapack-dev
26 |         $ cabal update
27 |         $ cabal install hTensor
28 | 
29 | Test
30 | ----
31 | 
32 |         $ ghci
33 |         > import Numeric.LinearAlgebra.Exterior
34 |         > printA "%4.0f" $ leviCivita 4 !"pqrs" * cov (leviCivita 4)!"qrsu"
35 | 
36 |         p^4 x u_4
37 |                     u
38 |             -6    0    0    0
39 |         p    0   -6    0    0
40 |              0    0   -6    0
41 |              0    0    0   -6
42 | 
43 | 
44 | 
45 | 
46 | [source]: http://hackage.haskell.org/package/hTensor
47 | [tutorial]: http://dis.um.es/profesores/alberto/material/hTensor.pdf
48 | [ap1]: http://dis.um.es/profesores/alberto/material/htmvg1.pdf
49 | 
50 | 


--------------------------------------------------------------------------------
/Setup.lhs:
--------------------------------------------------------------------------------
1 | #! /usr/bin/env runhaskell
2 | 
3 | > import Distribution.Simple
4 | > main = defaultMain
5 | 


--------------------------------------------------------------------------------
/hTensor.cabal:
--------------------------------------------------------------------------------
 1 | Name:               hTensor
 2 | Version:            0.9.1
 3 | License:            BSD3
 4 | License-file:       LICENSE
 5 | Author:             Alberto Ruiz
 6 | Maintainer:         Alberto Ruiz <aruiz@um.es>
 7 | Stability:          experimental
 8 | Homepage:           http://perception.inf.um.es/tensor
 9 | Synopsis:           Multidimensional arrays and simple tensor computations.
10 | Description:
11 |  This is an experimental library for multidimensional arrays,
12 |  oriented to support simple tensor computations and multilinear
13 |  algebra.
14 |  .
15 |  Array dimensions have an \"identity\" which is preserved
16 |  in data manipulation. Indices are explicitly selected by name in
17 |  expressions, and Einstein's summation convention for repeated indices
18 |  is automatically applied.
19 |  .
20 |  The library has a purely functional interface: arrays are immutable,
21 |  and operations typically work on whole structures which can be assembled
22 |  and decomposed using simple primitives. Arguments are automatically made conformant
23 |  by replicating them along extra dimensions appearing in an operation.
24 |  There is preliminary support for Geometric Algebra and for solving multilinear systems.
25 |  .
26 |  A tutorial can be found in the website of the project.
27 | 
28 | Category:           Math
29 | tested-with:        GHC ==7.4
30 | 
31 | cabal-version:      >=1.6
32 | build-type:         Simple
33 | 
34 | extra-source-files:
35 | 
36 | library
37 | 
38 |     Build-Depends:      base<5, hmatrix>=0.18, containers, random
39 | 
40 |     hs-source-dirs:     lib
41 |     Exposed-modules:    Numeric.LinearAlgebra.Array.Util
42 |                         Numeric.LinearAlgebra.Array
43 |                         Numeric.LinearAlgebra.Tensor
44 |                         Numeric.LinearAlgebra.Exterior
45 |                         Numeric.LinearAlgebra.Multivector
46 |                         Numeric.LinearAlgebra.Array.Solve
47 |                         Numeric.LinearAlgebra.Array.Decomposition
48 | 
49 |     other-modules:      Numeric.LinearAlgebra.Array.Internal
50 |                         Numeric.LinearAlgebra.Array.Display
51 |                         Numeric.LinearAlgebra.Array.Simple
52 | 
53 |     ghc-prof-options:   -auto-all
54 | 
55 |     ghc-options:        -Wall
56 |                         -fno-warn-missing-signatures
57 |                         -fno-warn-orphans
58 | 
59 | source-repository head
60 |     type:     git
61 |     location: https://github.com/AlbertoRuiz/hTensor
62 | 
63 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE UndecidableInstances #-}
 2 | -----------------------------------------------------------------------------
 3 | -- |
 4 | -- Module      :  Numeric.LinearAlgebra.Array
 5 | -- Copyright   :  (c) Alberto Ruiz 2009
 6 | -- License     :  BSD3
 7 | -- Maintainer  :  Alberto Ruiz
 8 | -- Stability   :  provisional
 9 | --
10 | -- Simple multidimensional array with useful numeric instances.
11 | --
12 | -- Contractions only require equal dimension.
13 | --
14 | -----------------------------------------------------------------------------
15 | 
16 | module Numeric.LinearAlgebra.Array (
17 |     None(..),
18 |     Array,
19 |     listArray,
20 |     scalar,
21 |     index,
22 |     (!),(!>),(~>),
23 |     (.*),
24 |     printA
25 | ) where
26 | 
27 | import Numeric.LinearAlgebra.Array.Simple
28 | import Numeric.LinearAlgebra.Array.Util
29 | import Numeric.LinearAlgebra.Array.Internal(namesR)
30 | import Numeric.LinearAlgebra.Array.Display(printA)
31 | import Numeric.LinearAlgebra.HMatrix(Vector)
32 | 
33 | -- | Create an 'Array' from a list of parts (@index = 'newIndex' 'None'@).
34 | index :: Coord t => Name -> [Array t] -> Array t
35 | index = newIndex None
36 | 
37 | 
38 | -- | Element by element product.
39 | infixl 7 .*
40 | (.*) :: (Coord a, Compat i) => NArray i a -> NArray i a -> NArray i a
41 | (.*) = zipArray (*)
42 | 
43 | instance (Eq t, Coord t, Compat i) => Eq (NArray i t) where
44 |     t1 == t2 = sameStructure t1 t2 && coords t1 == coords (reorder (namesR t1) t2)
45 | 
46 | instance (Show (NArray i t), Coord t, Compat i) => Num (NArray i t) where
47 |     (+) = zipArray (+)
48 |     (*) = (|*|)
49 |     negate t = scalar (-1) * t
50 |     fromInteger n = scalar (fromInteger n)
51 |     abs _ = error "abs for arrays not defined"
52 |     signum _ = error "signum for arrays not defined"
53 | 
54 | instance (Fractional t, Coord t, Compat i, Num (NArray i t)) => Fractional (NArray i t) where
55 |     fromRational = scalar . fromRational
56 |     (/) = zipArray (/)
57 |     recip = mapArray recip
58 | 
59 | instance (Coord t, Compat i, Fractional (NArray i t), Floating t, Floating (Vector t)) => Floating (NArray i t) where
60 |     sin   = mapArray sin
61 |     cos   = mapArray cos
62 |     tan   = mapArray tan
63 |     asin  = mapArray asin
64 |     acos  = mapArray acos
65 |     atan  = mapArray atan
66 |     sinh  = mapArray sinh
67 |     cosh  = mapArray cosh
68 |     tanh  = mapArray tanh
69 |     asinh = mapArray asinh
70 |     acosh = mapArray acosh
71 |     atanh = mapArray atanh
72 |     exp   = mapArray exp
73 |     log   = mapArray log
74 |     (**)  = zipArray (**)
75 |     sqrt  = mapArray sqrt
76 |     pi    = scalar pi
77 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Decomposition.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | -----------------------------------------------------------------------------
  3 | -- |
  4 | -- Module      :  Data.Packed.Array.Decomposition
  5 | -- Copyright   :  (c) Alberto Ruiz 2009
  6 | -- License     :  BSD3
  7 | -- Maintainer  :  Alberto Ruiz
  8 | -- Stability   :  experimental
  9 | --
 10 | -- Common multidimensional array decompositions. See the paper by Kolda & Balder.
 11 | --
 12 | -----------------------------------------------------------------------------
 13 | 
 14 | module Numeric.LinearAlgebra.Array.Decomposition (
 15 |     -- * HOSVD
 16 |     hosvd, hosvd', truncateFactors,
 17 |     -- * CP
 18 |     cpAuto, cpRun, cpInitRandom, cpInitSvd,
 19 |     -- * Utilities
 20 |     ALSParam(..), defaultParameters
 21 | ) where
 22 | 
 23 | import Numeric.LinearAlgebra.Array
 24 | import Numeric.LinearAlgebra.Array.Internal(seqIdx,namesR,sizesR,renameRaw)
 25 | import Numeric.LinearAlgebra.Array.Util
 26 | import Numeric.LinearAlgebra.Array.Solve
 27 | import Numeric.LinearAlgebra.HMatrix hiding (scalar)
 28 | import Data.List
 29 | import System.Random
 30 | --import Control.Parallel.Strategies
 31 | 
 32 | {- | Full version of 'hosvd'.
 33 | 
 34 |     The first element in the result pair is a list with the core (head) and rotations so that
 35 |     t == product (fst (hsvd' t)).
 36 | 
 37 |     The second element is a list of rank and singular values along each mode,
 38 |     to give some idea about core structure.
 39 | -}
 40 | hosvd' :: Array Double -> ([Array Double],[(Int,Vector Double)])
 41 | hosvd' t = (factors,ss) where
 42 |     (rs,ss) = unzip $ map usOfSVD $ flats t
 43 |     n = length rs
 44 |     dummies = take n $ seqIdx (2*n) "" \\ (namesR t)
 45 |     axs = zipWith (\a b->[a,b]) dummies (namesR t)
 46 |     factors = renameRaw core dummies : zipWith renameRaw (map (fromMatrix None None . tr) rs) axs
 47 |     core = product $ renameRaw t dummies : zipWith renameRaw (map (fromMatrix None None) rs) axs
 48 | 
 49 | {- | Multilinear Singular Value Decomposition (or Tucker's method, see Lathauwer et al.).
 50 | 
 51 |     The result is a list with the core (head) and rotations so that
 52 |     t == product (hsvd t).
 53 | 
 54 |     The core and the rotations are truncated to the rank of each mode.
 55 | 
 56 |     Use 'hosvd'' to get full transformations and rank information about each mode.
 57 | 
 58 | -}
 59 | hosvd :: Array Double -> [Array Double]
 60 | hosvd a = truncateFactors rs h where
 61 |     (h,info) = hosvd' a
 62 |     rs = map fst info
 63 | 
 64 | 
 65 | -- get the matrices of the flattened tensor for all dimensions
 66 | flats t = map (flip fibers t) (namesR t)
 67 | 
 68 | 
 69 | --check trans/ctrans
 70 | usOfSVD m = if rows m < cols m
 71 |         then let (s2,u) = eigSH' $ m <> tr m
 72 |                  s = sqrt (abs s2)
 73 |               in (u,r s)
 74 |         else let (s2,v) = eigSH' $ tr m <> m
 75 |                  s = sqrt (abs s2)
 76 |                  u = m <> v <> pinv (diag s)
 77 |               in (u,r s)
 78 |     where r s = (ranksv (sqrt peps) (max (rows m) (cols m)) (toList s), s)
 79 |                 -- (rank m, sv m) where sv m = s where (_,s,_) = svd m
 80 | 
 81 | 
 82 | ttake ns t = (foldl1' (.) $ zipWith (onIndex.take) ns (namesR t)) t
 83 | 
 84 | -- | Truncate a 'hosvd' decomposition from the desired number of principal components in each dimension.
 85 | truncateFactors :: [Int] -> [Array Double] -> [Array Double]
 86 | truncateFactors _ [] = []
 87 | truncateFactors ns (c:rs) = ttake ns c : zipWith f rs ns
 88 |     where f r n = onIndex (take n) (head (namesR r)) r
 89 | 
 90 | ------------------------------------------------------------------------
 91 | 
 92 | frobT = norm_2 . coords
 93 | 
 94 | ------------------------------------------------------------------------
 95 | 
 96 | unitRows [] = error "unitRows []"
 97 | unitRows (c:as) = foldl1' (.*) (c:xs) : as' where
 98 |     (xs,as') = unzip (map g as)
 99 |     g a = (x,a')
100 |         where n = head (namesR a) -- hmmm
101 |               rs = parts a n
102 |               scs = map frobT rs
103 |               x = diagT scs (order c) `renameRaw` (namesR c)
104 |               a' = (zipWith (.*) (map (scalar.recip) scs)) `onIndex` n $ a
105 | 
106 | 
107 | {- | Basic CP optimization for a given rank. The result includes the obtained sequence of errors.
108 | 
109 | For example, a rank 3 approximation can be obtained as follows, where initialization
110 | is based on the hosvd:
111 | 
112 | @
113 | (y,errs) = cpRank 3 t
114 |      where cpRank r t = cpRun (cpInitSvd (fst $ hosvd' t) r) defaultParameters t
115 | @
116 | 
117 | -}
118 | cpRun :: [Array Double] -- ^ starting point
119 |       -> ALSParam None Double     -- ^ optimization parameters
120 |       -> Array Double -- ^ input array
121 |       -> ([Array Double], [Double]) -- ^ factors and error history
122 | cpRun s0 params t = (unitRows $ head s0 : sol, errs) where
123 |     (sol,errs) = mlSolve params [head s0] (tail s0) t
124 | 
125 | 
126 | 
127 | {- | Experimental implementation of the CP decomposition, based on alternating
128 |      least squares. We try approximations of increasing rank, until the relative reconstruction error is below a desired percent of Frobenius norm (epsilon).
129 | 
130 |      The approximation of rank k is abandoned if the error does not decrease at least delta% in an iteration.
131 | 
132 |     Practical usage can be based on something like this:
133 | 
134 | @
135 | cp finit d e t = cpAuto (finit t) defaultParameters {delta = d, epsilon = e} t
136 | 
137 | cpS = cp (InitSvd . fst . hosvd')
138 | cpR s = cp (cpInitRandom s)
139 | @
140 | 
141 |      So we can write
142 | 
143 | @
144 |  \-\- initialization based on hosvd
145 | y = cpS 0.01 1E-6 t
146 | 
147 |  \-\- (pseudo)random initialization
148 | z = cpR seed 0.1 0.1 t
149 | @
150 | 
151 | -}
152 | cpAuto :: (Int -> [Array Double]) -- ^ Initialization function for each rank
153 |        -> ALSParam None Double    -- ^ optimization parameters
154 |        -> Array Double -- ^ input array
155 |        -> [Array Double] -- ^ factors
156 | cpAuto finit params t = fst . head . filter ((<epsilon params). head . snd)
157 |                       . map (\r->cpRun (finit r) params t) $ [1 ..]
158 | 
159 | ----------------------
160 | 
161 | -- | cp initialization based on the hosvd
162 | cpInitSvd :: [NArray None Double] -- ^ hosvd decomposition of the target array
163 |           -> Int                  -- ^ rank
164 |           -> [NArray None Double] -- ^ starting point
165 | cpInitSvd (hos) k = d:as
166 |     where c:rs = hos
167 |           as = trunc (replicate (order c) k) rs
168 |           d = diagT (replicate k 1) (order c) `renameO` (namesR c)
169 |           trunc ns xs = zipWith f xs ns
170 |               where f r n = onIndex (take n . cycle) (head (namesR r)) r
171 | 
172 | cpInitSeq rs t k = ones:as where
173 |     n = order t
174 |     auxIndx = take n $ seqIdx (2*n) "" \\ namesR t
175 |               --take (order t) $ map return ['a'..] \\ namesR t
176 |     ones = diagT (replicate k 1) (order t) `renameO` auxIndx
177 |     ts = takes (map (*k) (sizesR t)) rs
178 |     as = zipWith4 f ts auxIndx (namesR t) (sizesR t)
179 |     f c n1 n2 p = (listArray [k,p] c) `renameO` [n1,n2]
180 | 
181 | takes [] _ = []
182 | takes (n:ns) xs = take n xs : takes ns (drop n xs)
183 | 
184 | -- | pseudorandom cp initialization from a given seed
185 | cpInitRandom :: Int        -- ^ seed
186 |              -> NArray i t -- ^ target array to decompose
187 |              -> Int        -- ^ rank
188 |              -> [NArray None Double] -- ^ random starting point
189 | cpInitRandom seed = cpInitSeq (randomRs (-1,1) (mkStdGen seed))
190 | 
191 | ----------------------------------------------------------------------
192 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Display.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | 
  3 | -----------------------------------------------------------------------------
  4 | -- |
  5 | -- Module      :  Data.Packed.Array.Display
  6 | -- Copyright   :  (c) Alberto Ruiz 2009
  7 | -- License     :  BSD3
  8 | -- Maintainer  :  Alberto Ruiz
  9 | -- Stability   :  provisional
 10 | --
 11 | -- Formatting utilities
 12 | 
 13 | -----------------------------------------------------------------------------
 14 | 
 15 | module Numeric.LinearAlgebra.Array.Display (
 16 |     formatArray, formatFixed, formatScaled, printA, dummyAt, noIdx, showBases,
 17 | ) where
 18 | 
 19 | import Numeric.LinearAlgebra.Array.Internal
 20 | import Numeric.LinearAlgebra.HMatrix
 21 | import Data.List
 22 | import Text.Printf
 23 | 
 24 | showBases x = f $ concatMap (shbld) x
 25 |     where   shbld (c,[]) = shsign c ++ showc c
 26 |             shbld (c,l) = shsign c ++ g (showc c) ++ "{"++ concatMap show l++"}"
 27 |             shsign c = if c < 0 then " - " else " + "
 28 |             showc c
 29 |                 | abs (fromIntegral (round c :: Int) - c) <1E-10  = show (round $ abs c::Int)
 30 |                 | otherwise = printf "%.3f" (abs c)
 31 |             f (' ':'+':' ':rs) = rs
 32 |             f (' ':'-':' ':rs) = '-':rs
 33 |             f a = a
 34 |             g "1" = ""
 35 |             g a = a
 36 | 
 37 | ---------------------------------------------------------
 38 | 
 39 | data Rect = Rect { li :: Int, co :: Int, els :: [String] }
 40 | 
 41 | rect s = pad r c (Rect r 0 ss)
 42 |     where ss = lines s
 43 |           r  = length ss
 44 |           c  = maximum (map length ss)
 45 | 
 46 | pad nr nc (Rect r c ss) = Rect (r+r') (c+c') ss'' where
 47 |     r' = max 0 (nr-r)
 48 |     c' = max 0 (nc-c)
 49 |     ss' = map (padH nc) ss
 50 |     ss'' = replicate r' (replicate nc '-') ++ ss'
 51 |     padH l s = take (l-length s) (" | "++repeat ' ') ++ s
 52 | 
 53 | dispH :: Int -> [Rect] -> Rect
 54 | dispH k rs = Rect nr nc nss where
 55 |     nr = maximum (map li rs)
 56 |     nss' = mapTail (\x-> pad nr (co x + k) x) rs
 57 |     nss = foldl1' (zipWith (++)) (map els nss')
 58 |     nc = length (head nss)
 59 | 
 60 | dispV :: Int -> [Rect] -> Rect
 61 | dispV k rs = Rect nr nc nss where
 62 |     nc = maximum (map co rs)
 63 |     nss' = mapTail (\x-> pad (li x + k) nc x) rs
 64 |     nss = concatMap els nss'
 65 |     nr = length nss
 66 | 
 67 | mapTail f (a:b) = a : map f b
 68 | mapTail _ x     = x
 69 | 
 70 | 
 71 | formatAux f x = unlines . addds . els . fmt ms $ x where
 72 |     fmt [] _ = undefined -- cannot happen
 73 |     fmt (g:gs) t
 74 |         | order t == 0 = rect (f (coords t ! 0))
 75 |         | order t == 1 =  rect $ unwords $ map f (toList $ coords t)
 76 |         | order t == 2 =  decor t $ rect $ w1 $ format " " f (reshape (iDim $ last $ dims t) (coords t))
 77 |         | otherwise    = decor t (g ps)
 78 |       where ps = map (fmt gs ) (partsRaw t (head (namesR t)))
 79 |     ds = showNice (filter ((/='*').head.iName) $ dims x)
 80 |     addds = if null ds then (showRawDims (dims x) :) else (ds:)
 81 |     w1 = unlines . map (' ':) . lines
 82 |     ms = cycle [dispV 1, dispH 2]
 83 |     decor t | odd (order t) = id
 84 |             | otherwise = decorLeft  (namesR t!!0) . decorUp (namesR t!!1)
 85 | 
 86 | 
 87 | showNice x = unwords . intersperse "x" . map show $ x
 88 | showRawDims = showNice . map iDim . filter ((/="*").iName)
 89 | 
 90 | ------------------------------------------------------
 91 | 
 92 | -- | Show a multidimensional array as a nested 2D table.
 93 | formatArray :: (Coord t, Compat i)
 94 |       => (t -> String) -- ^ format function (eg. printf \"5.2f\")
 95 |       -> NArray i t
 96 |       -> String
 97 | formatArray f t | odd (order t) = formatAux f (dummyAt 0 t)
 98 |             | otherwise    = formatAux f t
 99 | 
100 | 
101 | decorUp s rec
102 |     | head s == '*' = rec
103 |     | otherwise     = dispV 0 [rs,rec]
104 |   where
105 |     c = co rec
106 |     c1 = (c - length s) `div` 2
107 |     c2 = c - length s - c1
108 |     rs = rect $ replicate c1 ' ' ++ s ++ replicate c2 ' '
109 | 
110 | decorLeft s rec
111 |     | head s == '*' = rec
112 |     | otherwise     = dispH 0 [rs,rec]
113 |   where
114 |     c = li rec
115 |     r1 = (c - length s+1) `div` 2
116 |     r2 = c - length s - r1
117 |     rs = rect $ unlines $ replicate r1 spc ++ s : replicate (r2) spc
118 |     spc = replicate (length s) ' '
119 | 
120 | ------------------------------------------------------
121 | 
122 | -- | Print the array as a nested table with the desired format (e.g. %7.2f) (see also 'formatArray', and 'formatScaled').
123 | printA :: (Coord t, Compat i, PrintfArg t) => String -> NArray i t -> IO ()
124 | printA f t = putStrLn (formatArray (printf f) t)
125 | 
126 | 
127 | -- | Show the array as a nested table with autoscaled entries.
128 | formatScaled :: (Compat i)
129 |       => Int -- ^ number of of decimal places
130 |       -> NArray i Double
131 |       -> String
132 | formatScaled dec t = unlines (('(':d++")  E"++show o) : m)
133 |     where ss = formatArray (printf fmt. g) t
134 |           d:m = lines ss
135 |           g x | o >= 0    = x/10^(o::Int)
136 |               | otherwise = x*10^(-o)
137 |           o = floor $ maximum $ map (logBase 10 . abs) $ toList $ coords t
138 |           fmt = '%':show (dec+3) ++ '.':show dec ++"f"
139 | 
140 | -- | Show the array as a nested table with a \"\%.nf\" format. If all entries
141 | -- are approximate integers the array is shown without the .00.. digits.
142 | formatFixed :: (Compat i)
143 |       => Int -- ^ number of of decimal places
144 |       -> NArray i Double
145 |       -> String
146 | formatFixed dec t
147 |     | isInt t   = formatArray (printf ('%': show (width t) ++".0f")) t
148 |     | otherwise = formatArray (printf ('%': show (width t+dec+1) ++"."++show dec ++"f")) t
149 | 
150 | isInt = all lookslikeInt . toList . coords
151 | lookslikeInt x = show (round x :: Int) ++".0" == shx || "-0.0" == shx
152 |     where shx = show x
153 | -- needsSign t = vectorMin (coords t) < 0
154 | -- width :: Compat i => NArray i Double -> Int
155 | width = maximum . map (length . (printf "%.0f"::Double->String)) . toList . coords
156 | -- width t = k + floor (logBase 10 (max 1 $ vectorMax (abs $ coords t))) :: Int
157 | --      where k | needsSign t = 2
158 | --              | otherwise = 1
159 | 
160 | ------------------------------------------------------
161 | 
162 | -- | Insert a dummy index of dimension 1 at a given level (for formatting purposes).
163 | dummyAt :: Coord t => Int -> NArray i t -> NArray i t
164 | dummyAt k t = mkNArray d' (coords t) where
165 |     (d1,d2) = splitAt k (dims t)
166 |     d' = d1 ++ d : d2
167 |     d = Idx (iType (head (dims t))) 1 "*"
168 | 
169 | -- | Rename indices so that they are not shown in formatted output.
170 | noIdx :: Compat i => NArray i t -> NArray i t
171 | noIdx t = renameSuperRaw t (map ('*':) (namesR t))
172 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Internal.hs:
--------------------------------------------------------------------------------
  1 | {-# OPTIONS_HADDOCK hide #-}
  2 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables #-}
  3 | -----------------------------------------------------------------------------
  4 | -- |
  5 | -- Module      :  Data.Packed.Array.Internal
  6 | -- Copyright   :  (c) Alberto Ruiz 2009
  7 | -- License     :  BSD3
  8 | -- Maintainer  :  Alberto Ruiz
  9 | -- Stability   :  provisional
 10 | --
 11 | -- Multidimensional arrays.
 12 | --
 13 | -- The arrays provided by this library are immutable, built on top of hmatrix
 14 | -- structures.
 15 | -- Operations work on complete structures (indexless), and dimensions have \"names\", 
 16 | -- in order to select the desired contractions in tensor computations.
 17 | --
 18 | -- This module contains auxiliary functions not required by the end user.
 19 | 
 20 | -----------------------------------------------------------------------------
 21 | 
 22 | module Numeric.LinearAlgebra.Array.Internal (
 23 |     -- * Data structures
 24 |     NArray, Idx(..), Name,
 25 |     order, namesR, names, size, sizesR, sizes, typeOf , dims, coords,
 26 |     Compat(..),
 27 |     -- * Array creation
 28 |     scalar,
 29 |     mkNArray,
 30 |     fromVector, fromMatrix, reshapeVector,
 31 |     -- * Array manipulation
 32 |     renameRaw,
 33 |     parts, partsRaw,
 34 |     (|*|),
 35 |     analyzeProduct,
 36 |     smartProduct,
 37 |     zipArray,
 38 |     mapArray,
 39 |     extract,
 40 |     onIndex,
 41 |     -- * Utilities
 42 |     seqIdx,
 43 |     reorder,
 44 |     sameStructure,
 45 |     conformable,
 46 |     makeConformant,
 47 |     mapTypes, mapNames,
 48 |     renameSuperRaw, renameExplicit,
 49 |     newIndex,
 50 |     basisOf,
 51 |     common,
 52 |     selDims, mapDims,
 53 |     takeDiagT, atT,
 54 |     firstIdx, fibers, matrixator, matrixatorFree,
 55 |     Coord,I,
 56 |     asMatrix, asVector, asScalar,
 57 |     resetCoords,
 58 |     debug
 59 | ) where
 60 | 
 61 | import qualified Numeric.LinearAlgebra.Devel as LA
 62 | import qualified Numeric.LinearAlgebra as LA
 63 | import Numeric.LinearAlgebra hiding (size,scalar,ident)
 64 | import Data.List
 65 | import Data.Function(on)
 66 | import Data.Maybe
 67 | import Debug.Trace
 68 | 
 69 | import Data.Set (Set)
 70 | import qualified Data.Set as Set
 71 | 
 72 | import Data.Map.Strict (Map)
 73 | import qualified Data.Map.Strict as Map
 74 | 
 75 | dim x = LA.size x
 76 | trans x = LA.tr' x
 77 | 
 78 | ident n = diagRect 0 (konst 1 n) n n
 79 | 
 80 | debug m f x = trace (m ++ show (f x)) x
 81 | 
 82 | -- | Types that can be elements of the multidimensional arrays.
 83 | class (Num (Vector t), Normed (Vector t), Show t, Numeric t, Indexable (Vector t) t) => Coord t
 84 | instance Coord Double
 85 | instance Coord (Complex Double)
 86 | instance Coord I
 87 | 
 88 | -- | indices are denoted by strings, (frequently single-letter)
 89 | type Name = String
 90 | 
 91 | -- | Dimension descriptor.
 92 | data Idx i = Idx { iType :: i
 93 |                  , iDim  :: Int
 94 |                  , iName :: Name
 95 |                  } deriving (Eq)
 96 | 
 97 | instance Eq i => Ord (Idx i) where
 98 |     compare = compare `on` iName
 99 | 
100 | -- | A multidimensional array with index type i and elements t.
101 | data NArray i t = A { dims   :: [Idx i]   -- ^ Get detailed dimension information about the array.
102 |                     , coords :: Vector t  -- ^ Get the coordinates of an array as a
103 |                                           -- flattened structure (in the order specified by 'dims').
104 |                     }
105 | 
106 | -- | development function not intended for the end user
107 | mkNArray :: (Coord a) => [Idx i] -> Vector a -> NArray i a
108 | mkNArray dms vec = A dms v where
109 |     ds = map iDim dms
110 |     n = product ds
111 |     v = if dim vec == n && (null ds || minimum ds > 0)
112 |             then vec
113 |             else error $ show ds ++ " dimensions and " ++
114 |                          show (dim vec) ++ " coordinates for mkNArray"
115 | 
116 | resetCoords :: Coord t => NArray i t -> Vector t -> NArray i t
117 | -- ^ change the whole set of coordinates.
118 | resetCoords (A dms u) v | dim u == dim v = A dms v
119 |                         | otherwise = error "wrong size in replaceCoords"
120 | 
121 | 
122 | -- | Create a 0-dimensional structure.
123 | scalar :: Coord t => t -> NArray i t
124 | scalar x = A [] (fromList [x])
125 | 
126 | -- | Rename indices (in the internal order). Equal indices are contracted out.
127 | renameRaw :: (Coord t, Compat i)
128 |        => NArray i t
129 |        -> [Name]     -- ^ new names
130 |        -> NArray i t
131 | renameRaw t ns = contract (renameSuperRaw t ns)
132 | 
133 | renameSuperRaw (A d v) l
134 |     | length l == length d = A d' v
135 |     | otherwise = error $ "renameRaw " ++ show d ++ " with " ++ show l
136 |    where d' = zipWith f d l
137 |          f i n = i {iName=n}
138 | 
139 | mapDims f (A d v) = A (map f d) v
140 | 
141 | mapTypes :: (i1 -> i2) -> NArray i1 t -> NArray i2 t
142 | mapTypes f = mapDims (\i -> i {iType = f (iType i)})
143 | 
144 | mapNames :: (Name -> Name) -> NArray i t -> NArray i t
145 | mapNames f = mapDims (\i -> i {iName = f (iName i)})
146 | 
147 | -- | Rename indices using an association list.
148 | renameExplicit :: (Compat i, Coord t) => [(Name,Name)] -> NArray i t -> NArray i t
149 | renameExplicit al = g . mapNames f where
150 |     f n = maybe n id (lookup n al)
151 |     g t = reorder orig (contract t) where orig = nub (namesR t) \\ common1 t
152 | 
153 | -- | Index names (in internal order).
154 | namesR :: NArray i t -> [Name]
155 | namesR = map iName . dims
156 | 
157 | -- | Index names (in alphabetical order).
158 | names :: NArray i t -> [Name]
159 | names = sort . namesR
160 | 
161 | -- | Dimension of given index.
162 | size :: Name -> NArray i t -> Int
163 | size n t = (iDim . head) (filter ((n==).iName) (dims t))
164 | 
165 | sizesR :: NArray i t -> [Int]
166 | sizesR = map iDim . dims
167 | 
168 | -- | Dimensions of indices (in alphabetical order of indices).
169 | sizes :: NArray i t -> [Int]
170 | sizes t = map (flip size t) (names t)
171 | 
172 | -- | Type of given index.
173 | typeOf :: Compat i => Name -> NArray i t -> i
174 | typeOf n t = (iType . head) (filter ((n==).iName) (dims t))
175 | 
176 | -- | The number of dimensions of a multidimensional array.
177 | order :: NArray i t -> Int
178 | order = length . dims
179 | 
180 | selDims ds = map f where
181 |     f n = head $ filter ((n==).iName) ds
182 | 
183 | ----------------------------------------------------------
184 | 
185 | common2 t1 t2 = [ n1 | n1 <- namesR t1, n2 <- namesR t2, n1==n2]
186 | 
187 | analyzeProduct :: (Coord t, Compat i) => NArray i t -> NArray i t -> Maybe (NArray i t, Int)
188 | analyzeProduct a b = r where
189 |     nx  = common2 a b
190 |     dx1 = selDims (dims a) nx
191 |     dx2 = selDims (dims b) nx
192 |     ok  = and $ zipWith compat dx1 dx2
193 |     (tma,na) = matrixatorFree a nx
194 |     (mb,nb)  = matrixatorFree b nx
195 |     mc  = trans tma <> mb
196 |     da  = selDims (dims a) na
197 |     db  = selDims (dims b) nb
198 |     dc  = db ++ da
199 |     c   = A dc (flatten $ trans mc) -- mc is a column-major matrix and we want to avoid a matrix transpose
200 |     sz  = product (map iDim dc)
201 |     r | ok = Just (c, sz)
202 |       | otherwise = Nothing
203 | 
204 | infixl 5 |*|
205 | -- | Tensor product with automatic contraction of repeated indices, following Einstein summation convention.
206 | (|*|) :: (Coord t, Compat i) => NArray i t -> NArray i t -> NArray i t
207 | t1 |*| t2 = case analyzeProduct t1 t2 of
208 |     Nothing -> error $ "wrong contraction2: "++(show $ dims t1)++" and "++(show $ dims t2)
209 |     Just (r,_) -> r
210 | 
211 | ----------------------------------------------------------
212 | 
213 | lastIdx name t = ((d1,d2),m) where
214 |     (d1,d2) = span (\d -> iName d /= name) (dims t)
215 |     c = product (map iDim d2)
216 |     m = reshape c (coords t)
217 | 
218 | firstIdx name t = (nd,m')
219 |     where ((d1,d2),m) = lastIdx name t
220 |           m' = reshape c $ flatten $ trans m
221 |           nd = d2++d1
222 |           c = dim (coords t) `div` (iDim $ head d2)
223 | 
224 | -- | Obtain a matrix whose columns are the fibers of the array in the given dimension. The column order depends on the selected index (see 'matrixator').
225 | fibers :: Coord t => Name -> NArray i t -> Matrix t
226 | fibers n = snd . firstIdx n
227 | 
228 | -- | Reshapes an array as a matrix with the desired dimensions as flattened rows and flattened columns.
229 | matrixator :: (Coord t) => NArray i t -- ^ input array
230 |                         -> [Name]    -- ^ row dimensions
231 |                         -> [Name]    -- ^ column dimensions
232 |                         -> Matrix t   -- ^ result
233 | matrixator t nr nc = reshape s (coords q) where
234 |     q = reorder (nr++nc) t
235 |     s = product (map (flip size t) nc)
236 | 
237 | -- | Reshapes an array as a matrix with the desired dimensions as flattened rows and flattened columns. We do not force the order of the columns.
238 | matrixatorFree :: (Coord t)
239 |                => NArray i t          -- ^ input array
240 |                -> [Name]              -- ^ row dimensions
241 |                -> (Matrix t, [Name])  -- ^ (result, column dimensions)
242 | matrixatorFree t nr = (reshape s (coords q), nc) where
243 |     q = tridx nr t
244 |     nc = drop (length nr) (map iName (dims q))
245 |     s = product (map (flip size t) nc)
246 | 
247 | -- | Create a list of the substructures at the given level.
248 | parts :: (Coord t) 
249 |       => NArray i t
250 |       -> Name        -- ^ index to expand
251 |       -> [NArray i t]
252 | parts a name | name `elem` (namesR a) = map (reorder orig) (partsRaw a name)
253 |              | otherwise = error $ "parts: " ++ show name ++ " is not a dimension of "++(show $ namesR a)
254 |     where orig = namesR a \\ [name]
255 | 
256 | partsRaw a name = map f (toRows m)
257 |     where (_:ds,m) = firstIdx name a
258 |           f t = A {dims=ds, coords=t}
259 | 
260 | -- transpose indices of array such that namesR of the new array will begin with names'
261 | tridx :: forall i t. Coord t => [Name] -> NArray i t -> NArray i t
262 | tridx names' t0 = mkNArray dims' coords' where
263 |     dims0 = dims t0
264 |     dims' :: [Idx i]
265 |     dims' = go names' dims0
266 |         where go []     ds = ds
267 |               go (n:ns) ds = case partition ((==n) . iName) ds of
268 |                   ([d],ds') -> d : go ns ds'
269 |                   ([] ,_  ) -> error $ show n ++ " is not a dimension of " ++ show (map iName ds)
270 |                   (_  ,_  ) -> error $ show n ++ " is repeated in "        ++ show (map iName ds)
271 |     strides :: [Int]
272 |     strides = flip map dims' $ \d ->
273 |               product $ map iDim $ tail $ dropWhile (on (/=) iName d) dims0
274 |     intVec  = fromList . map fromIntegral
275 |     done    = and $ on (zipWith (==)) (map iName . filter ((>1) . iDim)) dims0 dims'
276 |     coords' | done      = coords t0
277 |             | otherwise = LA.reorderVector (intVec strides) (intVec $ map iDim dims') (coords t0)
278 | 
279 | -- | Change the internal layout of coordinates.
280 | -- The array, considered as an abstract object, does not change.
281 | reorder :: (Coord t) => [Name] -> NArray i t -> NArray i t
282 | reorder ns b | sort ns == sort (namesR b) = tridx ns b
283 |              | otherwise = error $ "wrong index sequence " ++ show ns
284 |                                     ++ " to reorder "++(show $ namesR b)
285 | 
286 | ----------------------------------------------------------------------
287 | 
288 | -- | Apply a function (defined on hmatrix 'Vector's) to all elements of a structure.
289 | -- Use @mapArray (mapVector f)@ for general functions.
290 | mapArray :: (Coord b) => (Vector a -> Vector b) -> NArray i a -> NArray i b
291 | mapArray f t = mkNArray (dims t) (f (coords t))
292 | 
293 | liftNA2 f (A d1 v1) (A _d2 v2) = A d1 (f v1 v2)
294 | 
295 | -- | Class of compatible indices for contractions.
296 | class (Eq a, Show (Idx a)) => Compat a where
297 |     compat :: Idx a -> Idx a -> Bool
298 |     opos   :: Idx a -> Idx a
299 | 
300 | 
301 | 
302 | contract1 t name1 name2 | ok = foldl1' (liftNA2 (+)) y
303 |                         | otherwise = error $ "wrong contraction1: "
304 |                                     ++(show $ dims t)++" "
305 |                                     ++ name1++" "++name2
306 |     where ok = (compat <$> getName t name1 <*> getName t name2) == Just True
307 |           x = map (flip partsRaw name2) (partsRaw t name1)
308 |           y = map head $ zipWith drop [0..] x
309 | 
310 | getName t name = d where
311 |     l = filter ((==name).iName) (dims t)
312 |     d = if null l
313 |             then Nothing
314 |             else Just (head l)
315 | 
316 | contract1c t n = contract1 renamed n n'
317 |     where n' = " "++n++" " -- forbid spaces in names...
318 |           renamed = renameSuperRaw (t) auxnames
319 |           auxnames = h ++ (n':r)
320 |           (h,_:r) = break (==n) (namesR t)
321 | 
322 | common1 t = [ n1 | (a,n1) <- x , (b,n2) <- x, a>b, n1==n2]
323 |     where x = zip [0 ::Int ..] (namesR t)
324 | 
325 | contract t = foldl' contract1c t (common1 t)
326 | 
327 | -------------------------------------------------------------
328 | 
329 | -- | Check if two arrays have the same structure.
330 | sameStructure :: (Eq i) => NArray i t1 -> NArray i t2 -> Bool
331 | sameStructure a b = sortBy (compare `on` iName) (dims a) == sortBy (compare `on` iName) (dims b)
332 | 
333 | -------------------------------------------------------------
334 | 
335 | -- | Apply an element-by-element binary function to the coordinates of two arrays. The arguments are automatically made conformant.
336 | zipArray :: (Coord a, Coord b, Compat i)
337 |    => (Vector a -> Vector b -> Vector c) -- ^ transformation
338 |    -> NArray i a
339 |    -> NArray i b
340 |    -> NArray i c
341 | zipArray o a b = liftNA2 o a' b' where
342 |     (a',b') = makeConformantT (a,b)
343 | 
344 | -------------------------------------------------------
345 | 
346 | -- | Create an array from a list of subarrays. (The inverse of 'parts'.)
347 | newIndex:: (Coord t, Compat i) =>
348 |      i  -- ^ index type
349 |      -> Name
350 |      -> [NArray i t]
351 |      -> NArray i t
352 | newIndex i name ts = r where
353 |     ds = Idx i (length ts) name : (dims (head cts))
354 |     cts = makeConformant ts
355 |     r = mkNArray ds (vjoin $ map coords cts)
356 | 
357 | -------------------------------------------------------
358 | 
359 | -- | Obtain a canonical base for the array.
360 | basisOf :: Coord t => NArray i t -> [NArray i t]
361 | basisOf t = map (dims t `mkNArray`) $ toRows (ident . dim . coords $ t)
362 | 
363 | -------------------------------------------------------------
364 | 
365 | -- instance (Container Vector, Compat i) => ComplexContainer (NArray i) where
366 | -- --    cmap f (A d v) = A d (cmap f v)
367 | --     conj (A d v) = A d (conj v)
368 | --     complex' (A d v) = A d (complex' v) -- mapArray without constraints
369 | -- 
370 | --     toComplex (A d1 r, A d2 c)  -- zipArray without constraints
371 | --         | d1==d2 = A d1 (toComplex (r,c))
372 | --         | otherwise = error "toComplex on arrays with different structure"
373 | -- 
374 | --     fromComplex (A d v) = (A d *** A d) (fromComplex v)
375 | -- 
376 | --     single' (A d v) = A d (single' v)
377 | --     double' (A d v) = A d (double' v)
378 | 
379 | -- instance (NFData t, Element t) => NFData (NArray i t) where
380 | --     rnf = rnf . coords
381 | 
382 | ----------------------------------------------------------------------
383 | 
384 | -- | obtains the common value of a property of a list
385 | common :: (Eq a) => (b->a) -> [b] -> Maybe a
386 | common f = commonval . map f where
387 |     commonval :: (Eq a) => [a] -> Maybe a
388 |     commonval [] = Nothing
389 |     commonval [a] = Just a
390 |     commonval (a:b:xs) = if a==b then commonval (b:xs) else Nothing
391 | 
392 | ------------------------------------------------------------------------
393 | 
394 | -- | Extract the 'Matrix' corresponding to a two-dimensional array,
395 | -- in the rows,cols order.
396 | asMatrix :: (Coord t) => NArray i t -> Matrix t
397 | asMatrix a | order a == 2 = reshape c (coords a')
398 |            | otherwise = error $ "asMatrix requires a 2nd order array."
399 |     where c = size (last (namesR a')) a'
400 |           a' = reorder (sort (namesR a)) a
401 | 
402 | -- | Extract the 'Vector' corresponding to a one-dimensional array.
403 | asVector :: (Coord t) => NArray i t -> Vector t
404 | asVector a | order a == 1 = coords a
405 |            | otherwise = error $ "asVector requires a 1st order array."
406 | 
407 | -- | Extract the scalar element corresponding to a 0-dimensional array.
408 | asScalar :: (Coord t) => NArray i t -> t
409 | asScalar a | order a == 0 = coords a ! 0
410 |            | otherwise = error $ "asScalar requires a 0th order array."
411 | 
412 | ------------------------------------------------------------------------
413 | 
414 | -- | Create a 1st order array from a 'Vector'.
415 | fromVector :: (Coord t, Compat i) => i -> Vector t -> NArray i t
416 | fromVector i v = mkNArray [Idx i (dim v) "1"] v
417 | 
418 | -- | Create a 2nd order array from a 'Matrix'.
419 | fromMatrix :: (Compat i, Coord t) => i -> i -> Matrix t -> NArray i t
420 | fromMatrix ir ic m = mkNArray [Idx ir (rows m) "1",
421 |                                Idx ic (cols m) "2"] (flatten m)
422 | 
423 | -- | Create an 'NArray' from a 'Vector' by specifying the 'dims' and 'coords'.
424 | reshapeVector :: (Compat i, Coord t) => [Idx i] -> Vector t -> NArray i t
425 | reshapeVector dms vec = contract $ mkNArray dms vec
426 | 
427 | ------------------------------------------------------------------------
428 | 
429 | -- | Select some parts of an array, taking into account position and value.
430 | extract :: (Compat i, Coord t)
431 |         => (Int -> NArray i t -> Bool)
432 |         -> Name
433 |         -> NArray i t
434 |         -> NArray i t
435 | extract f name arr = reorder (namesR arr)
436 |                    . newIndex (typeOf name arr) name
437 |                    . map snd . filter (uncurry f)
438 |                    $ zip [1..] (parts arr name)
439 | 
440 | -- | Apply a list function to the parts of an array at a given index.
441 | onIndex :: (Coord a, Coord b, Compat i) =>
442 |      ([NArray i a] -> [NArray i b])
443 |      -> Name
444 |      -> NArray i a
445 |      -> NArray i b
446 | onIndex f name t = r where
447 |      r = if sort (namesR x) == sort (namesR t)
448 |             then reorder (namesR t) x
449 |             else x
450 |      x = newIndex (typeOf name t) name (f (parts t name))
451 | 
452 | ------------------------------------------------------------------------
453 | 
454 | extend alldims (A d v) = reorder (allnames) s where
455 |     allnames = map iName alldims
456 |     pref = alldims \\ d
457 |     n = product (map iDim pref)
458 |     s = A (pref++d) (vjoin (replicate n v))
459 | 
460 | -- | Obtains most general structure of a list of dimension specifications
461 | conformable :: Compat i => [[Idx i]] -> Maybe [Idx i]
462 | conformable ds | ok        = Just alldims
463 |                | otherwise = Nothing
464 |     where alldims = nub (concat ds)
465 |           allnames = map iName alldims
466 |           ok = length (allnames) == length (nub allnames)
467 | 
468 | -- | Converts a list of arrays to a common structure.
469 | makeConformant :: (Coord t, Compat i) => [NArray i t] -> [NArray i t]
470 | makeConformant ts =
471 |     case conformable (map dims ts) of
472 |         Just alldims -> map (extend alldims) ts
473 |         Nothing -> error $ "makeConformant with inconsistent dimensions "
474 |                          ++ show (map dims ts)
475 | 
476 | -- the same version for tuples with possibly different element types
477 | makeConformantT (t1,t2) =
478 |     case conformable [dims t1, dims t2] of
479 |         Just alldims -> (extend alldims t1, extend alldims t2)
480 |         Nothing -> error $ "makeConformantT with inconsistent dimensions "
481 |                          ++ show (dims t1, dims t2)
482 | 
483 | ---------------------------------------------
484 | 
485 | takeDiagT :: (Compat i, Coord t) => NArray i t -> [t]
486 | takeDiagT t = map (asScalar . atT t) cds where
487 |     n = minimum (sizesR t)
488 |     o = order t
489 |     cds = map (replicate o) [0..n-1]
490 | 
491 | atT :: (Compat i, Coord t) => NArray i t -> [Int] -> NArray i t
492 | atT t c = atT' c t where
493 |     atT' cs = foldl1' (.) (map fpart cs)
494 |     fpart k q = parts q (head (namesR q)) !! k
495 | 
496 | ----------------------------------------------
497 | 
498 | -- not very smart...
499 | 
500 | type Cost     = Either Int Int
501 | type TensorID = Int
502 | 
503 | data SmartProductDat i t = SmartProductDat {
504 |     pTensors   :: Map TensorID (NArray i t),    -- label tensors with a unique ID
505 |     pIndexMap  :: Map Name (Set TensorID),      -- all tensors with a given index
506 |     pSizes     :: Set (Int, TensorID),          -- tensors sorted by size
507 |     pPairCosts :: Set (Cost,TensorID,TensorID), -- sorted contraction suggestions
508 |     pMaxID     :: TensorID }                    -- largest ID
509 | -- pPairCosts has an entry for all pairs of tensors with common indices of dimension > 1
510 | -- To deal with disconnected networks (and scalars), pPairCosts also always has an entry for the two smallest tensors (obtained via pSizeMap)
511 | -- Extra entries in pPairCosts may exists, even with a TensorID that isn't in pTensors
512 | 
513 | smartProduct :: (Coord t, Compat i, Num (NArray i t)) => [NArray i t] -> NArray i t
514 | smartProduct = contractTensors . foldl' (flip addTensor) dat0  where
515 |     dat0 = SmartProductDat Map.empty Map.empty Set.empty Set.empty 0
516 |     sizeF = product . sizesR
517 |     addTensor t dat      = addSmallSizePairs dat $ SmartProductDat {
518 |               pTensors   = Map.insertWith undefined iD t $ pTensors dat,
519 |               pIndexMap  = foldl' (\iM n -> Map.insertWith Set.union n (Set.singleton iD) iM) (pIndexMap dat)
520 |                          $ map iName $ filter ((>1) . iDim) $ dims t,
521 |               pSizes     = Set.insert (sizeF t, iD) $ pSizes dat,
522 |               pPairCosts = foldl' (flip Set.insert) (pPairCosts dat) newPairs,
523 |               pMaxID     = iD }
524 |         where iD         = pMaxID dat + 1
525 |               newPairs   = [ (costF t $ pTensors dat Map.! iD', iD', iD)
526 |                            | iD' <- Set.toList $ Set.unions $ mapMaybe (flip Map.lookup $ pIndexMap dat) $ namesR t ]
527 |     removeTensor iD dat  = addSmallSizePairs dat $ dat {
528 |               pTensors   = Map.delete iD $ pTensors dat,
529 |               pIndexMap  = foldl' (flip $ Map.update $ justIf (not . Set.null) . Set.delete iD)
530 |                            (pIndexMap dat) $ namesR t,
531 |               pSizes     = Set.delete (sizeF t, iD) $ pSizes dat }
532 |         where t          = pTensors dat Map.! iD
533 |               justIf q x | q x       = Just x
534 |                          | otherwise = Nothing
535 |     -- add a pPairCosts entry whenever the two smallest tensors change, so that there is always an entry for the two smallest tensors
536 |     addSmallSizePairs dat dat'
537 |         | on (/=) (take 2 . Set.toAscList . pSizes) dat dat',
538 |           ((_,iD):(_,iD'):_) <- Set.toAscList $ pSizes dat'
539 |         = dat' { pPairCosts = Set.insert (on costF (pTensors dat' Map.!) iD iD', iD, iD') $ pPairCosts dat' }
540 |         | otherwise = dat'
541 |     costF a b = case analyzeProduct a b of
542 |                      Nothing    -> error $ "inconsistent dimensions in smartProduct: " ++ show (dims a) ++ " and " ++ show (dims b)
543 |                      Just (_,sC) -> let sA = sizeF a
544 |                                         sB = sizeF b
545 |                                     in  if   sC <= max sA sB      -- favor contractions which reduce the size of the larger tensor
546 |                                         then Left    sC           -- favor small tensors first
547 |                                         else Right $ sC - sA - sB -- prioritize the larger tensors
548 |     contractTensors dat = case Set.minView $ pPairCosts dat of
549 |         Nothing                       -> (\[t] -> t) $ Map.elems $ pTensors dat
550 |         Just ((_,iD,iD'), pairCosts') ->
551 |             let update = fromMaybe id
552 |                        $ do t  <- Map.lookup iD  $ pTensors dat -- only contract if iD and iD' haven't already been removed
553 |                             t' <- Map.lookup iD' $ pTensors dat
554 |                             return $ addTensor (t * t') . removeTensor iD . removeTensor iD'
555 |             in  contractTensors $ update $ dat { pPairCosts = pairCosts' }
556 | 
557 | ----------------------------------------------
558 | 
559 | -- | sequence of n indices with given prefix
560 | seqIdx :: Int -> String -> [Name]
561 | seqIdx n prefix = [prefix ++ show k | k <- [1 .. n] ]
562 | 
563 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Simple.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-}
 2 | {-# OPTIONS_HADDOCK hide #-}
 3 | -----------------------------------------------------------------------------
 4 | -- |
 5 | -- Module      :  Data.Packed.Array.Simple
 6 | -- Copyright   :  (c) Alberto Ruiz 2009
 7 | -- License     :  BSD3
 8 | -- Maintainer  :  Alberto Ruiz
 9 | -- Stability   :  provisional
10 | --
11 | -- Simple multidimensional arrays.
12 | -- Contractions only require equal dimension.
13 | --
14 | -----------------------------------------------------------------------------
15 | 
16 | module Numeric.LinearAlgebra.Array.Simple (
17 |     None(..),
18 |     Array,
19 |     listArray
20 | ) where
21 | 
22 | import Numeric.LinearAlgebra.Array.Internal
23 | import Numeric.LinearAlgebra.HMatrix
24 | import Data.List(intersperse)
25 | 
26 | 
27 | instance Show (Idx None) where
28 |     show (Idx _t n s) = s ++ ":" ++ show n
29 | 
30 | -- | Unespecified coordinate type. Contractions only
31 | -- require equal dimension.
32 | data None = None deriving (Eq,Show)
33 | 
34 | 
35 | instance Compat None where
36 |     compat d1 d2 = iDim d1 == iDim d2
37 |     opos = id
38 | 
39 | 
40 | -- | Multidimensional array with unespecified coordinate type.
41 | type Array t = NArray None t
42 | 
43 | instance (Coord t) => Show (Array t) where
44 |     show t | null (dims t) = "scalar "++ show (coords t !0)
45 |            | order t == 1 = "index " ++ show n ++" " ++ (show . toList . coords $ t)
46 |            | otherwise = "index "++ show n ++ " [" ++ ps ++ "]"
47 |       where n = head (namesR t)
48 |             ps = concat $ intersperse ", " $ map show (parts t n)
49 | 
50 | -- ++ " "++ show (toList $ coords t)
51 | 
52 | -- | Construction of an 'Array' from a list of dimensions and a list of elements in left to right order.
53 | listArray :: (Coord t)
54 |     => [Int] -- ^ dimensions
55 |     -> [t]   -- ^ elements
56 |     -> Array t
57 | listArray ds cs = mkNArray dms (product ds |> (cs ++ repeat 0))
58 |     where dms = zipWith3 Idx (repeat None) ds (map show [1::Int ..])
59 | 
60 | 
61 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Solve.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts, TypeFamilies #-}
  2 | -----------------------------------------------------------------------------
  3 | -- |
  4 | -- Module      :  Data.Packed.Array.Solve
  5 | -- Copyright   :  (c) Alberto Ruiz 2009
  6 | -- License     :  BSD3
  7 | -- Maintainer  :  Alberto Ruiz
  8 | -- Stability   :  provisional
  9 | --
 10 | -- Solution of general multidimensional linear and multilinear systems.
 11 | --
 12 | -----------------------------------------------------------------------------
 13 | 
 14 | module Numeric.LinearAlgebra.Array.Solve (
 15 | -- * Linear systems
 16 |     solve,
 17 |     solveHomog, solveHomog1, solveH,
 18 |     solveP,
 19 | -- *  Multilinear systems
 20 | -- ** General
 21 |     ALSParam(..), defaultParameters,
 22 |     mlSolve, mlSolveH, mlSolveP,
 23 | -- ** Factorized
 24 |     solveFactors, solveFactorsH,
 25 | -- * Utilities
 26 |     eqnorm, infoRank,
 27 |     solve', solveHomog', solveHomog1', solveP'
 28 | ) where
 29 | 
 30 | import Numeric.LinearAlgebra.Array.Util
 31 | import Numeric.LinearAlgebra.Exterior
 32 | import Numeric.LinearAlgebra.Array.Internal(mkNArray, selDims, debug, namesR)
 33 | import Numeric.LinearAlgebra.HMatrix hiding (scalar,size)
 34 | --import qualified Numeric.LinearAlgebra.HMatrix as LA
 35 | import Data.List
 36 | import System.Random
 37 | 
 38 | 
 39 | -- | Solution of the linear system a x = b, where a and b are
 40 | -- general multidimensional arrays. The structure and dimension names
 41 | -- of the result are inferred from the arguments.
 42 | solve :: (Compat i, Coord t, Field t)
 43 |         => NArray i t -- ^ coefficients (a)
 44 |         -> NArray i t -- ^ target       (b)
 45 |         -> NArray i t -- ^ result       (x)
 46 | solve = solve' id
 47 | 
 48 | solve' g a b = x where
 49 |     nx = namesR a \\ namesR b
 50 |     na = namesR a \\ nx
 51 |     nb = namesR b \\ namesR a
 52 |     aM = g $ matrixator a na nx
 53 |     bM = g $ matrixator b na nb
 54 |     xM = linearSolveSVD aM bM
 55 |     dx = map opos (selDims (dims a) nx) ++ selDims (dims b) nb
 56 |     x = mkNArray dx (flatten xM)
 57 | 
 58 | 
 59 | -- | Solution of the homogeneous linear system a x = 0, where a is a
 60 | -- general multidimensional array.
 61 | --
 62 | -- If the system is overconstrained we may provide the theoretical rank to get a MSE solution.
 63 | solveHomog :: (Compat i, Coord t, Field t)
 64 |            =>  NArray i t    -- ^ coefficients (a)
 65 |            -> [Name]         -- ^ desired dimensions for the result
 66 |                              --   (a subset selected from the target).
 67 |            -> Either Double Int -- ^ Left \"numeric zero\" (e.g. eps), Right \"theoretical\" rank
 68 |            -> [NArray i t] -- ^ basis for the solutions (x)
 69 | solveHomog = solveHomog' id
 70 | 
 71 | solveHomog' g a nx' hint = xs where
 72 |     nx = filter (`elem` (namesR a)) nx'
 73 |     na = namesR a \\ nx
 74 |     aM = g $ matrixator a na nx
 75 |     vs = toColumns $ nullspaceSVD hint aM (rightSV aM)
 76 |     dx = map opos (selDims (dims a) nx)
 77 |     xs = map (mkNArray dx) vs
 78 | 
 79 | -- | A simpler way to use 'solveHomog', which returns just one solution.
 80 | -- If the system is overconstrained it returns the MSE solution.
 81 | solveHomog1 :: (Compat i, Coord t, Field t)
 82 |             => NArray i t
 83 |             -> [Name]
 84 |             -> NArray i t
 85 | solveHomog1 = solveHomog1' id
 86 | 
 87 | solveHomog1' g m ns = head $ solveHomog' g m ns (Right (k-1))
 88 |     where k = product $ map iDim $ selDims (dims m) ns
 89 | 
 90 | -- | 'solveHomog1' for single letter index names.
 91 | solveH :: (Compat i, Coord t, Field t) => NArray i t -> [Char] -> NArray i t
 92 | solveH m ns = solveHomog1 m (map return ns)
 93 | 
 94 | 
 95 | -- | Solution of the linear system a x = b, where a and b are
 96 | -- general multidimensional arrays, with homogeneous equality along a given index.
 97 | solveP :: Tensor Double   -- ^ coefficients (a)
 98 |        -> Tensor Double   -- ^ desired result (b)
 99 |        -> Name            -- ^ the homogeneous dimension
100 |        -> Tensor Double   -- ^ result (x)
101 | solveP = solveP' id
102 | 
103 | solveP' g a b h = mapTat (solveP1 g h a) (namesR b \\ (h:namesR a)) b
104 | 
105 | -- solveP for a single right hand side
106 | solveP1 g nh a b = solveHomog1' g ou ns where
107 |     k = size nh b
108 |     epsi = t $ leviCivita k `renameO` (nh : (take (k-1) $ (map (('e':).(:[])) ['2'..])))
109 |     ou = a .* b' * epsi
110 |     ns = (namesR a \\ namesR b) ++ x
111 |     b' = renameExplicit [(nh,"e2")] b
112 |     x = if nh `elem` (namesR a) then [] else [nh]
113 |     t = if typeOf nh b == Co then contrav else cov
114 |         -- mapTypes (const (opos $ typeOf nh b))
115 | 
116 | -----------------------------------------------------------------------
117 | 
118 | -- | optimization parameters for alternating least squares
119 | data ALSParam i t = ALSParam
120 |     { nMax  ::   Int     -- ^ maximum number of iterations
121 |     , delta ::   Double  -- ^ minimum relative improvement in the optimization (percent, e.g. 0.1)
122 |     , epsilon :: Double  -- ^ maximum relative error. For nonhomogeneous problems it is
123 |                          --   the reconstruction error in percent (e.g.
124 |                          --   1E-3), and for homogeneous problems is the frobenius norm of the
125 |                          --  expected zero structure in the right hand side.
126 |     , post :: [NArray i t] -> [NArray i t] -- ^ post-processing function after each full iteration (e.g. 'id')
127 |     , postk :: Int -> NArray i t -> NArray i t-- ^ post-processing function for the k-th argument (e.g. 'const' 'id')
128 |     , presys :: Matrix t -> Matrix t -- ^ preprocessing function for the linear systems (eg. 'id', or 'infoRank')
129 |     }
130 | 
131 | 
132 | optimize :: (x -> x)      -- ^ method
133 |          -> (x -> Double) -- ^ error function
134 |          -> x             -- ^ starting point
135 |          -> ALSParam i t     -- ^ optimization parameters
136 |          -> (x, [Double]) -- ^ solution and error history
137 | optimize method errfun s0 p = (sol,e) where
138 |     sols = take (max 1 (nMax p)) $ iterate method s0
139 |     errs = map errfun sols
140 |     (sol,e) = convergence (zip sols errs) []
141 |     convergence [] _  = error "impossible"
142 |     convergence [(s,err)] prev = (s, err:prev)
143 |     convergence ((s1,e1):(s2,e2):ses) prev
144 |         | e1 < epsilon p = (s1, e1:prev)
145 |         | abs (100*(e1 - e2)/e1) < delta p = (s2, e2:prev)
146 |         | otherwise = convergence ((s2,e2):ses) (e1:prev)
147 | 
148 | percent t s = 100 * frobT (t - smartProduct s) / frobT t
149 | 
150 | percentP h t s = 100 * frobT (t' - s') / frobT t' where
151 |     t' = f t
152 |     s' = f (smartProduct s)
153 |     f = mapTat g (namesR t \\ [h])
154 |     g v = v / atT v [n]
155 |     n = size h t - 1
156 | 
157 | frobT t = realToFrac . norm_2 . coords $ t
158 | --unitT t = t / scalar (frobT t)
159 | 
160 | dropElemPos k xs = take k xs ++ drop (k+1) xs
161 | replaceElemPos k v xs = take k xs ++ v : drop (k+1) xs
162 | 
163 | takes [] _ = []
164 | takes (n:ns) xs = take n xs : takes ns (drop n xs)
165 | 
166 | ----------------------------------------------------------------------
167 | 
168 | alsStep f params a x = (foldl1' (.) (map (f params a) [n,n-1 .. 0])) x
169 |     where n = length x - 1
170 | 
171 | -----------------------------------------------------------------------
172 | 
173 | -- | Solution of a multilinear system a x y z ... = b based on alternating least squares.
174 | mlSolve
175 |   :: (Compat i, Coord t, Field t, Num (NArray i t), Show (NArray i t))
176 |      => ALSParam i t     -- ^ optimization parameters
177 |      -> [NArray i t]  -- ^ coefficients (a), given as a list of factors.
178 |      -> [NArray i t]  -- ^ initial solution [x,y,z...]
179 |      -> NArray i t    -- ^ target (b)
180 |      -> ([NArray i t], [Double]) -- ^ Solution and error history
181 | mlSolve params a x0 b
182 |     = optimize (post params . alsStep (alsArg b) params a) (percent b . (a++)) x0 params
183 | 
184 | alsArg _ _ _ _ [] = error "alsArg _ _ []"
185 | alsArg b params a k xs = sol where
186 |     p = smartProduct (a ++ dropElemPos k xs)
187 |     x = solve' (presys params) p b
188 |     x' = postk params k x
189 |     sol = replaceElemPos k x' xs
190 | 
191 | ----------------------------------------------------------
192 | 
193 | -- | Solution of the homogeneous multilinear system a x y z ... = 0 based on alternating least squares.
194 | mlSolveH
195 |   :: (Compat i, Coord t, Field t, Num (NArray i t), Show (NArray i t))
196 |      => ALSParam  i t    -- ^ optimization parameters
197 |      -> [NArray i t]  -- ^ coefficients (a), given as a list of factors.
198 |      -> [NArray i t]  -- ^ initial solution [x,y,z...]
199 |      -> ([NArray i t], [Double]) -- ^ Solution and error history
200 | mlSolveH params a x0
201 |     = optimize (post params . alsStep alsArgH params a) (frobT . smartProduct . (a++)) x0 params
202 | 
203 | alsArgH _ _ _ [] = error "alsArgH _ _ []"
204 | alsArgH params a k xs = sol where
205 |     p = smartProduct (a ++ dropElemPos k xs)
206 |     x = solveHomog1' (presys params) p (namesR (xs!!k))
207 |     x' = postk params k x
208 |     sol = replaceElemPos k x' xs
209 | 
210 | ----------------------------------------------------------
211 | 
212 | -- | Solution of a multilinear system a x y z ... = b, with a homogeneous index, based on alternating least squares.
213 | mlSolveP
214 |      :: ALSParam Variant Double     -- ^ optimization parameters
215 |      -> [Tensor Double]  -- ^ coefficients (a), given as a list of factors.
216 |      -> [Tensor Double]  -- ^ initial solution [x,y,z...]
217 |      -> Tensor Double    -- ^ target (b)
218 |      -> Name             -- ^ homogeneous index
219 |      -> ([Tensor Double], [Double]) -- ^ Solution and error history
220 | mlSolveP params a x0 b h
221 |     = optimize (post params . alsStep (alsArgP b h) params a) (percentP h b . (a++)) x0 params
222 | 
223 | alsArgP _ _ _ _ _ [] = error "alsArgP _ _ []"
224 | alsArgP b h params a k xs = sol where
225 |     p = smartProduct (a ++ dropElemPos k xs)
226 |     x = solveP' (presys params)  p b h
227 |     x' = postk params k x
228 |     sol = replaceElemPos k x' xs
229 | 
230 | -------------------------------------------------------------
231 | 
232 | {- | Given two arrays a (source) and  b (target), we try to compute linear transformations x,y,z,... for each dimension, such that product [a,x,y,z,...] == b.
233 | (We can use 'eqnorm' for 'post' processing, or 'id'.)
234 | -}
235 | solveFactors :: (Coord t, Field t, Random t, Compat i, Num (NArray i t), Show (NArray i t))
236 |              => Int          -- ^ seed for random initialization
237 |              -> ALSParam i t     -- ^ optimization parameters
238 |              -> [NArray i t] -- ^ source (also factorized)
239 |              -> String       -- ^ index pairs for the factors separated by spaces
240 |              -> NArray i t   -- ^ target
241 |              -> ([NArray i t],[Double]) -- ^ solution and error history
242 | solveFactors seed params a pairs b =
243 |     mlSolve params a (initFactorsRandom seed (smartProduct a) pairs b) b
244 | 
245 | initFactorsSeq rs a pairs b | ok = as
246 |                             | otherwise = error "solveFactors index pairs"
247 |   where
248 |     (ia,ib) = unzip (map sep (words pairs))
249 |     ic = intersect (namesR a) (namesR b)
250 |     ok = sort (namesR b\\ic) == sort ib && sort (namesR a\\ic) == sort ia
251 |     db = selDims (dims b) ib
252 |     da = selDims (dims a) ia
253 |     nb = map iDim db
254 |     na = map iDim da
255 |     ts = takes (zipWith (*) nb na) rs
256 |     as = zipWith5 f ts ib ia db da
257 |     f c i1 i2 d1 d2 = (mkNArray [d1,opos d2] (fromList c)) `renameO` [i1,i2]
258 | 
259 | initFactorsRandom seed a b = initFactorsSeq (randomRs (-1,1) (mkStdGen seed)) a b
260 | 
261 | 
262 | -- | Homogeneous factorized system. Given an array a,
263 | -- given as a list of factors as, and a list of pairs of indices
264 | -- [\"pi\",\"qj\", \"rk\", etc.], we try to compute linear transformations
265 | -- x!\"pi\", y!\"pi\", z!\"rk\", etc. such that product [a,x,y,z,...] == 0.
266 | solveFactorsH
267 |   :: (Coord t, Random t, Field t, Compat i, Num (NArray i t), Show (NArray i t))
268 |      => Int -- ^ seed for random initialization
269 |      -> ALSParam  i t    -- ^ optimization parameters
270 |      -> [NArray i t] -- ^ coefficient array (a), (also factorized)
271 |      -> String       -- ^ index pairs for the factors separated by spaces
272 |      -> ([NArray i t], [Double]) -- ^ solution and error history
273 | solveFactorsH seed params a pairs =
274 |     mlSolveH params a (initFactorsHRandom seed (smartProduct a) pairs)
275 | 
276 | initFactorsHSeq rs a pairs = as where
277 |     (ir,it) = unzip (map sep (words pairs))
278 |     nr = map (flip size a) ir
279 |     nt = map (flip size a) it
280 |     ts = takes (zipWith (*) nr nt) rs
281 |     as = zipWith5 f ts ir it (selDims (dims a) ir) (selDims (dims a) it)
282 |     f c i1 i2 d1 d2 = (mkNArray (map opos [d1,d2]) (fromList c)) `renameO` [i1,i2]
283 | 
284 | initFactorsHRandom seed a pairs = initFactorsHSeq (randomRs (-1,1) (mkStdGen seed)) a pairs
285 | 
286 | sep [a,b] = ([a],[b])
287 | sep _ = error "impossible pattern in hTensor initFactors"
288 | 
289 | ----------------------------------
290 | 
291 | -- | post processing function that modifies a list of tensors so that they
292 | -- have equal frobenius norm
293 | eqnorm :: (Compat i,Show (NArray i Double))
294 |        => [NArray i Double] -> [NArray i Double]
295 | 
296 | eqnorm [] = error "eqnorm []"
297 | eqnorm as = as' where
298 |     n = length as
299 |     fs = map (frobT) as
300 |     s = product fs ** (1/fromIntegral n)
301 |     as' = zipWith g as fs where g a f = a * (scalar (s/f))
302 | 
303 | -- | nMax = 20, epsilon = 1E-3, delta = 1, post = id, postk = const id, presys = id
304 | defaultParameters :: ALSParam i t
305 | defaultParameters = ALSParam {
306 |     nMax = 20,
307 |     epsilon = 1E-3,
308 |     delta = 1,
309 |     post = id,
310 |     postk = const id,
311 |     presys = id
312 |   }
313 | 
314 | -- | debugging function (e.g. for 'presys'), which shows rows, columns and rank of the
315 | -- coefficient matrix of a linear system.
316 | infoRank :: Field t => Matrix t -> Matrix t
317 | infoRank a = debug "" (const (rows a, cols a, rank a)) a
318 | 
319 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Array/Util.hs:
--------------------------------------------------------------------------------
  1 | -- {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
  2 | -----------------------------------------------------------------------------
  3 | -- |
  4 | -- Module      :  Data.Packed.Array.Util
  5 | -- Copyright   :  (c) Alberto Ruiz 2009
  6 | -- License     :  BSD3
  7 | -- Maintainer  :  Alberto Ruiz
  8 | -- Stability   :  provisional
  9 | --
 10 | -- Additional tools for manipulation of multidimensional arrays.
 11 | --
 12 | -----------------------------------------------------------------------------
 13 | 
 14 | module Numeric.LinearAlgebra.Array.Util (
 15 |     Coord, Compat(..),
 16 |     NArray, Idx(..), Name,
 17 |     scalar,
 18 |     order, names, size, sizes, typeOf, dims, coords,
 19 | 
 20 |     renameExplicit, (!>), renameO, (!),
 21 | 
 22 |     parts,
 23 |     newIndex,
 24 | 
 25 |     mapArray, zipArray, (|*|), smartProduct, outers,
 26 | 
 27 |     extract, onIndex, mapTat,
 28 | 
 29 |     reorder, (~>),
 30 |     formatArray, formatFixed, formatScaled,
 31 |     dummyAt, noIdx,
 32 |     conformable,
 33 |     sameStructure,
 34 |     makeConformant,
 35 |     basisOf,
 36 |     atT, takeDiagT, diagT,
 37 |     mkFun, mkAssoc, setType,
 38 |     renameParts,
 39 |     resetCoords,
 40 |     asScalar, asVector, asMatrix, applyAsMatrix,
 41 |     fibers, matrixator, matrixatorFree, analyzeProduct,
 42 |     fromVector, fromMatrix, reshapeVector
 43 |     -- ,Container(..),
 44 | ) where
 45 | 
 46 | import Numeric.LinearAlgebra.Array.Internal
 47 | import Numeric.LinearAlgebra.Array.Display
 48 | import Numeric.LinearAlgebra.HMatrix(Matrix)
 49 | import Numeric.LinearAlgebra.Array.Simple
 50 | import Data.List(intersperse,sort,foldl1')
 51 | 
 52 | -- infixl 9 #
 53 | -- (#) :: [Int] -> [Double] -> Array Double
 54 | -- (#) = listArray
 55 | 
 56 | -- | Multidimensional diagonal of given order.
 57 | diagT :: [Double] -> Int -> Array Double
 58 | diagT v n = replicate n k `listArray` concat (intersperse z (map return v))
 59 |     where k = length v
 60 |           tot = k^n
 61 |           nzeros = (tot - k) `div` (k-1)
 62 |           z = replicate nzeros 0
 63 | 
 64 | 
 65 | -- | Explicit renaming of single letter index names.
 66 | --
 67 | -- For instance, @t >\@> \"pi qj\"@ changes index \"p\" to \"i\" and \"q\" to \"j\".
 68 | (!>) :: (Compat i, Coord t) => NArray i t -> [Char] -> NArray i t
 69 | infixl 9 !>
 70 | t !> s = renameExplicit (map f (words s)) t
 71 |   where
 72 |     f [a,b] = ([a],[b])
 73 |     f _ = error "impossible pattern in hTensor (!>)"
 74 | 
 75 | -- | Rename indices in alphabetical order. Equal indices of compatible type are contracted out.
 76 | renameO :: (Coord t, Compat i)
 77 |     => NArray i t
 78 |     -> [Name]
 79 |     -> NArray i t
 80 | renameO t ns = renameExplicit (zip od ns) t
 81 |     where od = map iName (sort (dims t))
 82 | 
 83 | 
 84 | -- | Rename indices in alphabetical order ('renameO') using single letter names.
 85 | (!) :: (Compat i, Coord t) => NArray i t -> [Char] -> NArray i t
 86 | infixl 9 !
 87 | t ! s = renameExplicit (zip od (map return s)) t
 88 |     where od = map iName (sort (dims t))
 89 | 
 90 | 
 91 | -- -- | 'renameRaw' the indices (in the internal order) with single-letter names. Equal indices of compatible type are contracted out.
 92 | -- infixl 8 !!!
 93 | -- (!!!) :: (Coord t, Compat i)
 94 | --        => NArray i t
 95 | --        -> String   -- ^ new indices
 96 | --        -> NArray i t
 97 | -- t !!! ns = renameRaw t (map return ns)
 98 | 
 99 | 
100 | -- | 'reorder' (transpose) dimensions of the array (with single letter names).
101 | --
102 | -- Operations are defined by named indices, so the transposed array is operationally equivalent to the original one.
103 | infixl 8 ~>
104 | (~>) :: (Coord t) => NArray i t -> String -> NArray i t
105 | t ~> ns = reorder (map return ns) t
106 | 
107 | 
108 | -- | Map a function at the internal level selected by a set of indices
109 | mapTat :: (Coord a, Coord b, Compat i)
110 |          => (NArray i a -> NArray i b)
111 |          -> [Name]
112 |          -> NArray i a
113 |          -> NArray i b
114 | mapTat f [] = f
115 | mapTat f (a:as) = onIndex (map $ mapTat f as) a
116 | 
117 | -- | Outer product of a list of arrays along the common indices.
118 | outers :: (Coord a, Compat i) => [NArray i a] -> NArray i a
119 | outers = foldl1' (zipArray (*))
120 | 
121 | -- | Define an array using a function.
122 | mkFun :: [Int] -> ([Int] -> Double) -> Array Double
123 | mkFun ds f = listArray ds $ map f (sequence $ map (enumFromTo 0 . subtract 1. fromIntegral) $ ds)
124 | 
125 | -- | Define an array using an association list.
126 | mkAssoc :: [Int] -> [([Int], Double)] -> Array Double
127 | mkAssoc ds ps = mkFun ds f where
128 |    f = maybe 0 id . flip lookup ps
129 | 
130 | -- | Change type of index.
131 | setType :: (Compat i, Coord t) => Name -> i -> NArray i t -> NArray i t
132 | setType n t a = mapDims f a where
133 |     f i | iName i == n = i {iType = t}
134 |         | otherwise    = i
135 | 
136 | -- | Extract the 'parts' of an array, and renameRaw one of the remaining indices
137 | -- with succesive integers.
138 | renameParts :: (Compat i, Coord t)
139 |             => Name         -- ^ index of the parts to extract
140 |             -> NArray i t   -- ^ input array
141 |             -> Name         -- ^ index to renameRaw
142 |             -> String       -- ^ prefix for the new names
143 |             -> [NArray i t] -- ^ list or results
144 | renameParts p t x pre = zipWith renameExplicit [[(x,pre ++ show k)] | k<-[1::Int ..] ] (parts t p)
145 | 
146 | 
147 | applyAsMatrix :: (Coord t, Compat i) => (Matrix t -> Matrix t) -> (NArray i t -> NArray i t)
148 | applyAsMatrix f t = flip renameRaw nms . fromMatrix r c . f . asMatrix $ t
149 |     where [r,c] = map (flip typeOf t) nms
150 |           nms = sort . namesR $ t
151 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Exterior.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleContexts #-}
  2 | -----------------------------------------------------------------------------
  3 | -- |
  4 | -- Module      :  Numeric.LinearAlgebra.Exterior
  5 | -- Copyright   :  (c) Alberto Ruiz 2009
  6 | -- License     :  BSD3
  7 | -- Maintainer  :  Alberto Ruiz
  8 | -- Stability   :  experimental
  9 | --
 10 | -- Exterior Algebra.
 11 | --
 12 | --
 13 | -----------------------------------------------------------------------------
 14 | 
 15 | module Numeric.LinearAlgebra.Exterior (
 16 |     (/\),
 17 |     inner,
 18 |     leviCivita,
 19 |     dual,
 20 |     (\/),
 21 |     module Numeric.LinearAlgebra.Tensor,
 22 |     asMultivector, fromMultivector
 23 | ) where
 24 | 
 25 | import Numeric.LinearAlgebra.Tensor
 26 | import Numeric.LinearAlgebra.Array.Internal
 27 | import Numeric.LinearAlgebra.Multivector(Multivector,fromTensor,maxDim,grade)
 28 | import qualified Numeric.LinearAlgebra.Multivector as MV
 29 | import Data.List
 30 | 
 31 | -- import Debug.Trace
 32 | -- debug x = trace (show x) x
 33 | 
 34 | interchanges :: (Ord a) => [a] -> Int
 35 | interchanges ls = sum (map (count ls) ls)
 36 |     where count l p = length $ filter (>p) $ take pel l
 37 |               where Just pel = elemIndex p l
 38 | 
 39 | signature :: (Num t, Ord a) => [a] -> t
 40 | signature l | length (nub l) < length l =  0
 41 |             | even (interchanges l)     =  1
 42 |             | otherwise                 = -1
 43 | 
 44 | gsym f t = mkNArray (dims t) (coords $ sum ts) where
 45 |     ns = map show [1 .. order t]
 46 |     t' = cov $ renameRaw t ns
 47 |     per = permutations ns
 48 |     ts  = map (flip renameRaw ns . f . flip reorder t') per
 49 | 
 50 | -- symmetrize t = gsym id t
 51 | 
 52 | antisymmetrize t = gsym scsig t
 53 |     where scsig x = scalar (signature (namesR x)) * x
 54 | 
 55 | fact n = product [1..n]
 56 | 
 57 | wedge a b = antisymmetrize (a*b) * (recip . fromIntegral) (fact (order a) * fact (order b))
 58 | 
 59 | infixl 5 /\
 60 | -- | The exterior (wedge) product of two tensors. Obtains the union of subspaces.
 61 | --
 62 | --   Implemented as the antisymmetrization of the tensor product.
 63 | (/\) :: (Coord t, Fractional t)
 64 |      => Tensor t
 65 |      -> Tensor t
 66 |      -> Tensor t
 67 | a /\ b = renseq (wedge a' b')
 68 |     where a' = renseq  a
 69 |           b' = renseq' b
 70 | 
 71 | -- levi n = antisymmetrize $ product $ zipWith renameRaw ts is
 72 | --     where is = map (return.show) [1 .. n]
 73 | --           ts = map (listTensor [n]) (toLists $ ident n)
 74 | 
 75 | levi n = listTensor (replicate n n) $ map signature $ sequence (replicate n [1..n])
 76 | 
 77 | -- | The full antisymmetric tensor of order n (contravariant version).
 78 | leviCivita :: Int -> Tensor Double
 79 | leviCivita = (map levi [0..] !!)
 80 | 
 81 | infixl 4 \/
 82 | -- | The \"meet\" operator. Obtains the intersection of subspaces.
 83 | --
 84 | -- @a \\\/ b = dual (dual a \/\\ dual b)@
 85 | (\/) :: Tensor Double -> Tensor Double -> Tensor Double
 86 | a \/ b = dual (dual a /\ dual b)
 87 | 
 88 | dual' n t = inner (leviCivita n) t
 89 | 
 90 | -- | Inner product of a r-vector with the whole space.
 91 | --
 92 | -- @dual t = inner (leviCivita n) t@
 93 | dual :: Tensor Double -> Tensor Double
 94 | dual t | isScalar t = error $ "cannot deduce dimension for dual of a scalar. Use s * leviCivita n"
 95 |        | otherwise  = dual' n t
 96 |     where n = case common iDim (dims t) of
 97 |                 Just x -> x
 98 |                 Nothing -> error $ "dual with different dimensions"
 99 | 
100 | -- | Euclidean inner product of multivectors.
101 | inner :: (Coord t, Fractional t)
102 |       => Tensor t
103 |       -> Tensor t
104 |       -> Tensor t
105 | inner a b | order a < order b = switch (renseq a) * renseq b * k
106 |           | otherwise       = renseq a * switch (renseq b) * k
107 |     where k = recip . fromIntegral $ fact $ min (order a) (order b)
108 | 
109 | renseq t = renameRaw t (map show [1..order t])
110 | renseq' t = renameRaw t (map ((' ':).show) [1..order t])
111 | 
112 | isScalar = null . dims
113 | 
114 | -- | Extract a compact multivector representation from a full antisymmetric tensor.
115 | --
116 | -- asMultivector = Multivector.'fromTensor'.
117 | --
118 | -- (We do not check that the tensor is actually antisymmetric.)
119 | asMultivector :: Tensor Double -> Multivector
120 | asMultivector = fromTensor
121 | 
122 | -- | Create an explicit antisymmetric 'Tensor' from the components of a Multivector of a given grade.
123 | fromMultivector :: Int -> Multivector -> Tensor Double
124 | fromMultivector k t = sum $ map f (MV.coords $ grade k t) where
125 |     f (x,es) = scalar x * foldl1' (/\) (map g es)
126 |     n = maxDim t
127 |     g i = vector $ replicate (i-1) 0 ++ 1 : replicate (n-i) 0
128 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Multivector.hs:
--------------------------------------------------------------------------------
  1 | -----------------------------------------------------------------------------
  2 | -- |
  3 | -- Module      :  Numeric.LinearAlgebra.Multivector
  4 | -- Copyright   :  (c) Alberto Ruiz 2009
  5 | -- License     :  BSD3
  6 | -- Maintainer  :  Alberto Ruiz
  7 | -- Stability   :  experimental
  8 | --
  9 | -- A simple implementation of Geometric Algebra.
 10 | --
 11 | -- The Num instance provides the geometric product, and the Fractional
 12 | -- instance provides the inverse of multivectors.
 13 | --
 14 | -- This module provides a simple Euclidean embedding.
 15 | 
 16 | -----------------------------------------------------------------------------
 17 | 
 18 | module Numeric.LinearAlgebra.Multivector (
 19 |     Multivector, coords,
 20 |     scalar, vector, e, (/\), (-|), (\/), rever, full, rotor,
 21 |     apply,
 22 |     grade, maxGrade, maxDim,
 23 |     fromTensor
 24 | ) where
 25 | 
 26 | import Numeric.LinearAlgebra.HMatrix(toList,reshape,(<\>),atIndex)
 27 | import Numeric.LinearAlgebra.Array.Internal hiding (scalar,coords)
 28 | import Numeric.LinearAlgebra.Array.Display (showBases)
 29 | import Numeric.LinearAlgebra.Tensor hiding (scalar,vector)
 30 | import qualified Numeric.LinearAlgebra.Array.Internal as Array
 31 | import Data.List
 32 | import Control.Monad(filterM)
 33 | import Data.Function(on)
 34 | import qualified Data.Map as Map
 35 | 
 36 | powerset = filterM (const [True, False])  -- !!
 37 | 
 38 | base :: Int -> [[Int]]
 39 | base k = sortBy (compare `on` length) (powerset [1..k])
 40 | 
 41 | base' k = map (\b -> MV [(1,b)]) (base k)
 42 | 
 43 | data Multivector = MV { coords :: [(Double,[Int])] } deriving Eq
 44 | 
 45 | instance Show Multivector where
 46 |     show = showMV
 47 | 
 48 | maxGrade :: Multivector -> Int
 49 | maxGrade (MV l) = maximum . map (length.snd) $ l
 50 | 
 51 | grade :: Int -> Multivector -> Multivector
 52 | grade k (MV l) = MV $ filter ((k==).length.snd) l
 53 | 
 54 | maxDim :: Multivector -> Int
 55 | maxDim (MV [(_,[])]) = 0
 56 | maxDim (MV l) = maximum . concat . map snd $ l
 57 | 
 58 | -- | The reversion operator.
 59 | rever :: Multivector -> Multivector
 60 | rever (MV l) = MV (map r l) where
 61 |     r (c,b) = (c*fromIntegral s ,b)
 62 |         where s = signum (-1)^(k*(k-1)`div`2) :: Int
 63 |               k = length b
 64 | 
 65 | -- | Show the non zero coordinates of a multivector in a nicer format.
 66 | showMV :: Multivector -> String
 67 | showMV (MV x) = showBases x
 68 | 
 69 | -- | Creates a scalar multivector.
 70 | scalar :: Double -> Multivector
 71 | scalar s = MV [(s,[])]
 72 | 
 73 | -- | Creates a grade 1 multivector of from a list of coordinates.
 74 | vector :: [Double] -> Multivector
 75 | vector v = MV $ simplify $ zip v (map (:[]) [1..])
 76 | 
 77 | 
 78 | -- different product rules
 79 | 
 80 | -- reorders the base indices remembering the original position
 81 | r1 :: [Int] -> [(Int,[Int])]
 82 | r1 [] = []
 83 | r1 l = (m,elemIndices m l):(r1 (filter (/=m) l))
 84 |     where m = minimum l
 85 | 
 86 | -- geometric product
 87 | r2 :: [(Int, [Int])] -> (Double, [Int])
 88 | r2 = foldl' g (1,[])
 89 |     where g (k,l) (x,ps) = (k*s,l++t)
 90 |               where t = if even (length ps) then [] else [x]
 91 |                     s = product (map f ps')
 92 |                          where f z = if even z then 1 else -1
 93 |                                ps' = zipWith (subtract) ps [0..]
 94 | 
 95 | -- exterior product
 96 | r3 :: [(Int, [Int])] -> (Double, [Int])
 97 | r3 = foldl' g (1,[])
 98 |     where g (k,l) (x,ps) = (k*s,l++[x])
 99 |               where s = if length ps > 1 then 0 else if even (head ps) then 1 else -1
100 | 
101 | 
102 | -- simplification and cleaning of the list of coordinates
103 | simplify = chop . grp . sortBy (compare `on` snd)
104 |     where grp [] = []
105 |           grp [a] = [a]
106 |           grp ((c1,b1):(c2,b2):rest)
107 |               | b1 == b2  = grp ( (c1+c2,b1) : rest)
108 |               | otherwise = (c1,b1): grp ((c2,b2):rest)
109 |           zero (c,_) = abs c < 1E-8
110 |           chop = cz . filter (not.zero)
111 |           cz [] = [(0,[])]
112 |           cz x  = x
113 | 
114 | -- sum of multivectors
115 | gs (MV l1) (MV l2) = MV $ simplify (l1++l2)
116 | 
117 | -- geometric product
118 | gp (MV l1) (MV l2) = MV $ simplify [g x y | x<-l1, y <-l2]
119 |     where g (c1,b1) (c2,b2) = (k*c1*c2,b3) where (k,b3) = gpr b1 b2 --(r2.r1) (b1++b2)
120 | 
121 | -- exterior product
122 | ge (MV l1) (MV l2) = MV $ simplify [g x y | x<-l1, y <-l2]
123 |     where g (c1,b1) (c2,b2) = (k*c1*c2,b3) where (k,b3) = epr b1 b2 -- (r3.r1) (b1++b2)
124 | 
125 | -- contraction inner product
126 | gi (MV l1) (MV l2) = sum [g x y | x<-l1, y <-l2]
127 |     where g (c1,[]) (c2,is) = MV [(c1*c2,is)]
128 |           g _ (_,[])        = 0
129 | 
130 |           g (c1,[i]) (c2,[j]) = if i==j then MV [(c1*c2,[])] else 0
131 |           g (c1,[i]) (c2,j:js) = (g (c1,[i]) (c2,[j]) /\ MV [(1,js)])
132 |                                - (MV [(c2,[j])] /\ g (c1,[i]) (1,js))
133 | 
134 |           g (c1,i:is) b = gi (MV [(c1,[i])]) (gi (MV[(1,is)]) (MV [b]))
135 | 
136 | 
137 | instance Num Multivector where
138 |     (+) = gs
139 |     (*) = gp
140 |     negate (MV l) = MV (map neg l) where neg (k,b) = (-k,b)
141 |     abs _ = error "abs of multivector not yet defined"
142 |     signum _ = error "signum of multivector not yet defined"
143 |     fromInteger x = MV [(fromInteger x,[])]
144 | 
145 | instance Fractional Multivector where
146 |     fromRational x = MV [(fromRational x,[])]
147 |     recip (MV [(x,[])]) = MV [(recip x,[])]
148 |     recip x = mvrecip x
149 | 
150 | -- | The k-th basis element.
151 | e :: Int -> Multivector
152 | e k = MV [(1,[k])]
153 | 
154 | -- | The exterior (outer) product.
155 | (/\) :: Multivector -> Multivector -> Multivector
156 | infixl 7 /\
157 | (/\) = ge
158 | 
159 | 
160 | -- | The contractive inner product.
161 | (-|) :: Multivector -> Multivector -> Multivector
162 | infixl 7 -|
163 | (-|) = gi
164 | 
165 | -- | The full space of the given dimension. This is the leviCivita simbol, and the basis of the pseudoscalar.
166 | full :: Int -> Multivector
167 | full k = MV [(1,[1 .. k])] --product . map e $ [1 .. k]
168 | 
169 | -- | Intersection of subspaces.
170 | (\/) :: Multivector -> Multivector -> Multivector
171 | infixl 7 \/
172 | (\/) a b = (b -| rever (full k)) -| a
173 |     where k = max (maxDim a) (maxDim b)
174 | 
175 | -- check that it is a vector
176 | normVec v = sqrt x where MV [(x,[])] = v * v
177 | 
178 | unitary v = v / scalar (normVec v)
179 | 
180 | -- | The rotor operator, used in a sandwich product.
181 | rotor :: Int          -- ^ dimension of the space
182 |       -> Double       -- ^ angle
183 |       -> Multivector  -- ^ axis
184 |       -> Multivector  -- ^ result
185 | rotor k phi axis = scalar (cos (phi/2)) - scalar (sin (phi/2)) * (unitary axis*full k)
186 | 
187 | 
188 | -- memoization of the rules
189 | gprules k = Map.fromList [(x, Map.fromList [(y,(r2.r1)(x++y)) | y<-base k] )| x<-base k]
190 | 
191 | eprules k = Map.fromList [(x, Map.fromList [(y,(r3.r1)(x++y)) | y<-base k] )| x<-base k]
192 | 
193 | --reasonable limit
194 | gpr a b = g Map.! a Map.! b
195 |     where g = gprules 6
196 | 
197 | epr a b = g Map.! a Map.! b
198 |     where g = eprules 6
199 | 
200 | ----------------------- tensor expansion -----------------------
201 | 
202 | expand k = g
203 |     where g (MV l) = foldl1' (zipWith (+)) $ map f l
204 |           basepos b = m Map.! b
205 |           m = baseraw k
206 |           f (c,b) = en pk (basepos b) c
207 |           pk = 2^k
208 |           baseraw q = Map.fromList $ zip (base q) [0..]
209 |           en n q v = replicate q 0 ++ v : replicate (n-q-1) 0
210 | 
211 | compact k t = sum $ zipWith (*) (map scalar $ toList (Array.coords t)) (base' k)
212 | 
213 | gatensor k = listTensor [-pk,-pk,pk] (concat . concat $ gacoords)
214 |     where pk = 2^k
215 |           gacoords = [[ f (x * y) | y<-b] | x<-b]
216 |           b = base' k
217 |           f = expand k
218 | 
219 | tmv k x = listTensor [2^k] (expand k x)
220 | 
221 | 
222 | -- tp a b = comp (g!"ijk" * ta!"i" * tb!"j")
223 | --     where k = max (maxDim a) (maxDim b)
224 | --           g = gatensor k
225 | --           ta = tmv k a
226 | --           tb = tmv k b
227 | --           comp = compact k
228 | 
229 | mat rowidx t = reshape c $ Array.coords t'
230 |     where c = iDim $ last (dims t')
231 |           t' = reorder (rowidx: (namesR t\\[rowidx])) t
232 | 
233 | -- on the right
234 | pmat k b = mat "k" $ g!"ijk" * tb!"j"
235 |     where g = gatensor k
236 |           tb = tmv k b
237 | 
238 | divi k a b = compact k $ listTensor [2^k] (toList $ pmat k b <\> Array.coords (tmv k a))
239 | 
240 | mvrecip b = divi (maxDim b) 1 b
241 | 
242 | --------------------------------------------------------
243 | 
244 | -- | Extract a multivector representation from a full antisymmetric tensor.
245 | --
246 | -- (We do not check that the tensor is actually antisymmetric.)
247 | fromTensor :: Tensor Double -> Multivector
248 | fromTensor t = MV $ filter ((/=0.0).fst) $ zip vals basis
249 |     where vals = map ((`atIndex` 0). Array.coords .foldl' partF t) (map (map pred) basis)
250 |           r = length (dims t)
251 |           n = iDim . head . dims $ t
252 |           partF s i = part s (name,i) where name = iName . head . dims $ s
253 |           basis = filter (\x-> (x==nub x && x==sort x)) $ sequence $ replicate r [1..n]
254 | 
255 | part t (name,i) = parts t name !! i
256 | 
257 | --------------------------------------------------------
258 | 
259 | -- | Apply a linear transformation, expressed as the image of the element i-th of the basis.
260 | --
261 | --  (This is a monadic bind!)
262 | apply :: (Int -> Multivector) -> Multivector -> Multivector
263 | apply f t = sum $ map g (coords t) where
264 |     g (x,[]) = scalar x
265 |     g (x,es) = scalar x * foldl1' (/\) (map f es)
266 | 


--------------------------------------------------------------------------------
/lib/Numeric/LinearAlgebra/Tensor.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-}
  2 | -----------------------------------------------------------------------------
  3 | -- |
  4 | -- Module      :  Numeric.LinearAlgebra.Tensor
  5 | -- Copyright   :  (c) Alberto Ruiz 2009
  6 | -- License     :  BSD3
  7 | -- Maintainer  :  Alberto Ruiz
  8 | -- Stability   :  experimental
  9 | --
 10 | -- Tensor computations. Indices can only be contracted if they are of different 'Variant' type.
 11 | --
 12 | -----------------------------------------------------------------------------
 13 | 
 14 | 
 15 | module Numeric.LinearAlgebra.Tensor (
 16 |     -- * The Tensor type
 17 |     Tensor, Variant(..),
 18 |     listTensor,
 19 |     -- * Tensor creation utilities
 20 |     superindex, subindex,
 21 |     vector, covector, transf,
 22 |     -- * Index manipulation
 23 |     switch, cov, contrav, forget,
 24 |     -- * General array operations
 25 |     module Numeric.LinearAlgebra.Array
 26 | ) where
 27 | 
 28 | import Numeric.LinearAlgebra.Array.Internal
 29 | import Numeric.LinearAlgebra.HMatrix hiding (vector)
 30 | import Numeric.LinearAlgebra.Array
 31 | import Data.List(intersperse)
 32 | 
 33 | type Tensor t = NArray Variant t
 34 | 
 35 | data Variant = Contra | Co deriving (Eq,Show)
 36 | 
 37 | instance Compat Variant where
 38 |     compat d1 d2 = iDim d1 == iDim d2 && iType d1 /= iType d2
 39 |     opos (Idx x n s) = Idx (flipV x) n s
 40 | 
 41 | instance Show (Idx Variant) where
 42 |     show (Idx Co n s)     = s ++ "_" ++ show n
 43 |     show (Idx Contra n s) = s ++ "^" ++ show n
 44 | 
 45 | instance (Coord t) => Show (Tensor t) where
 46 |     show t | null (dims t) = "scalar "++ show (coords t `atIndex` 0)
 47 |            | order t == 1 = ixn ++ show n ++" " ++ (show . toList . coords $ t)
 48 |            | otherwise = ixn ++ show n ++ " [" ++ ps ++ "]"
 49 |       where n = head (namesR t)
 50 |             ps = concat $ intersperse ", " $ map show (parts t n)
 51 |             ixn = idxn (typeOf n t)
 52 |             idxn Co     = "subindex "
 53 |             idxn Contra = "superindex "
 54 | 
 55 | 
 56 | flipV Co = Contra
 57 | flipV Contra = Co
 58 | 
 59 | -- | Creates a tensor from a list of dimensions and a list of coordinates.
 60 | -- A positive dimension means that the index is assumed to be contravariant (vector-like), and
 61 | -- a negative dimension means that the index is assumed to be covariant (like a linear function, or covector). Contractions can only be performed between indices of different type.
 62 | listTensor :: Coord t
 63 |            => [Int] -- ^ dimensions
 64 |            -> [t]   -- ^ coordinates
 65 |            -> Tensor t
 66 | listTensor ds cs = mkNArray dms (product ds' |> (cs ++ repeat 0))
 67 |     where dms = zipWith3 Idx (map f ds) ds' (map show [1::Int ..])
 68 |           ds' = map abs ds
 69 |           f n | n>0       = Contra
 70 |               | otherwise = Co
 71 | 
 72 | -- | Create an 'Tensor' from a list of parts with a contravariant index (@superindex = 'newIndex' 'Contra'@).
 73 | superindex :: Coord t => Name -> [Tensor t] -> Tensor t
 74 | superindex = newIndex Contra
 75 | 
 76 | -- | Create an 'Tensor' from a list of parts with a covariant index (@subindex = 'newIndex' 'Co'@).
 77 | subindex :: Coord t => Name -> [Tensor t] -> Tensor t
 78 | subindex   = newIndex Co
 79 | 
 80 | 
 81 | 
 82 | -- | Change the 'Variant' nature of all dimensions to the opposite ones.
 83 | switch :: Tensor t -> Tensor t
 84 | switch = mapTypes flipV
 85 | 
 86 | -- | Make all dimensions covariant.
 87 | cov :: NArray i t -> Tensor t
 88 | cov     = mapTypes (const Co)
 89 | 
 90 | -- | Make all dimensions contravariant.
 91 | contrav :: NArray i t -> Tensor t
 92 | contrav = mapTypes (const Contra)
 93 | 
 94 | -- | Remove the 'Variant' nature of coordinates.
 95 | forget :: NArray i t -> Array t
 96 | forget = mapTypes (const None)
 97 | 
 98 | --------------------------------------------------------------
 99 | 
100 | -- | Create a contravariant 1st order tensor from a list of coordinates.
101 | vector :: [Double] -> Tensor Double
102 | vector   = fromVector Contra . fromList
103 | 
104 | -- | Create a covariant 1st order tensor from a list of coordinates.
105 | covector :: [Double] -> Tensor Double
106 | covector = fromVector Co . fromList
107 | 
108 | -- | Create a 1-contravariant, 1-covariant 2nd order from list of lists of coordinates.
109 | transf :: [[Double]] -> Tensor Double
110 | transf   = fromMatrix Contra Co . fromLists
111 | 


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