Добавил:
Studfiles2
Опубликованный материал нарушает ваши авторские права? Сообщите нам.
Вуз:
Предмет:
Файл:Аналитическое дифференцирование / TRF2
.PASunit TrF2;
interface
Uses Crt, Inform;
var
Table: cMas;
procedure Create(var Root:pTree);
procedure DrawTreeF(var H : Text; var Root:pTree; var OpM : uMas; var CoM: cMas; Deg:Integer);
procedure DrawTree(var Root:pTree; var OpM : uMas; var CoM: cMas; Deg:Integer);
procedure FillStartCond(var Root:pTree; var OpM: uMas; var CoM : cMas;ActX: String);
procedure MakeTree(var Root : pTree; var OpM : uMas; var I,J: integer);
function Derivate(var Root : pTree; var OpM: uMas; var CoM : cMas):Boolean;
implementation
procedure Create(var Root:pTree);
begin
New(Root);
Root := Nil
end;
procedure Move(S : String; var tS : tStr);
var
H : Text;
C : Char;
begin
assign(H,'H.txt');
rewrite(H);
write(H,S);
reset(H);
tS.Len := 0;
while not Eof(H) do
begin
read(H,C);
tS.Len := tS.Len + 1;
tS.S[tS.Len] := C
end;
close(H)
end;
function FindMin(var OpM: uMas; I,J: Integer):Integer;
var
P,Rec: Integer;
begin
rec := I;
For P := I to J do
If OpM[P].Prior <= OpM[Rec].Prior then
Rec := P;
FindMin := Rec
end;
procedure FormCodeTable(var Tab : cMas);
begin
Tab[2] := '+';
Tab[3] := '-';
Tab[4] := '*';
Tab[5] := '/';
Tab[6] := 'sin';
Tab[7] := 'cos';
Tab[8] := 'asi';
Tab[9] := 'atg';
Tab[10] := 'log';
Tab[11] := 'exp';
Tab[12] := chr(251);
Tab[16] := '^'
end;
procedure MakeTree(var Root : pTree; var OpM : uMas; var I,J: integer);
var
P : Integer;
begin
If I = J then
begin
New(Root);
Root^.code := I;
Root^.left := nil;
Root^.right := nil;
end
else
begin
P := FindMin(OpM,I,J);
New(Root);
Root^.left := NIl;
Root^.Code := P;
P := P + 1;
MakeTree(Root^.right,OpM,P,J);
P := P - 1;
If (OpM[P].Op.Code < 6) or (OpM[P].Op.Code > 12) then
begin
P := P - 1;
MakeTree(Root^.left,OpM,I,P)
end
end
end;
procedure FindEnd(var Root,Pointer : pTree);
begin
If Root^.Left <> nil then
If (Root^.left^.left <> Nil) or (Root^.left^.right <> Nil) then
FindEnd(Root^.left,Pointer)
else
If (Root^.Right^.left <> Nil) or (Root^.Right^.Right <> Nil) then
FindEnd(Root^.Right,Pointer)
else
Pointer := Root
else
If (Root^.Right^.left <> Nil) or (Root^.Right^.Right <> Nil) then
FindEnd(Root^.Right,Pointer)
else
Pointer := Root
end;
function IntNum(var S:tStr; var N:Integer):Boolean;
var
I : Integer;
Exit,Ans : Boolean;
begin
Exit := false;
Ans := true;
I := 1;
N := 0;
While not(Exit) and (I <= S.Len) do
begin
If (S.S[I] >= '0') and (S.S[I] <= '9') then
begin
N := N*10 + ord(S.S[I]) - ord('0');
I := I + 1
end
else
begin
Exit := true;
Ans := false
end
end;
IntNum := Ans;
end;
procedure NtoS(var N : Integer; var S:tStr);
var
H : Text;
SSS : String;
begin
assign(H,'H.txt');
rewrite(H);
write(H,N);
reset(H);
read(H,SSS);
close(H);
Move(SSS,S);
end;
procedure Push(var from,where: tStr;Start:Integer);
var
I : Integer;
begin
where.Len := From.Len + Start - 1;
For I := 1 to From.Len do
Where.S[I + Start - 1] := From.S[I]
end;
function Zero(var S : tStr):Boolean;
begin
If (S.len = 1) and (S.S[1] = '0') then
Zero := true
else
Zero := false
end;
function One(var S : tStr):Boolean;
begin
If (S.len = 1) and (S.S[1] = '1') then
One := true
else
One := false
end;
function mOne(var S : tStr):Boolean;
begin
If (S.len = 2) and (S.S[1] = '-') and (S.S[2] = '1') then
mOne := true
else
mOne := false
end;
function Equil(var S1,S2 : tStr): Boolean;
var
I : Integer;
E : Boolean;
begin
E := false;
If S1.Len = S2.Len then
begin
For I := 1 to S1.Len do
If S1.S[I] <> S2.S[I] then
E := true
end
else
E := true;
Equil := not(E)
end;
function InOp(var A: tStr):Boolean;
var
I : Integer;
E : Boolean;
begin
E := false;
I := 1;
while (I <= A.Len) and not(E) do
begin
If (A.S[I] = '+') or (A.S[I] = '-') then
E := true;
I := I + 1
end;
InOp := E
end;
procedure Sum(var S1,S2,A : tStr);
var
X,Y:Integer;
begin
If IntNum(S1,X) and IntNum(S2,Y) and (X <= 32767 - Y) then
begin
X := X + Y;
NtoS(X,A)
end
else If Zero(S1) and not(Zero(S2)) then
Push(S2,A,1)
else If Zero(S2) and not(Zero(S1)) then
Push(S1,A,1)
else If Zero(S1) and Zero(S2) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
If (One(S1) and mOne(S2)) or (mOne(S1) and One(S2)) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
begin
If Equil(S1,S2) then
If InOp(S1) then
begin
A.S[1] := '2';
A.S[2] := '*';
A.S[3] := '(';
Push(S1,A,4);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1
end
else
begin
A.S[1] := '2';
A.S[2] := '*';
Push(S1,A,3)
end
else
begin
Push(S1,A,1);
A.S[S1.Len + 1] := '+';
Push(S2,A,S1.Len + 2)
end
end;
end;
function InOp2(var A : tStr):Boolean;
var
I : Integer;
E : Boolean;
begin
E := false;
I := 1;
while (I <= A.Len) and not(E) do
begin
If (A.S[I] = '+') or (A.S[I] = '-') or (A.S[I] = '*') or (A.S[I] = '/') then
E := true;
I := I + 1
end;
InOp2 := E
end;
function InOp3(var A : tStr):Boolean;
begin
InOp3 := not(A.Len = 1)
end;
procedure Minus(var S1,S2,A : tStr);
var
X,Y : Integer;
begin
If IntNum(S1,X) and (IntNum(S2,Y)) and (X >= Y - 32768) then
begin
X := X - Y;
NtoS(X,A)
end
else If Zero(S1) and not(Zero(S2)) then
begin
A.S[1] := '-';
If InOp(S2) then
begin
A.S[2] := '(';
Push(S2,A,3);
A.S[S2.len + 3] := ')';
A.len := A.len + 1
end
else
Push(S2,A,2)
end
else If Zero(S2) and not(Zero(S1)) then
Push(S1,A,1)
else If Zero(S1) and Zero(S2) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
If (One(S1) and One(S2)) or (mOne(S1) and mOne(S2)) then
begin
A.Len := 1;
A.S[1] := '0';
end
else
begin
If Equil(S1,S2) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
begin
Push(S1,A,1);
A.S[S1.Len + 1] := '-';
If InOp(S2) then
begin
A.S[S1.len + 2] := '(';
Push(S2,A,S1.Len + 3);
A.S[S1.Len + S2.Len + 3] := ')';
A.Len := A.Len + 1
end
else
Push(S2,A,A.Len + 2)
end
end;
end;
procedure Mult(var S1,S2,A : tStr);
var
I,X,Y : Integer;
begin
If IntNum(S1,X) and (IntNum(S2,Y)) and ((Y = 0) or (X <= (32767 div Y)))then
begin
X := X*Y;
NtoS(X,A)
end
else If Zero(S1) or Zero(S2) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
If One(S1) then
Push(S2,A,1)
else
If One(S2) then
Push(S1,A,1)
else
If mOne(S1) and not(mOne(S2)) then
begin
A.S[1] := '-';
If InOp(S2) then
begin
A.S[2] := '(';
Push(S2,A,3);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S2,A,2)
end
else
If mOne(S2) and not(mOne(S1)) then
begin
A.S[1] := '-';
If InOp(S1) then
begin
A.S[2] := '(';
Push(S1,A,3);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S1,A,2)
end
else
If mOne(S1) and mOne(S2) then
begin
A.Len := 1;
A.S[1] := '1'
end
else
begin
If Equil(S1,S2) then
begin
If InOp2(S1) then
begin
A.S[1] := '(';
Push(S1,A,2);
A.S[A.Len + 1] := ')';
A.S[A.Len + 2] := '^';
A.S[A.Len + 3] := '2';
A.Len := A.Len + 3
end
else
begin
Push(S1,A,1);
A.S[A.Len + 1] := '^';
A.S[A.Len + 2] := '2';
A.Len := A.Len + 2
end
end
else
begin
If InOp(S1) then
begin
A.S[1] := '(';
Push(S1,A,2);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S1,A,1);
A.S[A.Len + 1] := '*';
A.Len := A.Len + 2;
If InOp(S2) then
begin
A.S[A.Len] := '(';
Push(S2,A,A.len + 1);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S2,A,A.Len)
end
end
end;
function Diviz(var S1,S2,A : tStr):Boolean;
var
X,Y:Integer;
begin
If IntNum(S1,X) and IntNum(S2,Y) and (X mod Y = 0) then
If Y = 0 then
begin
clrscr;
writeln('Divizion by zero!');
readkey;
Diviz := false
end
else
begin
X := X div Y;
NtoS(X,A)
end
else If Zero(S2) then
begin
clrscr;
writeln('Divizion by zero!');
readkey;
Diviz := false
end
else
begin
If Zero(S1) then
begin
A.Len := 1;
A.S[1] := '0';
end
else
If One(S2) then
Push(S1,A,1)
else
If One(S1) then
begin
A.S[1] := '1';
A.S[2] := '/';
If InOp2(S2) then
begin
A.S[3] := '(';
Push(S2,A,4);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S2,A,3)
end
else
If mOne(S2) and not(mOne(S1)) then
begin
A.S[1] := '-';
If InOp2(S1) then
begin
A.S[2] := '(';
Push(S1,A,3);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S1,A,2)
end
else
If mOne(S2) and mOne(S1) then
begin
A.Len := 1;
A.S[1] := '1'
end
else
begin
If Equil(S1,S2) then
begin
A.Len := 1;
A.S[1] := '1'
end
else
begin
If InOp2(S1) then
begin
A.S[1] := '(';
Push(S1,A,2);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1;
end
else
Push(S1,A,1);
A.S[A.Len + 1] := '/';
If InOp2(S2) then
begin
A.S[A.Len + 2] := '(';
Push(S2,A,A.Len + 3);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end
else
Push(S2,A,A.Len + 2)
end
end;
Diviz := true;
end
end;
function Sq(var S1, A : tStr) : Boolean;
begin
If One(S1) or Zero(S1) then
begin
Push(S1,A,1);
Sq := true
end
else
If mOne(S1) then
begin
clrscr;
writeln(chr(251),'(-1) is uncaculatable!');
Sq := false
end
else
begin
A.S[1] := chr(251);
A.S[2] := '(';
Push(S1,A,3);
A.Len := A.Len + 1;
A.S[A.Len] := ')';
sq := true
end
end;
function Deg(var S1,S2,A : tStr) : Boolean;
var
K : tStr;
E : Boolean;
begin
E := true;
If Zero(S1) then
If not Zero(S2) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
E := false
else
If mOne(S1) then
E := False
else
If Zero(S2) or One(S1) then
begin
A.Len := 1;
A.S[1] := '1'
end
else
If One(S2) then
Push(S1,A,1)
else
If mOne(S2) then
begin
K.Len := 1;
K.S[1] := '1';
If not(Diviz(K,S1,A)) then
E := false
end
else
begin
If InOp2(S1) then
begin
A.S[1] := '(';
Push(S1,A,2);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1
end
else
Push(S1,A,1);
A.S[A.Len + 1] := '^';
If InOp2(S2) then
begin
A.S[A.Len + 2] := '(';
Push(S2,A,A.Len + 3);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1
end
else
Push(S2,A,A.Len + 2)
end
end;
function Derivate(var Root : pTree; var OpM: uMas; var CoM : cMas):Boolean;
var
P : pTree;
F,G,F1,G1,A,dA,K,L,N,T : tStr;
I : Integer;
Error : Boolean;
begin
Error := false;
while (Root^.Right <> Nil) and not(Error) do
begin
FindEnd(Root,P);
If P^.left <> Nil then
begin
F := P^.left^.Func;
F1 := P^.left^.Der
end;
G := P^.right^.Func;
G1 := P^.right^.der;
If OpM[P^.Code].Op.Code = 2 then
begin
Sum(F,G,A);
Sum(F1,G1,dA)
end;
If OpM[P^.Code].Op.Code = 3 then
begin
Minus(F,G,A);
Minus(F1,G1,dA)
end;
If OpM[P^.Code].Op.Code = 4 then
begin
Mult(F,G,A);
Mult(F1,G,K);
Mult(G1,F,L);
Sum(K,L,dA)
end;
If OpM[P^.Code].Op.Code = 5 then
begin
If Diviz(F,G,A) then
begin
Mult(F1,G,K);
Mult(G1,F,L);
Minus(K,L,T);
Mult(G,G,K);
If not(Diviz(T,K,dA)) then
Error := true
end
else
Error := true
end;
If OpM[P^.Code].Op.Code = 6 then
begin
If Zero(G) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
begin
A.S[1] := 's';
A.S[2] := 'i';
A.S[3] := 'n';
A.S[4] := '(';
Push(G,A,5);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end;
If Zero(G1) then
begin
K.Len := 1;
K.S[1] := '1'
end
else
begin
K.S[1] := 'c';
K.S[2] := 'o';
K.S[3] := 's';
K.S[4] := '(';
Push(G,K,5);
K.Len := K.Len + 1;
K.S[K.Len] := ')'
end;
Mult(K,G1,dA)
end;
If OpM[P^.Code].Op.Code = 7 then
begin
If Zero(G) then
begin
A.Len := 1;
A.S[1] := '1'
end
else
begin
A.S[1] := 'c';
A.S[2] := 'o';
A.S[3] := 's';
A.S[4] := '(';
Push(G,A,5);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end;
If Zero(G1) then
begin
K.Len := 1;
K.S[1] := '0'
end
else
begin
K.S[1] := '-';
K.S[2] := 's';
K.S[3] := 'i';
K.S[4] := 'n';
K.S[5] := '(';
Push(G,K,6);
K.Len := K.Len + 1;
K.S[K.Len] := ')'
end;
Mult(K,G1,dA)
end;
If OpM[P^.Code].Op.Code = 8 then
begin
If Zero(G) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
begin
A.S[1] := 'a';
A.S[2] := 's';
A.S[3] := 'i';
A.S[4] := '(';
Push(G,A,5);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end;
If Zero(G) then
begin
K.Len := 1;
K.S[1] := '1'
end
else
If One(G) or mOne(G) then
begin
K.Len := 1;
K.S[1] := '0'
end
else
begin
Mult(G,G,L);
N.Len := 1;
N.S[1] := '1';
Minus(N,L,T);
If not(Sq(T,K)) then
Error := true
end;
If not(Diviz(G1,K,dA)) then
Error := true
end;
If OpM[P^.Code].Op.Code = 9 then
begin
If Zero(G) then
begin
A.Len := 1;
A.S[1] := '0'
end
else
begin
A.S[1] := 'a';
A.S[2] := 't';
A.S[3] := 'g';
A.S[4] := '(';
Push(G,A,5);
A.Len := A.Len + 1;
A.S[A.Len] := ')'
end;
If Zero(G) then
begin
K.Len := 1;
K.S[1] := '1'
end
else
begin
Mult(G,G,L);
N.Len := 1;
N.S[1] := '1';
Sum(N,L,K)
end;
If not(Diviz(G1,K,dA)) then
Error := true
end;
If OpM[P^.Code].Op.Code = 10 then
begin
If (Zero(G) or mOne(G)) then
begin
clrscr;
writeln('Impossible for lg...');
readkey;
Error := true
end
else
If One(G) then
begin
A.len := 1;
A.S[1] := '0'
end
else
begin
A.S[1] := 'l';
A.S[2] := 'o';
A.S[3] := 'g';
A.S[4] := '(';
Push(G,A,5);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1
end;
If not(Diviz(G1,G,dA)) then
Error := true
end;
If OpM[P^.Code].Op.Code = 11 then
begin
If Zero(G) then
begin
G.Len := 1;
G.S[1] := '1'
end
else
begin
A.S[1] := 'e';
A.S[2] := 'x';
A.S[3] := 'p';
A.S[4] := '(';
Push(G,A,5);
A.S[A.Len + 1] := ')';
A.Len := A.Len + 1
end;
Mult(G1,A,dA)
end;
If OpM[P^.Code].Op.Code = 12 then
begin
If Sq(G,A) then
begin
L.Len := 1;
L.S[1] := '2';
If Sq(G,T) then
begin
Mult(L,T,K);
If not(Diviz(G1,K,dA)) then
Error := true
end
else
Error := true
end
else
Error := true
end;
If OpM[P^.Code].Op.Code = 16 then
begin
If Deg(F,G,A) then
begin
Push(G,K,1);
L.Len := 1;
L.S[1] := '1';
Minus(G,L,T);
If Deg(F,T,L) then
begin
Mult(G,L,T);
Mult(T,F1,dA)
end
else
Error := true
end
else
Error := True
end;
P^.left := Nil;
P^.Right := Nil;
{Dispose(P^.left);
Dispose(P^.Right);}
clrscr;
If not(Error) then
begin
P^.func := A;
P^.der := dA;
writeln;
writeln;
writeln('The operation tree is: ');
writeln;
writeln;
DrawTree(Root,OpM,CoM,0);
readkey
end
end;
Derivate := not(Error)
end;
procedure DrawSpaceF(var H: Text; Deg : Integer);
var
K : Integer;
begin
If Deg > 0 then
for K := 1 to Deg do
write(H,' ');
end;
procedure DrawTreeF(var H : Text; var Root:pTree; var OpM : uMas; var CoM: cMas; Deg:Integer);
var
I : Integer;
begin
If Root<>Nil then
begin
DrawTreeF(H,Root^.Right,OpM,CoM,deg+1);
DrawSpaceF(H,Deg);
write(H,' ');
TextColor(Red);
For I := 1 to Root^.func.Len do
write(H,Root^.func.S[I]);
TextColor(white);
writeln(H);
DrawSpaceF(H,Deg);
If OpM[Root^.Code].Op.Num = false then
writeln(H,Table[OpM[Root^.Code].Op.Code])
else
writeln(H,CoM[Root^.Code]);
DrawSpaceF(H,Deg);
write(H,' ');
TextColor(Blue);
For I := 1 to Root^.der.Len do
write(H,Root^.der.S[I]);
writeln(H);
DrawTreeF(H,Root^.left,OpM,CoM,deg+1);
TextColor(white)
end
else If Deg = 0 then
writeLn(H,'The Tree is empty...')
end;
procedure DrawSpace(Deg : Integer);
var
K : Integer;
begin
If Deg > 0 then
for K := 1 to Deg do
write(' ');
end;
procedure DrawTree(var Root:pTree; var OpM : uMas; var CoM: cMas; Deg:Integer);
var
I : Integer;
begin
If Root<>Nil then
begin
DrawTree(Root^.Right,OpM,CoM,deg+1);
DrawSpace(Deg);
write(' ');
TextColor(Red);
For I := 1 to Root^.func.Len do
write(Root^.func.S[I]);
TextColor(white);
writeln;
DrawSpace(Deg);
If OpM[Root^.Code].Op.Num = false then
writeln(Table[OpM[Root^.Code].Op.Code])
else
writeln(CoM[Root^.Code]);
DrawSpace(Deg);
write(' ');
TextColor(Blue);
For I := 1 to Root^.der.Len do
write(Root^.der.S[I]);
writeln;
DrawTree(Root^.left,OpM,CoM,deg+1);
TextColor(white)
end
else If Deg = 0 then
writeLn('The Tree is empty...')
end;
procedure FillStartCond(var Root:pTree; var OpM: uMas; var CoM : cMas;ActX: String);
var
T : pTree;
begin
T := Root;
If T^.left <> Nil then
FillStartCond(T^.Left,OpM,CoM,ActX);
If T^.Right <> Nil then
FillStartCond(T^.Right,OpM,CoM,ActX);
T^.Func.Len := 0;
T^.der.Len := 0;
If (T^.Right = Nil)and(T^.Left = Nil)and(OpM[T^.Code].Op.Num = true) then
begin
Move(CoM[T^.Code],T^.Func);
T^.Der.Len := 1;
If CoM[T^.Code] = ActX then
T^.der.S[1] := '1'
else
T^.der.S[1] := '0'
end
end;
begin
FormCodeTable(Table);
end.