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