mat.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
-------------------------> GNU Sather - sourcefile <-------------------------
-- Copyright (C) 2000 by K Hopper, University of Waikato, New Zealand --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute and/or modify it under the terms of the GNU Library General --
-- Public License (LGPL) as published by the Free Software Foundation; --
-- either version 2 of the license, or (at your option) any later version. --
-- This library is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details. --
-- The license text is also available from: Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --
--------------> Please email comments to <bug-sather@gnu.org> <--------------
class MAT{ET < $NFE{ET}, VT < $VEC{ET,VT}} < $MAT{ET,VT,MAT{ET,VT}}
class MAT{ET < $NFE{ET}, VT < $VEC{ET,VT}} < $MAT{ET,VT,MAT{ET,VT}} is
-- This class is an implementation of the generic dense concrete
-- matrix. It arranges elements in Column-Major order as do standard Fortran
-- libraries -- thus the first index changes most rapidly when stepping
-- through storage.
--
-- Implementation tends to use extra index variabless to avoid integer
-- multiplication inside the loop. Local variables rather than attributes
-- are used in loops.
-- Version 1.1 Aug 97. Copyright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 8 Jul 96 mbk Original for 1.1 Dist
-- 8 Aug 97 kh Original from Sather 1.1 Dist
-- 22 Mar 01 djw _Major_ rewrite!
private include AREF{ET}
aclear -> aclear,
aget -> aget,
aset -> aset ;
readonly attr nr : CARD ; -- number of rows
readonly attr nc : CARD ; -- number of columns
create(
rows,
cols : CARD
) : SAME
pre (rows > 0)
and (cols > 0) is
-- This routine creates an empty matrix with the given number of rows
-- and columns.
me : SAME := new(rows * cols) ;
me.nr := rows ;
me.nc := cols ;
return me
end ;
create(
arg : SAME
) : SAME
pre ~void(arg) is
-- This routine creates a new matrix with the same dimensions as arg but
-- not its contents -- ie an empty matrix.
me : SAME := new(arg.asize) ;
me.nr := arg.nr ;
me.nc := arg.nc ;
return me
end ;
create(
arry : ARRAY{ARRAY{ET}}
) : SAME
pre (arry.size > 0)
and (arry[0].size > 0) is
-- This creation routine produces a new matrix from the contents of the
-- parameter, presuming that all of the rows of the array have an equal
-- number of elements.
sz1 : CARD := arry.size ;
sz2 : CARD := arry[0].size ;
me : SAME := create(sz1,sz2) ;
loop
row : CARD := sz1.times! ;
loop
col : CARD := sz2.times! ;
me[row,col] := arry[row][col]
end
end ;
return me
end ;
size : CARD is
-- This routine returns the total number of elements in the matrix.
return asize
end ;
size1 : CARD is
-- This routine returns the number of rows in the matrix.
return nr
end ;
rows : CARD is
-- This routine returns the number of rows in the matrix. It is a
-- synonym for size1.
return nr
end ;
size2 : CARD is
-- This routine returns the number of columns in the matrix.
return nc
end ;
columns : CARD is
-- This routine returns the number of columns in the matrix. It is a
-- synonym for size2.
return nc
end ;
-- NOTE The following two routines should really be features in the
-- class ET < $RING_ELT, where $RING_ELT gives additive and
-- multiplicative identity.
element_zero : ET is
-- This routine returns an element of value zero.
return ET::zero
end ;
element_one : ET is
-- This routine returns an element of unit value.
return ET::one
end ;
inplace(
elem : ET
) is
-- This routine sets all of the elements of self to have the given value.
loop
aset!(elem)
end
end ;
inplace_zero is
-- This routine sets all elements of self to be zero.
inplace(element_zero)
end ;
ident : SAME is
-- This routine creates and returns an identity matrix of the same shape
-- as self. If this is non-square then the remainder of the rows or columns
-- are not altered.
res : SAME := create(self) ; -- all elements zero!
diagonal_size : CARD := nc.min(nr) ;
index : CARD := 0 ;
loop
index := 0.upto!(nc.min(nr) - 1) ;
res[index,index] := element_one
end ;
return res
end ;
inplace_ident is
-- This routine sets the contents of self to be an identity matrix.
-- Where the matrix is not square then remaining non-diagonal rows or columns
-- are set to zero.
row : CARD := 0 ;
column : CARD := 0 ;
loop row:=row_ind!;
loop column:=col_ind!;
if (row=column) then
[row,column]:=element_one;
else
[row,column]:=element_zero;
end;
end;
end;
end ;
is_same_shape(
other : SAME
) : BOOL is
-- This routine returns true if and only if self and other are matrices
-- of the same number of rows and columns.
if void(other)
or void(self) then
return false
elsif (other.asize /= asize)
or (other.nr /= nr) then
return false
else
return true
end
end ;
inplace_contents(
arg : SAME
)
pre is_same_shape(arg) is
-- This routine copies the contents of arg (which must be of the same
-- shape as self) into self.
loop
index : CARD := 0.upto!(asize - 1) ;
self[index] := arg[index]
end
end ;
copy : SAME is
-- This routine makes and returns an identical copy of self.
res : SAME := create(self) ;
res.inplace_contents(self) ;
return res
end ;
contents(
mat : SAME
) is
-- This routine alters the contents of self to be the given values.
inplace_contents(mat)
end ;
is_eq(
other : SAME
) : BOOL
pre ~void(self)
and ~void(other)
and is_same_shape(other) is
-- This routine returns true if and only if the shape of self and other
-- is the same and corresponding elements are equal.
loop
if elt! /= other.elt! then
return false
end
end ;
return true
end ;
is_same_shape_trans(
other : SAME
) : BOOL is
-- This routine returns true if and only if self and the transpose of
-- other are the same shape.
if void(other)
or void(self) then
return false
elsif (other.asize /= asize)
or (other.nr /= nc) then
return false
else
return true
end
end ;
fits(
other : SAME
) : BOOL is
-- This routine returns true if and only if other will fit into self
-- without transposition.
if void(other)
or void(self)
or (other.asize /= asize) then
return false
else
return true
end
end ;
reshape(
rows,
cols : CARD
)
pre (rows * cols) = asize is
-- This routine reshapes self to have the given number of rows and
-- columns without altering the contents. Elements will therefore appear
-- to move.
--
-- NOTE This feature is not in the abstract class since it is representation
-- dependent.
nc := cols ;
nr := rows
end ;
inplace_contents_from_function(
function : ROUT{CARD,CARD} : ET
) is
-- This routine alters the contents of self, setting each element to be
-- the result of passing its row and column number to the argument function.
loop
column : CARD := col_ind! ;
loop
row : CARD := row_ind! ;
[column,row] := function.call(column,row)
end
end
end ;
inplace_portion_of_arg(
mat : SAME
) is
-- This routine copies into self as much of mat as will fit. If the
-- total number of elements in mat is less than self then the remaining
-- elements of self are unaltered.
rows : CARD := nr.min(mat.nr) ;
loop
row : CARD := rows.times! ;
loop
set_row!(row,mat.row_elt!(row))
end
end
end ;
trans : SAME is
-- This routine creates and returns a matrix which is the transpose of
-- self.
loc_cols : CARD := nc ;
trans_index : CARD := 0 ;
loc_size : CARD := asize ;
res : SAME := create(loc_cols, nr) ;
loop
index : CARD := 0.upto!(asize - 1) ;
res[trans_index] := self[index] ;
trans_index := trans_index + loc_cols ;
if trans_index >= loc_size then
trans_index := trans_index - loc_size + 1
end
end ;
return res
end ;
inplace_trans is
-- This routine carries out an in-place transposition of self, using
-- self if possible, otherwise making use of a temporary matrix to effect
-- the transposition.
if (nr = nc) then -- can be done in place!
loc_size : CARD := asize ;
loc_rows : CARD := nr ;
index : CARD := 1 ;
trans_index : CARD := loc_rows ;
diag_index : CARD := 0 ;
loop
while!(index < loc_size) ;
tmp : ET := [trans_index] ; -- 'flip' element and its transpose
[trans_index] := [index] ;
[index] := tmp ;
trans_index := trans_index + loc_rows ;
index := index + 1 ;
if trans_index >= loc_size then
diag_index := diag_index + loc_rows + 1 ;
index := diag_index + 1 ;
trans_index := trans_index + loc_rows
end
end
else -- need a temporary!
tmp : SAME := self.trans ;
self.nc := tmp.nc ;
self.nr := tmp.nr ;
self.inplace_contents(tmp)
end
end ;
inplace_arg_trans(
mat : SAME
)
pre fits(mat) is
-- This routine sets self to be the transpose of mat.
loc_size : CARD := asize ;
loc_cols : CARD := mat.nc ;
trans_index : CARD := 0 ;
nc := mat.nr ;
nr := loc_cols ;
loop
index : CARD := 0.upto!(loc_size - 1) ;
self[trans_index] := mat[index] ;
trans_index := trans_index + loc_cols ;
if trans_index >= loc_size then
trans_index := trans_index + trans_index - loc_size + 1
end
end
end ;
scaled_by(
factor : ET
) : SAME is
-- This routine creates a new matrix of the same shape as self and sets
-- all of its elements to be the product of the corresponding element in self
-- and factor.
res : SAME := create(self) ;
loop i : TUP{CARD,CARD} := res.inds!;
res.aset(i.t1,i.t2,self.elt! * factor)
end ;
return res
end ;
times_elt(
scale_factor : ET
) : SAME is
-- This routine is a synonym for scaled_by.
return scaled_by(scale_factor)
end ;
inplace_scaled_by(
factor : ET
) is
-- This routine scales self by the given factor.
loop i : TUP{CARD,CARD} := inds!;
aset(i.t1,i.t2,factor * elt!)
end
end ;
inplace_elements(
val : ET
) is
-- This routine sets all elements of self to the given value.
loop i : TUP{CARD,CARD} := inds!;
aset(i.t1,i.t2,val)
end
end ;
aget(
row,
col : CARD
) : ET
pre (row <= nr)
and (col <= nc) is
-- This routine is the row/column version of aget.
return [row + col * nr]
end ;
aset(
row,
col : CARD,
val : ET)
pre (row <= nr)
and (col <= nc) is
-- This routine is the row/column version of aset.
[row + col * nr] := val
end ;
inplace_arg_plus_arg(
arg1,
arg2 : SAME
)
pre is_same_shape(arg1)
and arg1.is_same_shape(arg2) is
-- This routine sets self to be the sum of the two argument matrices
-- provided that they satisfy the pre-condition of all being the same shape.
loop
aset!(arg1.elt! + arg2.elt!)
end
end ;
inplace_arg_plus_scaled_arg(
arg1 : SAME,
scale : ET,
arg2 : SAME
)
pre is_same_shape(arg1)
and arg1.is_same_shape(arg2) is
-- This routine sets self to have the result of adding arg1 to the
-- scaled value of arg2 element by element.
loop
aset!(arg1.elt! + scale * arg2.elt!)
end
end ;
inplace_arg_plus_arg_trans(
arg1,
arg2 : SAME
)
pre fits(arg1)
and arg1.is_same_shape_trans(arg2)
and ~SYS::ob_eq(self,arg2) is
-- This routine sets self to have the result of adding the transpose of
-- arg2 to arg1, element by element.
local_cols : CARD := arg1.nc ;
loc_size : CARD := asize ;
trans_index : CARD := 0 ;
nc := local_cols ;
nr := arg1.nr ;
loop
aset!(arg1.elt! + arg2[trans_index]) ;
trans_index := trans_index + local_cols ;
if trans_index > loc_size then
trans_index := (trans_index + 1) - loc_size
end
end
end ;
inplace_arg_trans_plus_arg_trans(
arg1,
arg2 : SAME
)
pre fits(arg1)
and arg1.is_same_shape(arg2)
and ~SYS::ob_eq(self,arg1)
and ~SYS::ob_eq(self,arg2) is
-- This routine sets self to be the sum of the transposes of arg1 and
-- arg2 element by element.
loc_cols : CARD := arg1.nc ;
loc_size : CARD := asize ;
trans_index : CARD := 0 ;
nr := loc_cols ;
nc := arg1.nr ;
loop
[trans_index] := arg1.elt! + arg2.elt! ;
trans_index := trans_index + loc_cols ;
if trans_index >= loc_size then
trans_index := (trans_index + 1) - loc_size
end
end
end ;
inplace_arg_plus_scaled_arg_trans(
arg1 : SAME,
scale : ET,
arg2 : SAME
)
pre fits(arg1)
and arg1.is_same_shape_trans(arg2)
and ~SYS::ob_eq(self,arg2) is
-- This routine sets self to be the result of adding arg1 to the scaled
-- value of the corresponding element of the transpose of arg2, element by
-- element.
local_cols : CARD := arg1.nc ;
loc_size : CARD := asize ;
trans_index : CARD := 0 ;
nc := local_cols ;
nr := arg1.nr ;
loop
aset!(arg1.elt! + scale * arg2[trans_index]) ;
trans_index := trans_index + local_cols ;
if trans_index > loc_size then
trans_index := (trans_index + 1) - loc_size
end
end
end ;
inplace_plus_arg(
other : SAME
)
pre is_same_shape(other) is
-- This routine adds the contents of the other matrix to self component
-- by component.
self.inplace_arg_plus_arg(self,other)
end ;
inplace_plus_scaled_arg(
scale : ET,
other : SAME) is
-- This routine sets self to have the result of adding self to the
-- scaled value of the corresponding element of other.
self.inplace_arg_plus_scaled_arg(self,scale,other)
end ;
inplace_plus_arg_trans(
other : SAME
)
pre is_same_shape_trans(other) is
-- This routine sets self to have the result of adding self to the
-- value of the corresponding element of other transposed.
self.inplace_arg_plus_arg_trans(self,other)
end ;
inplace_plus_scaled_arg_trans(
scale : ET,
other : SAME
) is
-- This routine sets self to have the result of adding self to the
-- scaled value of the corresponding element of other transposed.
self.inplace_arg_plus_scaled_arg_trans(self,scale,other)
end ;
plus_arg(
other : SAME
) : SAME
pre is_same_shape(other)
is
-- This routine returns a new array which contains elements which are
-- the sum of corresponding elements of self and other.
res : SAME := create(self) ;
res.inplace_arg_plus_arg(self,other) ;
return res
end ;
plus_scaled_arg(
scale : ET,
other : SAME
) : SAME is
-- This routine returns a new array which contains elements which are
-- the sum of self and the scaled value of the corresponding element of other.
res : SAME := create(self) ;
res.inplace_arg_plus_scaled_arg(self,scale,other) ;
return res
end ;
plus_arg_trans(
other : SAME
) : SAME
pre is_same_shape_trans(other) is
-- This routine returns a new array which contains elements which are
-- the sum of self and the value of the corresponding element of other
-- transposed.
res : SAME := create(self) ;
res.inplace_arg_plus_arg_trans(self,other) ;
return res
end ;
plus_scaled_arg_trans(
scale : ET,
other : SAME
) : SAME is
-- This routine returns a new array which contains elements which are
-- the sum of self and the scaled value of the corresponding element of other
-- transposed.
res : SAME := create(self) ;
res.inplace_arg_plus_scaled_arg_trans(self,scale,other) ;
return res
end ;
plus(
other : SAME
) : SAME is
-- This outine returns a new matrix which is the sum of self and other.
return plus_arg(other)
end ;
inplace_arg_minus_arg(
arg1,
arg2 : SAME
)
pre is_same_shape(arg1)
and arg1.is_same_shape(arg2) is
-- This routine sets self to be the difference between arg1 and arg2,
-- providing that all three are of the same shape!
loop
aset!(arg1.elt! - arg2.elt!)
end
end ;
inplace_arg_minus_arg_trans(
arg1,
arg2 : SAME
)
pre fits(arg1)
and arg1.is_same_shape_trans(arg2)
and ~SYS::ob_eq(self,arg2) is
-- This routine sets self to have the result of subtracting the value of
-- the corresponding element of the transpose of arg2, element by element.
local_cols : CARD := arg1.nc ;
loc_size : CARD := asize ;
trans_index : CARD := 0 ;
nc := local_cols ;
nr := arg1.nr ;
loop
aset!(arg1.elt! - arg2[trans_index]) ;
trans_index := trans_index + local_cols ;
if trans_index > loc_size then
trans_index := (trans_index + 1) - loc_size
end
end
end ;
inplace_arg_trans_minus_arg_trans(
arg1,
arg2 : SAME
)
pre fits(arg1)
and arg1.is_same_shape(arg2)
and ~SYS::ob_eq(self,arg1)
and ~SYS::ob_eq(self,arg2) is
-- This routine sets self to be the difference of the transposes of arg1
-- and arg2 element by element.
loc_cols : CARD := arg1.nc ;
loc_size : CARD := asize ;
trans_index : CARD := 0 ;
nr := loc_cols ;
nc := arg1.nr ;
loop
[trans_index] := arg1.elt! - arg2.elt! ;
trans_index := trans_index + loc_cols ;
if trans_index >= loc_size then
trans_index := (trans_index + 1) - loc_size
end
end
end ;
inplace_minus_arg(
other : SAME
)
pre is_same_shape(other) is
-- This routine sets self to be the matrix produced by subtracting other
-- from self component by component.
self.inplace_arg_minus_arg(self,other)
end ;
inplace_minus_arg_trans(
other : SAME
)
pre is_same_shape_trans(other) is
-- This routine sets self to be the matrix produced bt subtracting the
-- transpose of other from self component by component.
self.inplace_arg_minus_arg_trans(self,other)
end ;
minus_arg(
other : SAME
) : SAME
pre is_same_shape(other) is
-- This routine returns the result of subtracting other from self,
-- component by component.
res : SAME := create(self) ;
res.inplace_arg_minus_arg(self,other) ;
return res
end ;
minus_arg_trans(
other : SAME
) : SAME
pre is_same_shape_trans(other) is
-- This routine returns the result of subtracting the transpose of other
-- from self, component by component.
res : SAME := create(self) ;
res.inplace_arg_minus_arg_trans(self,other) ;
return res
end ;
minus(
other : SAME
) : SAME is
-- This routine returns the result of subtracting other from self
-- componenet by component.
return minus_arg(other)
end ;
inplace_arg_times_arg(
arg1,
arg2 : SAME
)
pre nr = arg1.nr
and nc = arg2.nc
and arg1.nc = arg2.nr
is
-- This routine sets self to have the result of the matrix product of
-- arg1 and arg2 --
loop i : CARD := col_ind! ;
inplace_col(i,arg1.times_vec(arg2.col(i))) ;
end ;
end ;
inplace_arg_trans_times_arg(
arg1,
arg2 : SAME
)
pre nr = arg1.nc
and nc = arg2.nc
and arg1.nr = arg2.nr is
-- This routine sets self to have the result of the matrix product of
-- the transpose of arg1 with arg2 --
loop i : CARD := col_ind! ;
inplace_col(i,arg1.trans_times_vec(arg2.col(i))) ;
end ;
end ;
inplace_arg_times_arg_trans(
arg1,
arg2 : SAME
)
pre nr = arg1.nc
and nc = arg2.nc
and arg1.nr = arg2.nr is
-- This routine sets self to have the result of the matrix product of
-- arg1 with the transpose of arg2 --
--
-- For all i,j, self[i,j] = sum(k) arg1[i,k] * arg2[j,k]
loc_rows : CARD := nr ;
loc_cols : CARD := nc ;
arg1_cols : CARD := arg2.nc ;
arg1_rows : CARD := arg1.nr ;
arg2_rows : CARD := arg2.nr ;
loop
outer : CARD := 0.upto!(loc_rows - 1) ;
loop
inner : CARD := 0.upto!(loc_cols - 1) ;
sum : ET := element_zero ;
loop
sum := sum + arg1.aelt!(outer,arg1_cols,arg1_rows.int) +
arg2.aelt!(inner,arg1_cols,arg2_rows.int)
end ;
[outer + inner * loc_rows] := sum
end
end
end ;
inplace_arg_trans_times_arg_trans(
arg1,
arg2 : SAME
)
pre nr = arg1.nc
and nc = arg2.nc
and arg1.nr = arg2.nr is
-- This routine sets self to have the result of the matrix product of
-- the transpose of arg1 with the transpose of arg2 --
--
-- For all i,j, self[i,j] = sum(k) arg1[k,i] * arg2[j,k]
loc_rows : CARD := nr ;
loc_cols : CARD := nc ;
arg1_cols : CARD := arg2.nc ;
arg1_rows : CARD := arg1.nr ;
arg2_rows : CARD := arg2.nr ;
arg1_index : CARD := 0 ;
loop
outer : CARD := 0.upto!(loc_rows - 1) ;
loop
inner : CARD := 0.upto!(loc_cols - 1) ;
sum : ET := element_zero ;
arg1_index := outer * arg1_rows ;
loop
sum := sum + arg1.aelt!(arg1_index,arg1_rows) +
arg2.aelt!(inner,arg1_rows,arg2_rows.int)
end ;
[outer + inner * loc_rows] := sum
end
end
end ;
trans_times_arg(
other : SAME
) : SAME
pre nr = other.nr is
-- This routine returns a new matrix which is the product of the
-- transpose of self with other.
res : SAME := create(nc,other.nc) ;
res.inplace_arg_trans_times_arg(self,other) ;
return res
end ;
times_arg_trans(
other : SAME
) : SAME
pre nc = other.nc is
-- This routine returns a new matrix which is the product of self with
-- the transpose of other.
res : SAME := create(nr,other.nr) ;
res.inplace_arg_times_arg_trans(self,other) ;
return res
end ;
trans_times_arg_trans(
other : SAME
) : SAME
pre nr = other.nc is
-- This routine returns a new matrix which is aproduct of the transpose
-- of self with the transpose of other.
res : SAME := create(nc,other.nr) ;
res.inplace_arg_trans_times_arg_trans(self,other) ;
return res
end ;
times(
other : SAME
) : SAME
pre nc = other.nr is
-- This routine carries out a standard matrix multiplication operation.
res : SAME := create(nr,other.nc) ;
res.inplace_arg_times_arg(self,other) ;
return res
end ;
-- MATRIX/VECTOR operations, manipulations
inplace_times_diagonal(
vect : VT
) is
-- This routine sets self to be the product of itself with a diagonal
-- matrix whose entries are the components of vect which may be either
-- truncated or extended with zeroes if needed to make it of the correct size.
-- The result of this is that self is scaled by the elements of vect.
column : CARD ;
loop
column := nc.min(vect.dim).times! ;
loop
set_col!(column,vect[column] * col_elt!(column))
end
end ;
loop
column := vect.dim.upto!(nc - 1) ;
loop
set_col!(column,ET::zero)
end
end
end ;
inplace_plus_scaled_vec_times_vec(
scale : ET,
vect1,
vect2 : VT
)
pre vect1.dim = nr
and vect2.dim = nc is
-- This routine sets self to be the scaled result of the outer product
-- of vect1 and vect2.
loc_rows : CARD := nr ;
loc_cols : CARD := nc ;
loop
outer : CARD := 0.upto!(loc_cols - 1) ;
loop
inner : CARD := 0.upto!(loc_rows - 1) ;
[inner,outer] := [inner,outer] +
scale * vect1[inner] * vect2[outer]
end
end
end ;
times_vec_into_vec(
vect,
dest : VT
)
pre vect.dim = self.nc
and dest.dim = self.nr is
-- This routine sets the destination vector to have the result of the
-- vector product of self and other.
loop
dest.aset!(row(row_ind!).dot(vect)) ;
end ;
end ;
trans_times_vec_into_vec(
arg,
dest : VT
)
pre arg.dim = self.nr
and dest.dim = self.nc is
-- This routine sets the destination vector to have the result of the
-- vector product of the transpose of self and other.
loop
dest.aset!(col(col_ind!).dot(arg))
end
end ;
times_scaled_vec_into_vec(
scale : ET,
vect,
dest : VT
)
pre vect.dim = self.nc
and dest.dim = self.nr is
-- This routine sets the destination vector to have the result of the
-- vector product of self and other.
loop
dest.aset!(scale * row(row_ind!).dot(vect))
end
end ;
trans_times_scaled_vec_into_vec(
scale : ET,
arg,
dest : VT
)
pre arg.dim = self.nr
and dest.dim = self.nc is
-- This routine sets the destination vector to have the result of the
-- scaled vector product of the transpose of self and other.
loop
dest.aset!(scale * col(col_ind!).dot(arg))
end
end ;
times_vec(
vect : VT
) : VT
pre vect.dim = self.nc is
-- This is a 'syntactic sugar' expression for the vector product of self
-- and vect, which is returned.
res : VT := VT::create(nr) ;
times_vec_into_vec(vect,res) ;
return res
end ;
trans_times_vec(
vect : VT
) : VT
pre vect.dim = self.nr is
-- This routine is syntactic 'sugar' for the vector product of the
-- transpose of self and vect.
res : VT := VT::create(nc) ;
trans_times_vec_into_vec(vect,res) ;
return res
end ;
create_col_matrix(
vect : VT
) : SAME is
-- This routine creates a single column matrix from the given vector.
res : SAME := create(vect.dim,1) ;
loop
res.aset!(vect.elt!)
end ;
return res
end ;
create_row_matrix(
vect : VT
) : SAME is
-- This routine is the row counterpart of the above -- creating a single
-- row matrix.
res : SAME := create(1,vect.dim) ;
loop
res.aset!(vect.elt!)
end ;
return res
end ;
col(
num : CARD
) : VT is
-- This routine returns the vector which is the indicated column of self.
res : VT := VT::create(nr) ;
loop
index : CARD := row_ind! ;
res[index] := [index,num]
end ;
return res
end ;
row(
num : CARD
) : VT is
-- This routine returns the vector which is the indicated row of self.
res : VT := VT::create(nc) ;
loop
index : CARD := col_ind! ;
res[index] := [num,index]
end ;
return res
end ;
col(
num : CARD,
vect : VT
)
pre vect.dim = nc is
-- Provided that it is of the correct length the indicated column of
-- self is given the contents of vect.
loop
index : CARD := 0.upto!(vect.dim - 1) ;
[index,num] := vect.elt!
end
end ;
row(
num : CARD,
vect : VT
)
pre vect.dim = nr is
-- Provided that it is of the correct length the indicated row of
-- self is given the contents of vect.
loop
index : CARD := 0.upto!(vect.dim - 1) ;
[num,index] := vect.elt!
end
end ;
inplace_scaled_col(
scale : ET,
num : CARD
)
pre num < nc is
-- This routine scales the indicated column of self by the given scale
-- factor.
loop
index : CARD := 0.upto!(nc - 1) ;
[index,num] := [index,num] * scale
end
end ;
inplace_scaled_row(
scale : ET,
num : CARD
)
pre num < nr is
-- This routine scales the indicated row of self by the given scale
-- factor.
loop
index : CARD := 0.upto!(nc - 1) ;
[num,index] := [num,index] * scale
end
end ;
inplace_col_plus_scaled_vec(
row : CARD,
scale : ET,
vect : VT
)
pre row < nc
and vect.dim = nr is
-- This routine scales the indicated row of self by the given scale
-- factor.
loop
index : CARD := 0.upto!(nc - 1) ;
[index,row] := [index,row] + vect.elt! * scale
end
end ;
inplace_row(
row : CARD,
vect : VT
)
pre row < nr
and vect.dim = nc is
-- This routine sets the indicated row of self to have the contents of
-- the given vector.
loop
index : CARD := 0.upto!(nc - 1) ;
[row,index] := vect.elt!
end
end ;
inplace_col(
col : CARD,
vect : VT
)
pre col < nr
and vect.dim = nr is
-- This routine sets the indicated col of self to have the contents of
-- the given vector.
loop
index : CARD := row_ind! ;
[index,col] := vect.elt! ;
end
end ;
inplace_row_plus_scaled_vec(
row : CARD,
scale : ET,
vect : VT
)
pre row < nc
and vect.dim = nr is
-- This routine adds the scaled elements of vect to the indicated row
-- of self.
loop
index : CARD := 0.upto!(nc - 1) ;
[row,index] := [row,index] + vect.elt! * scale
end
end ;
inplace_swapped_col(
col : CARD,
vect : VT
)
pre col < nc
and vect.dim = nr is
-- This routine swaps the contents of the indicated column with the given
-- vector.
loop
index : CARD := 0.upto!(nc - 1) ;
temp : ET := [col,index] ;
[col,index] := vect[index] ;
vect[index] := temp
end
end ;
inplace_swapped_row(
row : CARD,
vect : VT
)
pre row < nr
and vect.dim = nc is
-- This routine swaps the contents of the indicated row with the given
-- vector.
loop
index : CARD := 0.upto!(nc - 1) ;
temp : ET := [index,row] ;
[index,row] := vect[index] ;
vect[index] := temp
end
end ;
inplace_swapped(
other : SAME
)
pre is_same_shape(other) is
-- This routine swaps the contents of the indicated row with the given
-- vector.
loop
temp : ET := aelt! ;
aset!(other.aelt!) ;
other.aset!(temp)
end
end ;
inplace_submatrix_to_arg(
low_row,
high_row : CARD,
low_col,
high_col : CARD,
other : SAME
)
pre low_row <= high_row
and high_row < nr
and low_col <= high_col
and high_col < nc
and other.nr = high_row - low_row + 1
and other.nc = high_col - low_col + 1 is
-- This routine sets the sub-matrix of self indicated by the 'corner'
-- indices, to have the values given by the corresponding elements of other.
loc_rows : CARD := other.nr ;
loop
outer : CARD := 0.upto!(other.nc) ;
loop
inner : CARD := 0.upto!(loc_rows - 1) ;
[inner + low_row, outer + low_col] := other.elt!
end
end
end ;
submatrix(
low_row,
high_row : CARD,
low_col,
high_col : CARD
) : SAME
pre low_row <= high_row
and high_row < nr
and low_col <= high_col
and high_col < nc is
-- This routine returns the sub-matrix of self indicated by the 'corner'
-- indices.
rows : CARD := high_row - low_row + 1 ;
cols : CARD := high_col - low_col + 1 ;
res : SAME := create(rows,cols) ;
loop
outer : CARD := 0.upto!(cols - 1) ;
loop
inner : CARD := 0.upto!(rows - 1) ;
res[inner,outer] := [inner + low_row, outer + low_col]
end
end ;
return res
end ;
-- Matrix iters!
ind1! : CARD is
-- This iter yields each of the values of the first index (row numbers)
-- of the matrix in order.
loop
yield(size1.times!)
end
end ;
row_ind! : CARD is
-- This iter yields each of the values of the first index (row numbers)
-- of the matrix in order. It is a synonym for the above.
loop
yield(size1.times!)
end
end ;
ind2! : CARD is
-- This iter yields each of the values of the second index (column
-- numbers) of the matrix in order.
loop
yield(size2.times!)
end
end ;
col_ind! : CARD is
-- This iter yields each of the values of the second index (column
-- numbers) of the matrix in order. It is a synonym for the above.
loop
yield(size2.times!)
end
end ;
inds! :TUP{CARD,CARD} is
-- This iter yields pairs of indices of self in row major order.
loop
row : CARD := size1.times! ;
loop
yield(TUP{CARD,CARD}::create(row,size2.times!))
end
end
end ;
elt! : ET
pre ~void(self) is
-- This iter yields all of the elements of self in row major order.
loop
yield(aelt!)
end
end ;
inplace_elt!(
val : ET
) is
-- This iter enables its caller to set the elements of self to the given
-- argument (evaluated on each entry!).
loop
aset!(val) ;
yield
end
end ;
row_elt!(
once row : CARD
) : ET
pre ~void(self) is
-- This iter yields all of the elements in the indicated row of self in
-- order.
loop
yield(aelt!(row,size2,size1.int))
end
end ;
elt1!(
once row : CARD
) : ET
pre ~void(self) is
-- This iter yields all of the elements in the indicated row of self in
-- order. It is a synonym for the above.
loop
yield(aelt!(row,size2,size1.int))
end
end ;
col_elt!(
once col : CARD
) : ET
pre ~void(self) is
-- This iter yields all of the elements of the indicated column in turn.
loop
yield(aelt!(col * size1,size1,1.int))
end
end ;
elt2!(
once col : CARD
) : ET
pre ~void(self) is
-- This iter yields all of the elements of the indicated column in turn.
-- It is a synonym for the one above.
loop
yield(aelt!(col * size1,size1,1.int))
end
end ;
set_row!(
once row : CARD,
val : ET
)
pre ~void(self) is
-- This iter yields permits each of the elements of the indicated row to
-- be set in turn.
loop
aset!(row,size2,size1.int,val) ;
yield
end
end ;
inplace_row!(
once row : CARD,
val : ET
)
pre ~void(self) is
-- This iter permits each of the elements of the indicated row to
-- be set in turn. It is a synonym for set_row!
loop
aset!(row,size2,size1.int,val) ;
yield
end
end ;
set1!(
once row : CARD,
val : ET
)
pre ~void(self) is
-- This iter permits each of the elements of the indicated row to
-- be set in turn. It is a synonym for set_row!
loop
aset!(row,size2,size1.int,val) ;
yield
end
end ;
set_col!(
once col : CARD,
val : ET
)
pre ~void(self) is
-- This iter enables each entry in a given column of self to be set in
-- turn.
loop
aset!(col * size1,size1,val) ;
yield
end
end ;
inplace_col!(
once col : CARD,
val : ET
)
pre ~void(self) is
-- This iter enables each entry in a given column of self to be set in
-- turn. It is a synonym for set_col!
loop
aset!(col * size1,size1,val) ;
yield
end
end ;
set2!(
once col : CARD,
val : ET
)
pre ~void(self) is
-- This iter enables each entry in a given column of self to be set in
-- turn. It is a synonym for set_col!
loop
aset!(col * size1,size1,val) ;
yield
end
end ;
diag_elt! : ET
pre ~void(self) is
-- This iter yields each element of the matrix diagonal [square on the
-- smaller dimension] in turn.
loop
index : CARD := (size1.min(size2)).times! ;
yield([index,index])
end
end ;
inplace_diag_elt!(
val : ET
)
pre ~void(self) is
-- This iter sets each element of the matrix diagonal [square on the
-- smaller dimension] in turn.
loop
index : CARD := (size1.min(size2)).times! ;
aset(index,index,val) ;
yield
end
end ;
str(
lib : LIBCHARS
) : STR is
-- This routine returns a textual representation of self using the given
-- repertoire and encoding. It is expressed as a list (in braces) of lists
-- (also in braces).
res : FSTR :=FSTR::create + lib.Left_Brace.char ;
loop
row : CARD := nr.times! ;
if row /= 0 then
res := res + lib.Comma.char
end ;
res := res + lib.Left_Brace.char ;
loop
column : CARD := nc.times! ;
if column /= 0 then
res := res +lib.Comma.char
end ;
res := res + [row,column].str
end ;
res := res + lib.Right_Brace.char
end ;
res := res + lib.Right_Brace.char ;
return res.str
end ;
str : STR is
-- This routine returns a textual representation of the contents of self
-- using the default representation and encoding.
return str(LIBCHARS::default)
end ;
end ; -- MAT{ET,VT}
class NUMERIC_MAT{ET < $REAL{ET}, VT < $VEC{ET,VT}} <
class NUMERIC_MAT{ET < $REAL{ET}, VT < $VEC{ET,VT}} <
$MAT{ET,VT,NUMERIC_MAT{ET,VT}} is
-- This class implements numeric matrices which work on real numbers --
-- but NOT on complex numbers.
-- Version 1.1 Aug 97. Copright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 8 Jul 96 bmk Original for Sather 1.1 Dist
-- 27 Aug 97 kh Modified for cards & portability
-- 22 Mar 01 djw New destructive_invert, chol, etc.
include MAT{ET,VT} ;
destructive_invert : SAME
pre nr=nc
-- post self * result (roughly) = identity
is
-- Destructive inverse of self - returns a new matrix.
-- Uses a straightforward Gaussian elimination algorithm
-- with "maximal column pivoting" (partial pivoting).
-- Not very efficient (creates garbage), but should work... (DJW)
A::=create(nr,nr);
A.inplace_ident;
-- run through the columns
loop j::=A.col_ind!;
-- first search for "best" pivot
max::=j;
loop k::=(j+1).upto!(nr-1);
if self[k,j].abs > self[max,j].abs then max:=k; end;
end;
if ~(max=j) then
-- swap rows
temp::=self.row(j);
self.inplace_row(j,self.row(max));
self.inplace_row(max,temp);
temp:=A.row(j);
A.inplace_row(j,A.row(max));
A.inplace_row(max,temp);
end; -- if
-- now perform pivot
A.inplace_row(j,A.row(j).times(element_one/self[j,j]));
self.inplace_row(j,self.row(j).times(element_one/self[j,j]));
loop i::=A.row_ind!;
if ~(i=j) then
A.inplace_row(i,A.row(i)-A.row(j).times(self[i,j]));
self.inplace_row(i,self.row(i)-self.row(j).times(self[i,j]));
end; -- if
end; -- loop i
end; -- loop j
return A;
end; -- destructive_invert
invert : SAME
pre nr = nc
post ident.is_similar(self*result)
is
-- This routine provides a matrix inversion as a new matrix -- ie it is
-- not destructive.
return copy.destructive_invert
end ;
destructive_det : ET
pre nr = nc is
-- This routine obtains the destructive determinant value of self.
-- It operates in a similar way to the Gaussian algorithm.
loop -- elimination
outer : CARD := 0.upto!(nr - 1) ;
max : CARD := outer ;
loop -- find max column
inner : CARD := (outer + 1).upto!(nr - 1) ;
if [inner,outer].abs > [max,outer].abs then
max := inner
end
end ;
loop -- swap loop
inner : CARD := outer.upto!(nr - 1) ;
temp : ET := [outer,inner] ;
[outer,inner] := [max,inner] ;
[max,inner] := temp
end ;
loop -- outer reduction loop
inner : CARD := (outer + 1).upto!(nr - 1) ;
loop
index : CARD := (nr - 1).downto!(outer) ;
[inner,index] := [inner,index] -
[outer,index] * [inner,outer] / [outer,outer]
end
end
end ;
res : ET := ET::one ;
loop -- find the final value!
res := res * diag_elt!
end ;
return res
end ;
det : ET
pre nr = nc is
-- This routne returns the determinant value obtained from a copy of
-- self in order to avoid destroying self.
return copy.destructive_det
end ;
destructive_gauss(
res : VT
)
pre nc = nr
and res.dim = nc is
-- This routine solves the system of linear equations represented by
-- self, using Gauss' algorithm. The answers are put into the vector
-- argument res whose original content is over-written in so doing. See
-- Sedgewick: "Algorithms", pp 57-65.
loop -- elimination
outer : CARD := 0.upto!(nc - 1) ;
max : CARD := outer ;
loop -- find max
inner : CARD := (outer + 1).upto!(nc - 1) ;
if [inner,outer].abs > [max,outer].abs then
max := inner
end
end ;
loop -- swap loop
inner : CARD := outer.upto!(nc - 1) ;
temp : ET := [outer,inner] ;
[outer,inner] := [max,inner] ;
[max,inner] := temp
end ;
temp : ET := res[outer] ; -- swap vector element
res[outer] := res[max] ;
res[max] := temp ;
loop -- reduction loop
inner : CARD := (outer + 1).upto!(nc - 1) ;
res[inner] := res[inner] - res[outer] *
[inner,outer] / [outer,outer] ;
loop
index : CARD := (nc - 1).downto!(outer) ;
[index,inner] := [inner,index] - [outer,index] *
[inner,outer] / [outer,outer]
end
end
end ;
loop -- substitution
outer: CARD := (nc - 1).downto!(0) ;
temp : ET := ET::zero ;
loop
inner : CARD := (outer + 1).upto!(nc - 1) ;
temp := temp + [outer,inner] * res[inner]
end ;
res[outer] := (res[outer] - temp) / [outer,outer]
end
end ;
gauss(
vect : VT
) : VT
pre nc = nr
and vect.dim = nc is
-- This routine returns the vector containing the solutions to the
-- system of linear equations represented by self.
res : VT := vect.copy ;
copy.destructive_gauss(res) ;
return res
end ;
norm_squared : ET is
-- square of the Frobenious norm of a matrix
n::=element_zero;
loop
e::=elt!;
n:=n+(e*e);
end;
return n;
end;
norm : ET is return norm_squared.sqrt; end;
-- Frobenious norm of a matrix
destructive_chol : SAME pre nr=nc is
-- Returns lower Cholesky triangle of a real symmetric PSD matrix
-- derived this algorithm myself - no idea if it's any good
-- should check symmetry, but currently doesn't. (DJW)
i,j,k : CARD;
loop j := col_ind!;
loop i := row_ind!;
if i<j then [i,j]:=element_zero;
elsif i=j then
if j>0 then
loop k:=0.upto!(j-1);
[i,j] := [i,j] - [i,k]*[i,k];
end;
end;
[i,j] := [i,j].sqrt;
else
if j>0 then
loop k:=0.upto!(j-1);
[i,j] := [i,j] - [i,k]*[j,k];
end;
end;
[i,j] := [i,j]/[j,j];
end;
end;
end;
return self;
end; -- destructive_chol
chol : SAME
pre nr=nc
post self.is_similar(result*(result.trans))
is
return copy.destructive_chol;
end;
-- non-destructive Cholesky factorisation
is_similar(
other : SAME
) : BOOL
pre nc=other.nc and nr=other.nr
is
tol ::= ET::epsilon.sqrt ;
return (self-other).norm < tol ;
end;
end ; -- NUMERIC_MAT
class MAT < $MAT{FLT,VEC,MAT}
class MAT < $MAT{FLT,VEC,MAT} is
-- This implementation class provides a simple matrix class using
-- floating point arithmetic elements.
--
-- NOTE Generalising the operations in this class requires the definition of
-- a machine epsilon for approximate classes.
-- Version 1.0 Aug 97. Copright K Hopper, U of Waikato
-- Development History
-- -------------------
-- Date Who By Detail
-- ---- ------ ------
-- 8 Aug 97 kh Original from Sather 1.1 Dist
include NUMERIC_MAT{FLT,VEC} ;
private const Epsilon : FLT := 0.000001 ;
inplace_uniform_random is
-- This routine sets the entries of self to be random numbers uniform in
-- the range zero up to one and NOT including one itself.
loop
row : CARD :=row_ind! ;
loop
[row,col_ind!] := SHAPED_RANDOM::uniform.flt
end
end
end ;
svd_in(
mat : MAT,
vect : VEC,
val : MAT)
pre mat.nr = nr.max(nc)
and mat.nc = nc
and vect.dim = nc
and val.nr = nc
and val.nc = nc is
-- This routine computes the singular value decomposition of
--
-- self = mat vect val^T
--
-- for which
--
-- a. mat must be of shape max(nr,nc) x nc
--
-- b. vect must be of length nc.
--
-- c. val must be of shape nc x nc.
--
-- Self remains unchanged although mat, vect and val are all altered.
-- If necessary mat is filled in with values from self and extra zero rows.
mat.inplace_zero ;
mat.inplace_portion_of_arg(self) ;
NR_SVD::svd(mat,vect,val) -- Numerical Recipes version.
-- Eventually use better algorithm.
end ;
svd_back_sub(
mat : MAT,
vect : VEC,
val : MAT,
scnd,
res : VEC
)
pre mat.nc = vect.dim
and val.nr = mat.nc
and val.nc = mat.nc
and scnd.dim = mat.nr
and res.dim = mat.nc is
-- This routine solves
--
-- first . res = scnd
--
-- for res where
--
-- first = mat . vect . val^T
--
-- is the singular value decomposition of first.
tmp : VEC := VEC::create(mat.nc) ;
loop
outer : CARD := 0.upto!(mat.nc - 1) ;
sum : FLT := 0.0 ;
if vect[outer].abs >= Epsilon then -- nonzero only if w_j is nonzero
loop
inner : CARD := 0.upto!(mat.nr - 1) ;
sum := sum + mat[inner,outer] * scnd[inner]
end ;
sum := sum / vect[outer]
end ;
tmp[outer] := sum
end ;
loop
outer : CARD := 0.upto!(mat.nc - 1) ;
sum : FLT := 0.0 ;
loop
inner : CARD := 0.upto!(mat.nc - 1) ;
sum := sum + val[outer,inner] * tmp[inner]
end ;
res[outer] := sum
end
end ;
inplace_linear_fit_of(
vin,
vout : ARRAY{VEC}
) : MAT
pre nr = vout[0].dim
and nc = vin[0].dim
and vout.size = vin.size is
-- This routine fills vin so that it is the least squares best linear
-- approximation relating vin to vout by
--
-- vout[index] = self.act_on(vin[index])
--
-- Self is returned.
temp : MAT := create(vin.size,vin[0].dim) ;
loop
index : CARD := 0.upto!(vin.size - 1) ;
temp.inplace_row(index,vin[index]) ;
end ;
frst : MAT := create(temp.nr.max(temp.nc),temp.nc) ;
scnd : MAT := create(temp.nc,temp.nc) ;
vect : VEC := vect.create(temp.nc) ;
temp.svd_in(frst,vect,scnd) ;
wmax : FLT := vect.max_value ;
wmin : FLT := wmax * Epsilon ;
loop -- val < min valid means 0.0!
index : CARD := 0.upto!(temp.nc - 1) ;
if vect[index] <= wmin then
vect[index] := 0.0
end
end ;
vect1 : VEC := vect1.create(nc) ;
vect2 : VEC := vect2.create(vout.size) ;
loop
outer : CARD := 0.upto!(vout[0].dim - 1) ;
loop
inner : CARD := 0.upto!(vout.size - 1) ;
vect2[inner] := vout[inner][outer]
end ;
temp.svd_back_sub(frst,vect,scnd,vect2,vect1) ;
inplace_row(outer,vect2)
end ;
return self
end ;
inplace_affine_fit_of(
vin,
vout : ARRAY{VEC}
)
pre nr = vout[0].dim
and nc = vin[0].dim + 1
and vout.size = vin.size is
-- This routine fills each row of self such that it is the least squares
-- affine map relating vin to vout by the relation
--
-- vout[index] = self.affine_act_on(vin[index])
temp : MAT := create(vin.size,vin[0].dim + 1) ;
loop
index : CARD := 0.upto!(vin.size - 1) ;
temp.inplace_row(index,vin[index]) ;
temp[index,vin[0].dim] := 1.0
end ;
frst : MAT := create(temp.nr.max(temp.nc),temp.nc) ;
scnd : MAT := create(temp.nc,temp.nc) ;
vect : VEC := vect.create(temp.nc) ;
temp.svd_in(frst,vect,scnd) ;
wmax : FLT := wmax.max_normal ;
wmin : FLT := wmax * Epsilon ;
loop
index : CARD := 0.upto!(temp.nc - 1) ;
if vect[index] <= wmin then
vect[index] := 0.0
end
end ;
vect1 : VEC := vect1.create(nc) ;
vect2 : VEC := vect2.create(vout.size) ;
loop
outer : CARD := 0.upto!(vout[0].dim - 1) ;
loop
inner : CARD := 0.upto!(vout.size - 1) ;
vect2[inner] := vout[inner][outer]
end ;
temp.svd_back_sub(frst,vect,scnd,vect2,vect1) ;
inplace_row(outer,vect1)
end
end ;
inplace_weighted_linear_fit_of(
vin,
vout : ARRAY{VEC},
wt :ARRAY{FLT}
)
pre nr = vout[0].dim
and nc = vin[0].dim
and vout.size = vin.size
and wt.size = vin.size is
-- This routine fills in self to be the least squares best linear
-- approximation relating vin to vout by
--
-- vout[index] = self.act_on(vin[index])
--
-- where the weights wt[index] are the weights which should be given to the
-- indexed example.
temp : MAT := create(vin.size,vin[0].dim) ;
loop
index : CARD := 0.upto!(temp.nr - 1) ;
temp.inplace_row(index,vin[index])
end ;
loop -- scale by weight!
outer : CARD := 0.upto!(temp.nr - 1) ;
loop
inner : CARD := 0.upto!(temp.nc - 1) ;
temp[outer,inner] := temp[outer,inner] * wt[outer]
end
end ;
frst : MAT := create(temp.nr.max(temp.nc),temp.nc) ;
scnd : MAT := create(temp.nc,temp.nc) ;
vect : VEC := vect.create(temp.nc) ;
temp.svd_in(frst,vect,scnd) ;
wmax : FLT := wmax.max_normal ;
wmin : FLT := wmax * Epsilon ;
loop
index : CARD := 0.upto!(temp.nc - 1) ;
if vect[index] <= wmin then
vect[index] := 0.0
end
end ;
vect1 : VEC := vect1.create(nc) ;
vect2 : VEC := vect2.create(vout.size) ;
loop
outer : CARD := 0.upto!(vout[0].dim - 1) ;
loop
inner : CARD := 0.upto!(vout.size - 1) ;
vect2[inner] := vout[inner][outer] * wt[inner]
end ;
temp.svd_back_sub(frst,vect,scnd,vect2,vect1) ;
inplace_row(outer,vect1)
end
end ;
inplace_weighted_affine_fit_of(
vin,
vout : ARRAY{VEC},
wt : ARRAY{FLT}
)
pre nr = vout[0].dim
and nc = vin[0].dim + 1
and vout.size = vin.size
and wt.size = vin.size is
-- This routine fills self to be the least squares best affine
-- approximation relating vin to vout by
--
-- vout[index] = self.affine_act_on(vin[index])
--
-- where the weights give the wuight which is to be applied to the indexed
-- example.
temp : MAT := create(vin.size,vin[0].dim + 1) ;
loop
index : CARD := 0.upto!(temp.nr - 1) ;
temp.inplace_row(index,vin[index]) ;
temp[index,vin[0].dim] := wt[index]
end ;
loop -- scale by weight!
outer : CARD := 0.upto!(temp.nr - 1) ;
loop
inner : CARD := 0.upto!(temp.nc - 1) ;
temp[outer,inner] := temp[outer,inner] * wt[outer]
end
end ;
frst : MAT := create(temp.nr.max(temp.nc),temp.nc) ;
scnd : MAT := create(temp.nc,temp.nc) ;
vect : VEC := vect.create(temp.nc) ;
temp.svd_in(frst,vect,scnd) ;
wmax : FLT := wmax.max_normal ;
wmin : FLT := wmax * Epsilon ;
loop
index : CARD := 0.upto!(temp.nc - 1) ;
if vect[index] <= wmin then
vect[index] := 0.0
end
end ;
vect1 : VEC := vect1.create(nc) ;
vect2 : VEC := vect2.create(vout.size) ;
loop
outer : CARD := 0.upto!(vout[0].dim - 1) ;
loop
inner : CARD := 0.upto!(vout.size - 1) ;
vect2[inner] := vout[inner][outer] * wt[inner]
end ;
temp.svd_back_sub(frst,vect,scnd,vect2,vect1) ;
inplace_row(outer,vect1)
end
end ;
end ; -- MAT