Возведение матрицы в степень / UMatr

unit UMatr;


interface
Uses Dialogs, SysUtils, Controls;

Const Max = 10000;

type
type_el=integer;
ind_M = Longint;
Next = ^Matr_Elem;
Matr_Elem = record
Row, Col:ind_M;
Val: type_el;
Down, Right:Next end; {Matr_Elem}
Base = array [0..Max] of Matr_Elem;
Matr = record
BaseRow, BaseCol : Base end;

Procedure Cr(i_,j_:ind_M; el_:type_el;var q_:next);
Procedure Input( n_,i_,j_:ind_M; var el_: type_el;var A_:Matr);
Procedure Null(var A_:Matr; var n_:ind_M);
Procedure Proizv (var A_,B_:Matr; i_,j_:ind_M; var rez_:type_el);
Procedure DelMatr(var A_:Matr;n_:ind_M);
Procedure CopyMatr(var A_,B_:Matr;n_:ind_M);

implementation

Procedure Cr(i_,j_:ind_M; el_:type_el;var q_:next);
Begin{Cr}
 if el_<>0 then
   begin
     new(q_);
     q_^.row:=i_;
     q_^.col:=j_;
     q_^.val:=el_;
  end;
end; {Cr--new Element}

Procedure Input( n_,i_,j_:ind_M; var el_: type_el;var A_:Matr);
var  p,q:next;
Begin {Input}
     P := A_.BaseRow[i_-1].Right;
     Q := P;
      While Q^.Col <> 0 do
       Begin
        If (Q^.Row = i_) and (Q^.Col = J_) then
          Begin
           If MessageDlg('Вы хотите заменить элемент?',mtConfirmation, [mbYes, mbNo], 0)= mrYes then
           Begin
             Q^.Val := El_;
             Exit;
           End;
          End;
        Q := Q.Right;
  End;
  
  p:=@(A_.BaseRow[i_-1]);
  Cr(i_,j_,el_,q);
      while (p^.right^.col<>0) and (j_>=p^.right^.col) do
          p:=p^.right;
       if j_<>p^.col then
         begin
          q^.right:=p^.right;
          p^.right:=q;
        end;
  p:=@(A_.BaseCol [j_-1]);
     while (p^.down^.row<>0) and (i_>=p^.down^.row) do
       p:=p^.down;
if i_<>p^.row then
  begin
     q^.down:=p^.down;
     p^.down:=q;
  end;
end;{Input}


Procedure Null(var A_:Matr; var n_:ind_M);
 var i:ind_m;
 begin
    For i:=0 to n_-1 do
        begin
          A_.BaseRow[i].col:=0;
          A_.BaseRow[i].right:=@(A_.BaseRow[i]);
          A_.BaseCol[i].row:=0;
          A_.BaseCol[i].Down:=@(A_.BaseCol[i]); end;
      end;{Null}



Procedure Proizv (var A_,B_:Matr; i_,j_:ind_M; var rez_:type_el);
 var p,q:next;
  begin
    p:=A_.BaseRow[i_].right;
    q:=B_.BaseCol[j_].down;
    rez_:=0;
while (p^.col<>0) and (q^.row<>0) do
  begin
    if p^.col=q^.row then
          begin
              rez_:= rez_+p^.val*q^.val;
              p:=p^.right;
              q:=q^.down;
          end
 else
    if p^.Col>q^.row
          then q:=q^.down
          else p:=p^.right;
end; {while}
end;{Proizv}

Procedure DelMatr(var A_:Matr;n_:ind_M);
var i:ind_M; p,q:next;
 begin
  For i:=0 to n_-1 do
     begin
       p:=@(A_.BaseRow[i]);
       while p^.right^.col<>0 do
           begin
	     q:=p^.right;
                 while q^.right^.Col<>0 do
	           begin
	               q:=q^.right;
	               p:=p^.right;
	           end;
	      p^.right:=@(A_.BaseRow[i]);
	      p:=@(A_.BaseRow[i]);
	      dispose(q);
          end;{while}
    A_.BaseCol[i].down:= @(A_.BaseCol[i]);
 end;{for}
end;{DelMatr}


Procedure CopyMatr(var A_,B_:Matr;n_:ind_M);
var i,j,k:ind_M; el:type_el; P:next;
 begin
  Null(B_,n_);
  K:=0;
   for k:=0 to n_-1 do
      begin
         p:=A_.BaseRow[k].right;
             while p^.Col<>0 do
               begin
                i:=p^.Row;
                j:=p^.Col;
               el:=p^.Val;
               Input(n_,i,j,el,B_); p:=p^.right;
           end;
 end;
end;{CopyMatr}

end.