Function CuanZeeroInLine(L1: Integer): Integer;
Procedure SwapLines(L1,L2: Integer); Virtual;
Procedure SwapBars(B1,B2: Integer);
Function CuanZeeroInBar(B1: Integer): Integer;
Procedure SpecialSortLines;
Procedure SpecialSortBars;
Procedure SelfClear; Virtual;
Procedure StepRevers; Virtual;
Procedure RemSettings(Var FM: Mem); Virtual;
Procedure RestoreSettings(Var FM: Mem); Virtual;
Procedure MSqr(Var A: Matrix); {ў®§ў®¤Ёв ўбҐ н«Ґ¬Ґвл ¬ ваЁжл ў Єў ¤а в}
Procedure MDg(Var A: Matrix);
{errors}
Procedure BadOperands; Virtual;
Procedure MulError; Virtual;
Procedure MNotSquare; Virtual;
Procedure AddError; Virtual;
Procedure ReversError; Virtual;
Procedure MDegenerate; Virtual;
Procedure MDgError; Virtual;
Procedure MSqrError; Virtual;
Procedure DetError; Virtual;
Procedure SortError; Virtual;
Procedure DGaussError; Virtual;
Procedure CuanZeeroError; Virtual;
Procedure SwapError; Virtual;
Procedure MulToNumError; Virtual;
Procedure Stopped; Virtual;
Procedure DegrError; Virtual;
Procedure IgError; Virtual;
End;
Matrix31=Object(Matrix)
Function DetWithGauss: TOE; Virtual;
Procedure SwapLines(L1,L2: Integer); Virtual;
End;
Matrix63=Object(Matrix)
Function DetWithGauss: TOE; Virtual;
Procedure SwapLines(L1,L2: Integer); Virtual;
End;
Implementation
{**************************************************************************}
Procedure TAbl. ZeeroFill;
Var i,j: Integer;
Begin
IF Not Exist Then Begin NotExist; ZFE; Exit; End;
IF (Errors<> [0]) Then Begin ZFE; Exit; End;
For i: =1 to CLines do
For j: =1 to CBars do
SetE(i,j,0);
End;
Procedure Tabl. Let(Var A);
Begin
End;
Procedure Tabl. AllClear;
Begin
CBars: =0;
CLines: =0;
SizeInMemory: =0;
Errors: = [0] ;
M: =Nil;
End;
Procedure Tabl. DataInit(L,B: Byte);
Begin
IF Exist Then Del;
AllClear;
IF 1.0*SizeOf(TOE) *L*B>(Word(Pred(0)) +1) *1.0 Then Begin TooManySize; Exit; End;
CBars: =B;
CLines: =L;
SizeInMemory: =SizeOf(TOE) *CBars*CLines;
If MaxAvail < SizeInMemory Then Begin TooManySize; Exit; End;
GetMem(M,SizeInMemory);
Exist: =True;
End;
Procedure Tabl. SetE(I,J: Byte; E: TOE);
Begin
IF Errors<> [0] Then Exit;
IF Not Exist Then Begin NotExist; Exit; End;
IF (I>CLines) or (J>CBars) or (I<1) or (J<1) Then Begin BadPosition; Exit; End;
Ar(M^) [((I-1) *CBars+J)]: =E;
End;
Function Tabl. GetE(I,J: Byte): TOE;
Begin
IF Errors<> [0] Then Exit;
IF Not Exist Then Begin NotExist; Exit; End;
IF (I>CLines) or (J>CBars) or (I<1) or (J<1)
Then
Begin
GetE: =0.0;
BadPosition;
End
Else
GetE: =Ar(M^) [((I-1) *CBars+J)] ;
End;
Procedure Tabl. Del;
Begin
IF Errors<> [0] Then Exit;
IF Not Exist Then Begin NotExist; Exit; End;
IF SizeInMemory<>0 Then FreeMem(M,SizeInMemory);
AllClear;
Exist: =False;
End;
Procedure Tabl. ReadOfText(Name: String; Search: String);
Var F: Text;
I,J: Byte;
Prom: TOE;
Help: Integer;
Function Searcher: Boolean;
Var Prom: String;
Begin
Repeat
Readln(F,Prom);
IF IOResult<>0 Then Begin ReadError; Close(F); Exit; End;
Until (EOF(F)) or (Pos(Search,Prom) <>0);
IF Pos(Search,Prom) =0
Then
Begin
SearchError;
Searcher: =False;
End
Else Searcher: =True;
End;
Begin
IF Exist Then Del;
Assign(F,Name);
{$I-}
Reset(F);
IF IOResult=2 Then Begin FileNotFound; ReadError; Exit; End;
IF IOResult<>0 Then Begin FileError; ReadError; Exit; End;
IF Not Searcher Then Exit;
Readln(F,CLines);
IF IOResult<>0 Then Begin AllClear; ReadError; Close(F); Exit; End;
Readln(F,CBars);
IF IOResult<>0 Then Begin AllClear; ReadError; Close(F); Exit; End;
DataInit(CLines,CBars);
IF Errors<> [0] Then Exit;
IF Not Exist Then Exit;
For I: =1 to CLines do
For J: =1 to CBars do
Begin
Read(F,Prom);
IF (EOF(F)) and (I<>CLines) And (I<>CBars) Then Begin Del; OutOfData; ReadError; Close(F); Exit; End;
IF IOResult<>0 Then Begin Del; ReadError; Close(F); Exit; End;
SetE(I,J,Prom);
End;
Close(F);
{$I+}
End;
Procedure Tabl. WriteToText(Name: String; F1,F2: Byte);
Var F: Text;
I,J: Byte;
Begin
IF Errors<> [0] Then Exit;
IF Not Exist Then Begin NotExist; WriteError; Exit; End;
Assign(F,Name);
{$I-}
ReWrite(F);
IF IOResult<>0 Then Begin FileError; WriteError; Exit; End;
For I: =1 to CLines do
Begin
For J: =1 to CBars do
Begin
Write(F,GetE(I,J): F1: F2,' ');
IF IOResult<>0 Then Begin Close(F); WriteError; Exit; End;
End;
Writeln(F)
End;
Close(F);
{$I+}
End;
Procedure Tabl. TooManySize;
Begin
Errors: =Errors+ [CTooManySize] ;
AnyError
End;
Procedure Tabl. BadPosition;
Begin
Errors: =Errors+ [CBadPosition] ;
AnyError
End;
Procedure Tabl. FileNotFound;
Begin
Errors: =Errors+ [CFileNotFound] ;
AnyError
End;
Procedure Tabl. FileError;
Begin
Errors: =Errors+ [CFileError] ;
AnyError
End;
Procedure Tabl. ReadError;
Begin
Errors: =Errors+ [CReadError] ;
AnyError
End;
Procedure Tabl. WriteError;
Begin
Errors: =Errors+ [CWriteError] ;
AnyError
End;
Procedure Tabl. OutOfData;
Begin
Errors: =Errors+ [COutOfData] ;
AnyError
End;
Procedure Tabl. SearchError;
Begin
Errors: =Errors+ [CSearchError] ;
AnyError
End;
Procedure Tabl. NotExist;
Begin
Errors: =Errors+ [CNotExist] ;
AnyError
End;
Procedure Tabl. ZFE;
Begin
Errors: =Errors+ [CZFE] ;
AnyError
End;
Procedure Tabl. UnkNownError;
Begin
Errors: =Errors+ [CUnkNownError] ;
AnyError
End;
Procedure Tabl. AnyError;
Begin
End;
Constructor TAbl. VMT;
Begin
Exist: =False;
End;
Procedure Matrix. MSqr;
Var i,j: Integer;
Begin
IF Not A. Exist Then Begin A. NotExist; BadOperands; MSqrError; Exit; End;
IF A. Errors<> [0] Then Begin MsqrError; Exit; End;
IF Self. Exist Then Del;
Self. DataInit(A. CLines,A. CBars);
For i: =1 to CLines do
For j: =1 to CBars do
SetE(i,j,Sqr(A. GetE(i,j)));
Self. SelfClear;
End;
Procedure Matrix. MDg;
Var i,j: Integer;
Begin
IF Not A. Exist Then Begin A. NotExist; BadOperands; MDgError; Exit; End;
IF A. Errors<> [0] Then Begin MDgError; Exit; End;
IF A. CLines<>A. CBars Then Begin MNotSquare; MDgError; Exit; End;
IF Exist Then Del;
DataInit(A. CLines,A. CBars);
For i: =1 to A. CLines do
For j: =1 to A. CBars do
IF i=j Then SetE(i,j,A. GetE(i,j))
Else SetE(i,j,0);
Self. SelfClear;
End;
Procedure Matrix. BadOperands;
Begin
Errors: =Errors+ [CBadOperands] ;
AnyError;
End;
Procedure Matrix. MulError;
Begin
Errors: =Errors+ [CMulError] ;
AnyError;
End;
Procedure Matrix. MDgError;
Begin
Errors: =Errors+ [CMDgError] ;
AnyError;
End;
Procedure Matrix. SortError;
Begin
Errors: =Errors+ [CSortError] ;
AnyError;
End;
Procedure Matrix. DetError;
Begin
Errors: =Errors+ [CDetError] ;
AnyError;
End;
Procedure Matrix. DGaussError;
Begin
Errors: =Errors+ [CDGaussError] ;
AnyError;
End;
Procedure Matrix. MSqrError;
Begin
Errors: =Errors+ [CMSqrError] ;
AnyError;
End;
Procedure MAtrix. CuanZeeroError;
Begin
Errors: =Errors+ [CCuanZeeroError] ;
AnyError;
End;
Procedure MAtrix. SwapError;
Begin
Errors: =Errors+ [CSwapError] ;
AnyError;
End;
Procedure Matrix. MulToNumError;
Begin
Errors: =Errors+ [CMulToNumError] ;
AnyError
End;
Procedure Matrix. DegrError;
Begin
Errors: =Errors+ [CDegrError] ;
AnyError
End;
Procedure Matrix. IgError;
Begin
Errors: =Errors+ [CIgError] ;
AnyError
End;
Procedure MAtrix. SelfClear;
Begin
Lin: = [0] ;
Bar: = [0] ;
Plus: =True;
Direction: =True;
SortLines: =True;
BeginZeero: =True;
SpecialSort: =False;
Chek: =0;
Gauss: =False;
DetForRev: =False;
End;
Procedure Matrix. AllClear;
Begin
inherited AllClear;
SelfClear;
End;
Procedure Matrix. Revers;
VAr FM: Mem;
Begin
Gauss: =False;
InnerRevers(A);
End;
Procedure Matrix. RevWithGauss;
Var FM: Mem;
Begin
Gauss: =True;
InnerRevers(A);
End;
Procedure Matrix. InnerRevers;
Var P,A1: Matrix;
D: TOE;
i,j: Integer;
Var Ver: TOE;
Var FM: Mem;
Begin
IF Not A. Exist Then Begin A. NotExist; BadOperands; ReversError; Exit; End;
IF (A. Errors<> [0]) Then Begin Exit; ReversError; End;
IF (A. CBars<>A. Clines) Then Begin BadOperands; ReversError; Exit; End;
P. VMT;
P. DataInit(A. CLines,A. CBars);
A1. VMT;
A1: =A;
IF A1. CLines=31 Then Begin Matrix31(A1). VMT; A1. Exist: =True; End;
IF A1. CLines=63 Then Begin Matrix63(A1). VMT; A1. Exist: =True; End;
IF Gauss Then D: =A1. DetWithGauss;
IF D=0 Then
Begin
MDegenerate;
ReversError;
Exit;
End;
DetForRev: =True;
For i: =1 to P. Clines do
Begin
A. StepRevers;
For j: =1 to P. CBars do
Begin
A1. Lin: =A1. Lin+ [i] ;
A1. Bar: =A1. Bar+ [j] ;
IF Gauss Then Ver: =A1. DetWithGauss;
IF (A1. Errors<> [0]) or (A. Errors<> [0]) Then Begin ReversError; Exit; End;
P. SetE(j, i,(Ver) *Sign(i+j) /D);
A1. Lin: =A1. Lin- [i] ;
A1. Bar: =A1. Bar- [j] ;
End;
End;
IF Self. Exist Then Self. del;
Self: =P;
Self. SelfClear;
End;
Procedure Matrix. SwapBars(B1,B2: Integer);
Var Prom: TOE;
i: Integer;
Begin
IF Not Exist Then BEgin NotExist; SwapError; Exit; End;
IF (Errors<> [0]) Then Begin SwapError; Exit; End;
For i: =1 to CLines do
Begin
Prom: =GetE(i,B1);
SetE(i,B1,GetE(i,B2));
SetE(i,B2,Prom)
End;
End;
Function Matrix. CuanZeeroInBar(B1: Integer): Integer;
Var i: Integer;
Sum: Integer;
Begin
IF Not Exist Then Begin NotExist; CuanZeeroError; Exit; End;
IF (Errors<> [0]) Then Begin CuanZeeroError; Exit; End;
Sum: =0;
IF Not SpecialSort
Then
For i: =1 to CLines do IF GetE(i,B1) =0 Then Inc(Sum) else
Else
IF BeginZeero
Then
Begin
Sum: =1;
While (GetE(Sum,B1) =0) and (Sum<=CLines) do inc(Sum);
Dec(Sum);
End
Else
Begin
Sum: =CLines;
While (GetE(Sum,B1) =0) and (Sum>0) do Dec(Sum);
Sum: =Clines-Sum;
End;
CuanZeeroinBar: =Sum;
End;
Procedure Matrix. ZeeroSortBars;
Var i,j: Integer;
Max,NMax,CZ: Integer;
FM: Mem;
Begin
IF Not Exist Then Begin NotExist; Exit; End;
IF (Errors<> [0]) Then Exit;
RemSettings(FM);
SortLines: =False;
SpecialSort: =False;
UniversalSort;
RestoreSettings(FM);
End;
Function Matrix. CuanZeeroinLine(L1: Integer): Integer;
Var i: Integer;
Sum: Integer;
Begin
IF Not Exist Then Begin NotExist; CuanZeeroError; Exit; End;
IF (Errors<> [0]) Then Begin CuanZeeroError; Exit; End;
Sum: =0;
IF Not SpecialSort
Then
For i: =1 to CBars do IF GetE(L1, i) =0 Then Inc(Sum) else
Else
IF BeginZeero
Then
Begin
Sum: =1;
While (GetE(L1,Sum) =0) and (Sum<=CBars) do inc(Sum);
Dec(Sum);
End
Else
Begin
Sum: =CBars;
While (GetE(L1,Sum) =0) and (Sum>0) do Dec(Sum);
Sum: =CBars-Sum;
End;
CuanZeeroinLine: =Sum;
End;
Procedure Matrix. SwapLines(L1,L2: Integer);
Var Prom: TOE;
i: Integer;
Begin
IF Not Exist Then Begin NotExist; SwapError; Exit; End;
IF (Errors<> [0]) Then Begin SwapError; Exit; End;
For i: =1 to CBars do
Begin
Prom: =GetE(L1, i);
SetE(L1, i,GetE(L2, i));
SetE(L2, i,Prom)
End;
End;
Procedure Matrix. ZeeroSortLines;
VAr FM: Mem;
Begin
IF Not Exist Then Begin NotExist; Exit; End;
IF (Errors<> [0]) Then Exit;
RemSettings(FM);
SortLines: =True;
SpecialSort: =False;
UniversalSort;
RestoreSettings(FM);
End;
Procedure Matrix. UniversalSort;
Var i,j: Integer;
Max,NMax,CZ: Integer;
Cuan: Integer;
Begin
IF Not Exist Then Begin NotExist; SortError; Exit; End;
IF (Errors<> [0]) Then Begin SortError; Exit; End;
IF SortLines Then Cuan: =CLines
Else Cuan: =CBars;
For i: =1 to Cuan do
Begin
IF SortLines Then Max: =CuanZeeroInLine(i)
Else Max: =CuanZeeroInBar(i);
Nmax: =i;
For j: =i to Cuan do
Begin
IF SortLines Then CZ: =CuanZeeroInLine(j)
Else CZ: =CuanZeeroInBar(j);
IF (CZ<Max) xor Direction
Then
Begin
Max: =CZ;
NMax: =j;
End;
End;
IF i<>NMax Then
Begin
IF SortLInes Then SwapLines(i,NMax)
Else SwapBars(i,NMax);
Inc(Chek);
End;
End;
End;
Function Matrix. DetWithGauss: TOE;
Var i,j: Integer;
K: TOE;
P: TOE;
S: Matrix;
Si,Sj: Integer;
Procedure SortLinesOfTheBar(B1: Integer);
Var i: Integer;
Max: TOE;
nMax: Integer;
Begin
Max: =S. GetE(1,B1);
nMax: =1;
For i: =2 to S. Clines do
IF Abs(Max) <Abs(S. GetE(i,B1))
Then
Begin
Max: =S. GetE(i,B1);
nMAx: =i;
End;
IF S. Clines<>nMAx Then
Begin
S. SwapLines(S. Clines,nMAx);
Inc(S. Chek);
End;
End;
Procedure AddLines(l1,l2: Integer; K: TOE);
Var i: Integer;
Begin
For i: =1 to S. CBars do
S. SetE(l2, i,(S. GetE(l2, i) - S. GetE(l1, i) *K));
End;
Procedure InitObject;
Var i,j: Integer;
Ver: TOE;
Begin
Si: =0;
Sj: =0;
For i: =1 to CLines do IF not (i in Lin) Then Inc(Si);
For j: =1 to CBars do IF not (j in Bar) Then Inc(sj);
S. VMT;
S. DataInit(Si,Sj);
Si: =0;
For i: =1 to CLines do
IF not (i in Lin) Then
Begin
Inc(Si);
Sj: =0;
For j: =1 to CBars do
IF not (j in Bar) Then
Begin
Inc(sj);
Ver: =GetE(i,j);
S. SetE(Si,Sj,Ver);
End
End;
End;
Begin
IF Not Exist Then Begin NotExist; DGaussError; Exit; End;
IF (Errors<> [0]) Then Begin DGaussError; Exit; End;
IF CBars<>CLines Then Begin MNotSquare; DGaussError; Exit; End;
InitObject;
IF S. CBars<>S. CLines Then Begin MNotSquare; DGaussError; Exit; End;
For i: =Si downto 2 do
Begin
S. Clines: =i;
SortLinesOfTheBar(i);
S. Clines: =Si;
IF S. GetE(i, i) =0 Then Begin DetWithGauss: =0; Exit; End;
For j: =i-1 downto 1 do
IF S. GetE(j, i) <>0 Then
Begin
K: =S. GetE(j, i) /S. GetE(i, i);
AddLines(i,j,K);
End;
End;
P: =1;
S. Clines: =Si;
S. CBars: =Sj;
For i: =1 to S. Clines do
P: =P*S. GetE(i, i);
DetWithGauss: =P*S. Sign(S. Chek);
S. Del;
End;
Function Matrix. Sign;
Begin
IF (C div 2) *2=C Then Sign: =1.0 Else Sign: =-1.0;
End;
Procedure Matrix. SpecialSortLines;
VAr FM: Mem;
Begin
IF Not Exist Then Begin NotExist; Exit; End;
IF (Errors<> [0]) Then Exit;
RemSettings(FM);
SpecialSort: =True;
SortLines: =True;
UniversalSort;
RestoreSettings(FM);
End;
Procedure Matrix. SpecialSortBars;
VAr FM: Mem;
Begin
IF Not Exist Then Begin NotExist; Exit; End;
IF (Errors<> [0]) Then Exit;