Матрицы в Delphi

Материал из DRKB


Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.

Я понимаю, что уровень подготовки наших преподавателей весьма отстает не то, что от нынешних технологий, но даже и от весьма более ранних, но все-таки попробую помочь собратьям "по-несчастью".... :o)))

Перечень функций этой библиотеки:

unit Matrix;

interface

type
  MatrixPtr = ^MatrixRec;

  MatrixRec = record
    MatrixRow: Byte;
    MatrixCol: Byte;
    MatrixArray: Pointer;
  end;
  MatrixElement = Real;

(* Функция возвращает целочисленную степень *)
function IntPower(X, n: Integer): Integer;

(* Функция создает квадратную матрицу *)
function CreateSquareMatrix(Size: Byte): MatrixPtr;

(* Функция создает прямоугольную матрицу *)
function CreateMatrix(Row, Col: Byte): MatrixPtr;

(* Функция дублирует матрицу *)
function CloneMatrix(MPtr: MatrixPtr): MatrixPtr;

(* Функция удаляет матрицу и возвращает TRUE в случае удачи *)
function DeleteMatrix(var MPtr: MatrixPtr): Boolean;

(* Функция заполняет матрицу указанным числом *)
function FillMatrix(MPtr: MatrixPtr; Value: MatrixElement): Boolean;

(* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *)
function AssignMatrix(var MPtr1: MatrixPtr; MPtr2: MatrixPtr): MatrixPtr;

(* Функция отображает матрицу на консоль *)
function DisplayMatrix(MPtr: MatrixPtr; _Int, _Frac: Byte): Boolean;

(* Функция возвращает TRUE, если матрица 1x1 *)
function IsSingleMatrix(MPtr: MatrixPtr): Boolean;

(* Функция возвращает TRUE, если матрица квадратная *)
function IsSquareMatrix(MPtr: MatrixPtr): Boolean;

(* Функция возвращает количество строк матрицы *)
function GetMatrixRow(MPtr: MatrixPtr): Byte;

(* Функция возвращает количество столбцов матрицы *)
function GetMatrixCol(MPtr: MatrixPtr): Byte;

(* Процедура устанавливает элемент матрицы *)
procedure SetMatrixElement(MPtr: MatrixPtr; Row, Col: Byte; Value: MatrixElement);

(* Функция возвращает элемент матрицы *)
function GetMatrixElement(MPtr: MatrixPtr; Row, Col: Byte): MatrixElement;

(* Функция исключает векторы из матрицы *)
function ExcludeVectorFromMatrix(MPtr: MatrixPtr; Row, Col: Byte): MatrixPtr;

(* Функция заменяет строку(столбец) матрицы вектором *)
function SetVectorIntoMatrix(MPtr, VPtr: MatrixPtr; _Pos: Byte): MatrixPtr;

(* Функция возвращает детерминант матрицы *)
function DetMatrix(MPtr: MatrixPtr): MatrixElement;

(* Функция возвращает детерминант треугольной матрицы *)
function DetTriangularMatrix(MPtr: MatrixPtr): MatrixElement;

(* Функция возвращает алгебраическое дополнение элемента матрицы *)
function AppendixElement(MPtr: MatrixPtr; Row, Col: Byte): MatrixElement;

(* Функция создает матрицу алгебраических дополнений элементов матрицы *)
function CreateAppendixMatrix(MPtr: MatrixPtr): MatrixPtr;

(* Функция транспонирует матрицу *)
function TransponeMatrix(MPtr: MatrixPtr): MatrixPtr;

(* Функция возвращает обратную матрицу *)
function ReverseMatrix(MPtr: MatrixPtr): MatrixPtr;

(* Функция умножает матрицу на число *)
function MultipleMatrixOnNumber(MPtr: MatrixPtr; Number: MatrixElement): MatrixPtr;

(* Функция умножает матрицу на матрицу *)
function MultipleMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;

(* Функция суммирует две матрицы *)
function AddMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;

(* Функция вычитает из первой матрицы вторую *)
function SubMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;

(* Функция решает систему методом Гаусса и возвращает LU-матрицы *)
(* Результат функции - вектор-столбец решений                    *)

function GausseMethodMatrix(MPtr, VPtr: MatrixPtr;
  var LPtr, UPtr, BPtr: MatrixPtr): MatrixPtr;


implementation


function IntPower(X, n: Integer): Integer;
var
  Res, i: Integer;
begin
  if n < 1 then
    Result := 0
  else
  begin
    Res := X;
    for i := 1 to n - 1 do Res := Res * X;
    Result := Res;
  end;
end;


function CreateSquareMatrix(Size: Byte): MatrixPtr;
var
  TempPtr: MatrixPtr;
begin
  TempPtr := nil;
  GetMem(TempPtr, SizeOf(MatrixRec));
  if TempPtr = nil then
  begin
    Result := nil;
    Exit;
  end;
  with TempPtr^ do
  begin
    MatrixRow := Size;
    MatrixCol := Size;
    MatrixArray := nil;
    GetMem(MatrixArray, Size * Size * SizeOf(MatrixElement));
    if MatrixArray = nil then
    begin
      FreeMem(TempPtr, SizeOf(MatrixRec));
      Result := nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr, 0);
  Result := TempPtr;
end;


function CreateMatrix(Row, Col: Byte): MatrixPtr;
var
  TempPtr: MatrixPtr;
begin
  TempPtr := nil;
  GetMem(TempPtr, SizeOf(MatrixRec));
  if TempPtr = nil then
  begin
    Result := nil;
    Exit;
  end;
  with TempPtr^ do
  begin
    MatrixRow := Row;
    MatrixCol := Col;
    MatrixArray := nil;
    GetMem(MatrixArray, Row * Col * SizeOf(MatrixElement));
    if MatrixArray = nil then
    begin
      FreeMem(TempPtr, SizeOf(MatrixRec));
      Result := nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr, 0);
  Result := TempPtr;
end;


function DeleteMatrix(var MPtr: MatrixPtr): Boolean;
begin
  if MPtr = nil then
    Result := False
  else
    with MPtr^ do
    begin
      if MatrixArray <> nil then
        FreeMem(MatrixArray, MatrixRow * MatrixCol * SizeOf(MatrixElement));
      FreeMem(MPtr, SizeOf(MatrixRec));
      MPtr := nil;
      Result := True;
    end;
end;


function CloneMatrix(MPtr: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j: Byte;
begin
  if MPtr = nil then
    Result := nil
  else
    with MPtr^ do
    begin
      TempPtr := CreateMatrix(MPtr^.MatrixRow, MPtr^.MatrixCol);
      if TempPtr <> nil then
      begin
        for i := 1 to MatrixRow do
          for j := 1 to MatrixCol do
            SetMatrixElement(TempPtr, i, j, GetMatrixElement(MPtr, i, j));
        Result := TempPtr;
      end
      else
        Result := nil;
    end;
end;



function FillMatrix(MPtr: MatrixPtr; Value: MatrixElement): Boolean;
var
  i, j: Byte;
begin
  if MPtr = nil then
    Result := False
  else
    with MPtr^ do
    begin
      for i := 1 to MatrixRow do
        for j := 1 to MatrixCol do
          SetMatrixElement(MPtr, i, j, Value);
      Result := True;
    end;
end;


function AssignMatrix(var MPtr1: MatrixPtr; MPtr2: MatrixPtr): MatrixPtr;
begin
  DeleteMatrix(MPtr1);
  MPtr1 := MPtr2;
  Result := MPtr1;
end;


function DisplayMatrix(MPtr: MatrixPtr; _Int, _Frac: Byte): Boolean;
var
  i, j: Byte;
begin
  if MPtr = nil then Result := False
  else
    with MPtr^ do
    begin
      for i := 1 to MatrixRow do
      begin
        for j := 1 to MatrixCol do
          Write(GetMatrixElement(MPtr, i, j): _Int: _Frac);
        WriteLn;
      end;
      Result := True;
    end;
end;


function IsSingleMatrix(MPtr: MatrixPtr): Boolean;
begin
  if MPtr <> nil then
    with MPtr^ do
    begin
      if (MatrixRow = 1) and (MatrixCol = 1) then
        Result := True
      else
        Result := False;
    end
  else
    Result := False;
end;


function IsSquareMatrix(MPtr: MatrixPtr): Boolean;
begin
  if MPtr <> nil then
    with MPtr^ do
    begin
      if MatrixRow = MatrixCol then
        Result := True
      else
        Result := False;
    end
  else
    Result := False;
end;

function GetMatrixRow(MPtr: MatrixPtr): Byte;
begin
  if MPtr <> nil then
    Result := MPtr^.MatrixRow
  else
    Result := 0;
end;

function GetMatrixCol(MPtr: MatrixPtr): Byte;
begin
  if MPtr <> nil then
    Result := MPtr^.MatrixCol
  else
    Result := 0;
end;

procedure SetMatrixElement(MPtr: MatrixPtr; Row, Col: Byte; Value: MatrixElement);
var
  TempPtr: ^MatrixElement;
begin
  if MPtr <> nil then
    if (Row <> 0) or (Col <> 0) then with MPtr^ do
      begin
        pointer(TempPtr) := pointer(MatrixArray);
        Inc(TempPtr, MatrixRow * (Col - 1) + Row - 1);
        TempPtr^ := Value;
      end;
end;


function GetMatrixElement(MPtr: MatrixPtr; Row, Col: Byte): MatrixElement;
var
  TempPtr: ^MatrixElement;
begin
  if MPtr <> nil then
  begin
    if (Row <> 0) and (Col <> 0) then with MPtr^ do
      begin
        pointer(TempPtr) := pointer(MatrixArray);
        Inc(TempPtr, MatrixRow * (Col - 1) + Row - 1);
        Result := TempPtr^;
      end
    else
      Result := 0;
  end
  else
    Result := 0;
end;


function ExcludeVectorFromMatrix(MPtr: MatrixPtr; Row, Col: Byte): MatrixPtr;
var
  NewPtr: MatrixPtr;
  NewRow, NewCol: Byte;
  i, j: Byte;
  DiffRow, DiffCol: Byte;
begin
  if MPtr <> nil then with MPtr^ do
    begin

      if Row = 0 then NewRow := MatrixRow
      else
        NewRow := MatrixRow - 1;
      if Col = 0 then NewCol := MatrixCol
      else
        NewCol := MatrixCol - 1;

      NewPtr := CreateMatrix(NewRow, NewCol);
      if (NewPtr = nil) or (NewPtr^.MatrixArray = nil) then
      begin
        Result := nil;
        Exit;
      end;

      DiffRow := 0;
      DiffCol := 0;
      for i := 1 to MatrixRow do
      begin
        if i = Row then DiffRow := 1
        else
          for j := 1 to MatrixCol do if j = Col then DiffCol := 1
            else
              SetMatrixElement(NewPtr, i - DiffRow, j - DiffCol,
                GetMatrixElement(MPtr, i, j));
        DiffCol := 0;
      end;

      Result := NewPtr;
    end
  else
    Result := nil;
end;


function SetVectorIntoMatrix(MPtr, VPtr: MatrixPtr; _Pos: Byte): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i: Byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then
  begin
    TempPtr := CloneMatrix(MPtr);
    if TempPtr = nil then
    begin
      Result := nil;
      Exit;
    end;
    if VPtr^.MatrixRow = 1 then
    begin
      for i := 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr, _Pos, i, GetMatrixElement(VPtr, 1, i));
    end
    else
    begin
      for i := 1 to TempPtr^.MatrixRow do
        SetMatrixElement(TempPtr, i, _Pos, GetMatrixElement(VPtr, i, 1));
    end;
    Result := TempPtr;
  end
  else
    Result := nil;
end;


function DetMatrix(MPtr: MatrixPtr): MatrixElement;
var
  TempPtr: MatrixPtr;
  i, j: Byte;
  Sum: MatrixElement;
begin
  if IsSquareMatrix(MPtr) then
  begin
    if not IsSingleMatrix(MPtr) then
    begin
      TempPtr := nil;
      Sum := 0;
      for j := 1 to GetMatrixCol(MPtr) do
      begin
        AssignMatrix(TempPtr, ExcludeVectorFromMatrix(MPtr, 1, j));
        Sum := Sum + IntPower(-1, j + 1) * GetMatrixElement(MPtr, 1, j) *
          DetMatrix(TempPtr);
      end;
      DeleteMatrix(TempPtr);
      Result := Sum;
    end
    else
      Result := GetMatrixElement(MPtr, 1, 1);
  end
  else
    Result := 0;
end;


function DetTriangularMatrix(MPtr: MatrixPtr): MatrixElement;
var
  i: Byte;
  Sum: MatrixElement;
begin
  if IsSquareMatrix(MPtr) then
  begin
    Sum := 1;
    for i := 1 to MPtr^.MatrixRow do
      Sum := Sum * GetMatrixElement(MPtr, i, i);
    Result := Sum;
  end
  else
    Result := 0;
end;


function AppendixElement(MPtr: MatrixPtr; Row, Col: Byte): MatrixElement;
var
  TempPtr: MatrixPtr;
begin
  if IsSquareMatrix(MPtr) then
  begin
    TempPtr := ExcludeVectorFromMatrix(MPtr, Row, Col);
    if TempPtr = nil then
    begin
      Result := 0;
      Exit;
    end;
    Result := IntPower(-1, Row + Col) * DetMatrix(TempPtr);
    DeleteMatrix(TempPtr);
  end
  else
    Result := 0;
end;


function CreateAppendixMatrix(MPtr: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j: Byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) or (not IsSquareMatrix(MPtr)) then
    with MPtr^ do
    begin
      TempPtr := CreateMatrix(MatrixCol, MatrixRow);
      for i := 1 to MatrixRow do
        for j := 1 to MatrixCol do
          SetMatrixElement(TempPtr, i, j, AppendixElement(MPtr, i, j));
      Result := TempPtr;
    end
  else
    Result := nil;
end;



function TransponeMatrix(MPtr: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j: Byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) then with MPtr^ do
    begin
      TempPtr := CreateMatrix(MatrixCol, MatrixRow);
      for i := 1 to MatrixRow do
        for j := 1 to MatrixCol do
          SetMatrixElement(TempPtr, j, i, GetMatrixElement(MPtr, i, j));
      Result := TempPtr;
    end
  else
    Result := nil;
end;


function ReverseMatrix(MPtr: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  Determinant: MatrixElement;
begin
  if MPtr <> nil then
  begin
    TempPtr := nil;
    AssignMatrix(TempPtr, CreateAppendixMatrix(MPtr));
    AssignMatrix(TempPtr, TransponeMatrix(TempPtr));
    Determinant := DetMatrix(MPtr);
    if (TempPtr = nil) or (Determinant = 0) then
    begin
      DeleteMatrix(TempPtr);
      Result := nil;
      Exit;
    end;
    AssignMatrix(TempPtr, MultipleMatrixOnNumber(TempPtr, 1 / Determinant));
    Result := TempPtr;
  end
  else
    Result := nil;
end;



function MultipleMatrixOnNumber(MPtr: MatrixPtr; Number: MatrixElement): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j: Byte;
begin
  if MPtr <> nil then with MPtr^ do
    begin
      TempPtr := CreateMatrix(MatrixRow, MatrixCol);
      if TempPtr = nil then
      begin
        Result := nil;
        Exit;
      end;
      for i := 1 to MatrixRow do
        for j := 1 to MatrixCol do
          SetMatrixElement(TempPtr, i, j, GetMatrixElement(MPtr, i, j) * Number);
      Result := TempPtr;
    end
  else
    Result := nil;
end;


function MultipleMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j, k: Byte;
begin
  if (MPtr1 <> nil) and (MPtr2 <> nil) then
  begin
    TempPtr := CreateMatrix(MPtr1^.MatrixRow, MPtr2^.MatrixCol);
    if TempPtr = nil then
    begin
      Result := nil;
      Exit;
    end;
    for i := 1 to TempPtr^.MatrixRow do
      for j := 1 to TempPtr^.MatrixCol do
        for k := 1 to MPtr1^.MatrixCol do
          SetMatrixElement(TempPtr, i, j, GetMatrixElement(TempPtr, i, j) +
            GetMatrixElement(MPtr1, i, k) * GetMatrixElement(MPtr2, k, j));
    Result := TempPtr;
  end
  else
    Result := nil;
end;



function AddMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j, k: Byte;
begin
  if (MPtr1 <> nil) and (MPtr2 <> nil) then
  begin
    TempPtr := CreateMatrix(MPtr1^.MatrixRow, MPtr2^.MatrixCol);
    if TempPtr = nil then
    begin
      Result := nil;
      Exit;
    end;
    for i := 1 to TempPtr^.MatrixRow do
      for j := 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr, i, j, GetMatrixElement(Mptr1, i, j) +
          GetMatrixElement(MPtr2, i, j));
    Result := TempPtr;
  end
  else
    Result := nil;
end;


function SubMatrixOnMatrix(MPtr1, MPtr2: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  i, j, k: Byte;
begin
  if (MPtr1 <> nil) and (MPtr2 <> nil) then
  begin
    TempPtr := CreateMatrix(MPtr1^.MatrixRow, MPtr2^.MatrixCol);
    if TempPtr = nil then
    begin
      Result := nil;
      Exit;
    end;
    for i := 1 to TempPtr^.MatrixRow do
      for j := 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr, i, j, GetMatrixElement(MPtr1, i, j) -
          GetMatrixElement(MPtr2, i, j));
    Result := TempPtr;
  end
  else
    Result := nil;
end;



function GausseMethodMatrix(MPtr, VPtr: MatrixPtr;
  var LPtr, UPtr, BPtr: MatrixPtr): MatrixPtr;
var
  TempPtr: MatrixPtr;
  TempVPtr: MatrixPtr;
  TempLPtr: MatrixPtr;
  TempUPtr: MatrixPtr;
  XSum: MatrixElement;
  i, j, k: Byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then
  begin

    TempUPtr := CloneMatrix(MPtr);
    if TempUPtr = nil then
    begin
      Result := nil;
      Exit;
    end;
    TempLPtr := CreateMatrix(MPtr^.MatrixRow, MPtr^.MatrixCol);
    if TempLPtr = nil then
    begin
      DeleteMatrix(TempUPtr);
      Result := nil;
      Exit;
    end;
    TempVPtr := CloneMatrix(VPtr);
    if TempVPtr = nil then
    begin
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      Result := nil;
      Exit;
    end;
    TempPtr := CreateMatrix(MPtr^.MatrixRow, 1);
    if TempPtr = nil then
    begin
      DeleteMatrix(TempVPtr);
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      Result := nil;
      Exit;
    end;

    for j := 1 to MPtr^.MatrixCol - 1 do
    begin
      SetMatrixElement(TempLPtr, j, j, 1);
      for i := j + 1 to MPtr^.MatrixRow do
      begin
        SetMatrixElement(TempLPtr, i, j, GetMatrixElement(TempUPtr, i, j) /
          GetMatrixElement(TempUPtr, j, j));
        for k := j to MPtr^.MatrixCol do
        begin
          SetMatrixElement(TempUPtr, i, k, GetMatrixElement(TempUPtr, i, k) -
            GetMatrixElement(TempLPtr, i, j) * GetMatrixElement(TempUPtr, j, k));
        end;
        SetMatrixElement(TempVPtr, i, 1, GetMatrixElement(TempVPtr, i, 1) -
          GetMatrixElement(TempLPtr, i, j) * GetMatrixElement(TempVPtr, j, 1));
      end;
    end;

    SetMatrixElement(TempLPtr, TempLPtr^.MatrixRow, TempLPtr^.MatrixCol, 1);
    SetMatrixElement(TempPtr, TempPtr^.MatrixRow, 1,
      GetMatrixElement(TempVPtr, TempVPtr^.MatrixRow, 1) /
      GetMatrixElement(TempUPtr, TempUPtr^.MatrixRow, TempUPtr^.MatrixCol));

    for j := MPtr^.MatrixCol - 1 downto 1 do
    begin
      XSum := 0;
      for k := j + 1 to MPtr^.MatrixCol do
        XSum := XSum + GetMatrixElement(TempUPtr, j, k) *
          GetMatrixElement(TempPtr, k, 1);
      SetMatrixElement(TempPtr, j, 1, (GetMatrixElement(TempVPtr, j, 1) - XSum) /
        GetMatrixElement(TempUPtr, j, j));
    end;

    LPtr := TempLPtr;
    UPtr := TempUPtr;
    BPtr := TempVPtr;
    Result := TempPtr;
  end
  else
    Result := nil;
end;

end.


Мне кажется, что интерфейсное описание весьма простое, но если возникнут какие-либо вопросы - пишите на E-mail - постараюсь ответить на все Ваши вопросы. Может быть, азы матричного исчисления я опишу в виде отдельной статьи по причине множества поступивших вопросов, хотя в этой матричной математике нет ничего сложного :o) Следует отметить, что теория матриц дает в Ваши руки весьма мощный инструмент по анализу данных весьма различного характера, в чем я неоднократно убеждался на практике.

Важные, на мой взгляд, замечания. НЕ СТЕСНЯЙТЕСЬ использовать подход, использующий стандартный тип Pascal - record. В объектах мало чего хорошего в межкомпиляторном взаимодействии. Да и, кстати, использование типа record до сих пор является самым быстрым способом математических расчетов, в отличии от ООП. Частенько простое 2+2=4 дает существенный выигрыш по времени выполнения, по сравнению с объектным подходом, а если математических вычислений в Вашей программе великое множество....



Author: Andrew M. Omutov
Source: http://delphiworld.narod.ru
ID: 03956