Аналитическое дифференцирование / DERIVAT2

uses Crt, Inform, Trf2;


var

Size : Integer;

function getF(var M:sMas;var I:Integer;var Code:Byte):Boolean;
var
Get:Boolean;
begin
get := false;
If (ord(M[I]) = 251) then
begin
Code := 12;
get := true;
I := I + 1;
end;
If (M[I] = 's') and (M[I+1] = 'i') and (M[I+2] = 'n') then
begin
Code := 6;
get:=true;
I:=I+3
end;
If (M[I] = 'c') and (M[I+1] = 'o') and (M[I+2] = 's') then
begin
Code := 7;
get:=true;
I:=I+3
end;
If (M[I] = 'a') and (M[I+1] = 's') and (M[I+2] = 'i') then
begin
Code := 8;
get:=true;
I:=I+3
end;
If (M[I] = 'a') and (M[I+1] = 't') and (M[I+2] = 'g') then
begin
Code := 9;
get:=true;
I:=I+3
end;
If (M[I] = 'l') and (M[I+1] = 'o') and (M[I+2] = 'g') then
begin
Code := 10;
get:=true;
I:=I+3
end;
If (M[I] = 'e') and (M[I+1] = 'x') and (M[I+2] = 'p') then
begin
Code := 11;
get:=true;
I:=I+3
end;
GetF := Get
end;

function GetConst(var M:sMas;var I:Integer; var S : String; MaxNum:Integer):Boolean;
var
Del,Exit,Get:Boolean;
H: Text;
begin
assign(H,'H1.txt');
rewrite(H);
Get := False;
Del := false;
If (M[I] >= 'a') and (M[I] <= 'z') then
begin
Get := true;
I := I + 1;
S := M[I - 1]
end
else
begin
Exit := false;
while not(Exit) do
begin
If I <= MaxNum then

If (M[I] >= '0') and (M[I] <= '9') then
begin
Get := true;
write(H,M[I]);
I := I + 1;
end
else If M[I] = '.' then
If Del then
Exit := true
else
begin
Get := true;
write(H,'.');
I := I + 1;
Del := true
end
else
Exit := true
else
Exit := true
end;
reset(H);
If Get then
read(H,S)
end;

close(H);
GetConst := Get
end;

function NumConst(var S : String) : Boolean;
var
I : Integer;
Flag,Ans,Exit : Boolean;
begin
I := 1;
Flag := false;
Ans := true;
Exit := false;
while not(Exit) and (I <= length(S)) do
begin
If ((S[I] < '0') or (S[I] > '9')) then
If (S[I] = '.') and not(Flag) then
begin
Flag := true;
I := I + 1
end
else
begin
Ans := false;
Exit := true
end
else
I := I + 1
end;
NumConst := Ans
end;

procedure Mode(var F:Text);
var
M : sMas;
C : Char;
I,J : Integer;
begin
reset(F);
I := 0 ;
while not(Eof(F)) do
begin
Read(F,C);
If not((ord(C) = 32) or (ord(C) = 13)) then
If (C >= 'A') and (C <= 'Z') then
begin
I := I + 1;
M[I] := chr(ord(C)-ord('A')+ord('a'))
end
else
begin
I := I + 1;
M[I] := C
end
end;
rewrite(F);
For J := 1 to I do
write(F,M[J])
end;

Function DataAn(var F:Text;var OpM:uMas;var CoM:cMas):Boolean;
var
M : sMas;
C : Char;
I,J,MaxNum,BrNum,K,P : Integer;
Exit,Answer,State:Boolean;
S : String;
begin
Mode(F);
reset(F);
I := 1;
while not(Eof(F)) do
begin
Read(F,C);
M[I] := C;
I := I + 1
end;
close(F);
MaxNum := I - 1;
BrNum := 0;
Exit := false;
I := 1;
J := I;
Answer := false;
State := false;
while (I <= MaxNum) and not(Exit) do
begin
C := M[I];
write(C);
K := I;
If C = '(' then
If State then
begin
writeln;
writeln('It is not a good place for "("');
readkey;
Exit := true;
answer := false
end
else
begin
BrNum := BrNum + 1;
I := I + 1
end
else
If C = ')' then
If (State and (BrNum > 0)) then
begin
BrNum := BrNum - 1;
I := I + 1
end
else
begin
writeln;
writeln('It is not a good place for ")"');
readkey;
Exit := true;
answer := false
end
else If C = '-' then
If State then
begin
OpM[J].Op.Num := false;
Opm[J].Op.Code := 3;
Opm[J].Prior := BrNum * 4 + 1;
State := false;
I := I + 1;
J := J + 1
end
else
begin
OpM[J].Op.Num := true;
CoM[J] := '-1';
OpM[J].Prior := 255;
OpM[J + 1].Op.Num := false;
Opm[J + 1].Op.Code := 4;
Opm[J + 1].Prior := BrNum * 4 + 2;
J := J + 2;
I := I + 1
end
else
If (C = '+') or (C = '*') or (C = '/') or (C = '^') then
If State then
begin
OpM[J].Op.Num := false;
If C = '+' then
begin
Opm[J].Op.Code := 2;
Opm[J].Prior := BrNum * 4 + 1;
J := J + 1;
I := I + 1;
State := false
end;
If (C = '*') then
begin
Opm[J].Op.Code := 4;
Opm[J].Prior := BrNum * 4 + 2;
J := J + 1;
I := I + 1;
State := false
end;
If (C = '/') then
begin
Opm[J].Op.Code := 5;
Opm[J].Prior := BrNum * 4 + 2;
J := J + 1;
I := I + 1;
State := false
end;
If (C = '^') then
begin
Opm[J].Op.Code := 16;
Opm[J].Prior := BrNum * 4 + 3;
J := J + 1;
I := I + 1;
K := I;
If (GetConst(M,I,S,MaxNum)) and (NumConst(S))then
begin
For P := K to I - 1 do
write(M[P]);
OpM[J].Op.Num := true;
CoM[J] := S;
OpM[J].Prior := 255;
J := J + 1;
State := true
end
else
begin
writeln;
writeln('There should be a constant greater then zero...');
readkey;
Exit := true;
answer := false
end
end
end
else
begin
writeln;
writeln('It is not a good place for ',C);
readkey;
Exit := true;
answer := false
end
else
If GetF(M,I,OpM[J].op.Code) and (I - 1 <= MaxNum) then
If not(State) then
begin
For P := K + 1 to I do
write(M[P]);
If M[I] = '(' then
begin
OpM[J].Op.Num := false;
OpM[J].Prior := BrNum * 4 + 4;
BrNum := BrNum + 1;
J := J + 1;
I := I + 1
end
else
begin
writeln;
writeln;
writeln('There should be "("');
readkey;
Exit := true
end
end
else
begin
For P := K + 1 to I - 1 do
write(M[P]);
writeln;
writeln('Not a good place for this');
readkey;
Exit := true
end
else
If GetConst(M,I,S,MaxNum) and (I - 1 <= MaxNum) then
If not(State) then
begin
For P := K + 1 to I - 1 do
write(M[P]);
OpM[J].Op.Num := true;
CoM[J] := S;
OpM[J].Prior := 255;
J := J + 1;
State := true
end
else
begin
For P := K + 1 to I - 1 do
write(M[P]);
writeln;
writeln('Not a good place for this');
readkey;
Exit := true
end
else
begin
writeln;
writeln('Not a good place for this');
readkey;
Exit := true
end

end;
If BrNum <> 0 then
begin
writeln;
writeln;
writeln('Not enough ")"');
Exit := true
end;
DataAn := not(Exit);
Size := J - 1
end;

procedure GetConMas(var CoM : cMas; var M : sMas; var Size1,Size2 : Integer);
var
I,J : Integer;
begin
J := 0;
For I := 1 to Size1 do
If ((length(Com[I]) = 1)) and (CoM[I][1] <= 'z') and (CoM[I][1] >= 'a') then
begin
J := J + 1;
M[J] := CoM[I][1]
end;
Size2 := J
end;

function placed(var M : sMas; Size : Integer; Ch : Char) : Boolean;
var
I : Integer;
Ans : Boolean;
begin
Ans := false;
I := 1;
while (I <= Size) and not(Ans) do
begin
If M[I] = Ch then
Ans := true;
I := I + 1
end;
placed := Ans;
end;

procedure GetString(var S : tStr);
var
I,J : Integer;
Exit : Boolean;
begin
Exit := false;
I := -1;
J := 1;
while not(Exit) do
begin
I := ord(readkey);
If (I<>13) and (I<>32) and (I<>27) then
begin
write(chr(I));
S.S[J] := chr(I);
J := J + 1
end
else
Exit := true
end;
S.Len := J - 1;
end;

var
OpM: uMas;
Com: cMas;
M : sMas;
F,H,Fo,Fout: Text;
I,K,L,Ch:Integer;
S,S2:String;
R:pTree;
E,Exit,A : Boolean;
C,Cha : Char;
S3 : tStr;
begin
clrscr;
TextColor(White);
writeln('Input a name of the used file: ');
GetString(S3);
assign(H,'H.txt');
rewrite(H);
A := false;
If (S3.S[S3.Len] = 't') and (S3.S[S3.Len-1] = 'x')
and (S3.S[S3.Len-2] = 't') and (S3.S[S3.Len-3] = '.') then
A := true;
for I := 1 to S3.Len do
write(H,S3.S[I]);
If not(A) then
write(H,'.txt');
reset(H);
read(H,S2);
close(H);
assign(F,S2);

assign(H,'H.txt');
assign(Fout,'fout.txt');
rewrite(Fout);

reset(F);
rewrite(H);
while not(Eof(F)) do
begin
Read(F,C);
write(H,C)
end;
writeln;
writeln;
E := false;
while not(E) do
begin
writeln('The function is: ');
If DataAn(H,OpM,CoM) then
begin
readkey;
create(R);
writeln;
K := 1;
L := Size;
MakeTree(R,Opm,K,L);
GetConMas(CoM,M,Size,K);

writeln;
Ch := 0;
while (Ch < ord('a')) or (Ch > ord('z')) do
begin
write('Input a derivation variable: ');
Ch := ord(readkey);
writeln(Chr(Ch));
writeln;
writeln;
end;
if placed(M,K,chr(Ch)) then
begin
S := Chr(Ch);
FillStartCond(R,OpM,CoM,S);
writeln;
writeln;
writeln('The operation tree is: ');
writeln;
writeln;
DrawTree(R,OpM,CoM,0);
readkey;
If Derivate(R,OpM,CoM) then;
clrscr;
write('F(',chr(Ch),')=');
write(Fout,'F(',chr(Ch),')=');
For I := 1 to R^.Func.Len do
begin
write(R^.Func.S[I]);
write(Fout,R^.Func.S[I]);
end;
writeln;
writeln;
writeln(Fout);
write('F`(',Chr(Ch),')=');
write(Fout,'F`(',Chr(Ch),')=');
assign(H,'H.txt');
rewrite(H);
For I := 1 to R^.Der.Len do
begin
write(R^.der.S[I]);
write(Fout,R^.der.S[I]);
write(H,R^.Der.S[I])
end;
writeln(Fout);
writeln(Fout);
readkey;
Dispose(R);
reset(H)
end
else
begin
write('F(',chr(Ch),')=');
write(Fout,'F(',chr(Ch),')=');
reset(H);
while not(Eof(H)) do
begin
read(H,Cha);
write(Cha);
write(Fout,Cha);
end;
writeln;
writeln;
writeln(Fout);
write('F`(',Chr(Ch),')=0');
write(Fout,'F`(',Chr(Ch),')=0');
writeln(Fout);
writeln(Fout);
assign(H,'H.txt');
rewrite(H);
write(H,'0');
reset(H);
readkey
end;

clrscr;
Exit := false;
while not(Exit) do
begin
clrscr;
write('Continue the derivation? (y/n) ');
C := readkey;
writeln(C);
If (C = 'y') or (C = 'Y') then
begin
Exit := true;
E := false
end;
If (C = 'N') or (C = 'n') then
begin
Exit := true;
E := true
end
end
{DrawTree(R,OpM,CoM,0);}
end
else
begin
writeln;
writeln;
writeln;
writeln('The function is incorrect!');
E := true
end;
writeln;
writeln;
end;

close(Fout)
end.