Найти ошибку в построении бинарного дерева - Pascal ABC

//uses
   // crt;
 
const
    zn = ['+', '-', '/', '*'];
 
type
    TFpile = ^TFpilenode;//Описание типа указателя на узел дерева
    TFpilenode = record //Описание типа узла дерева
        znak: char;
        chislo: real;
        perem: string[1]; //Информационное поле
        TFleft, TFright: TFpile; //Указатели на левый и правый следующие узлы
        next: TFpile
    end;
    {pt_1 = ^el_1;
    el_1 = Record //описание стека для первой части программы
        data: Char;
        next: pt_1;
    End;}
    oper = set of char;
 
var
    result_a: TFpile; //Статическая переменная – указатель на корень
    s_base, s_base1: string; //Входная строка
    count: integer;
    y: real;
    ch: char;
    i, j: integer;
    f: Boolean;
    rez_1: String;//строка с постинфиксной формой
    count_b: real;
 
(*procedure WriteStack_1(var u: pt_1; dig: Char);
//запись в стек
//u – указатель на начало стека
//dig – значение символа, которое записывается в стек
var
    x: pt_1;
begin
    New(x);
    x^.data := dig; x^.next := u;
    u := x;
end;
 
procedure ReadStack_1(var u: pt_1; var dig: Char);
//извлечение из стека
//u – указатель на начало стека
//dig – значение символа, которое извлекается из стека
var
    x: pt_1;
begin
    dig := u^.Data;
    x := u;
    u := u^.Next; Dispose(x);
end;
 
function Priority(c: Char): Byte;
var
    R: Byte;
begin
    R := 0;
    case c of
        '+', '-': R := 1;
        '*', '/': R := 2;
    end;
    Priority := R;
end;
 
function Free_1(u: pt_1): Boolean;
//u – указатель на начало стека
begin
    if u = nil Then Free_1 := False Else Free_1 := True;
end;
 
procedure Convert_expression(var a: String; var z: String);
var
    head: pt_1;
    i: Integer;
    w: Char;
begin
    head := nil;z := '';
    i := 1;
    while i <= Length(a) Do
    begin
        case a[i] of
            '0'..'9': z := z + a[i];
            '(': WriteStack_1(head, a[i]);
            ')': 
                begin //Считываем из стека до символа «(»
                    ReadStack_1(head, w);
                    while w <> '(' Do
                    begin z := z + w; ReadStack_1(head, w); end;
                end;
            '+', '-', '*', '/':
                begin
                    if not Free_1(head) Then WriteStack_1(head, a[i])
                    else
                    begin
                        w := head^.data;
                        while Free_1(head) and (Priority(head^.data) >= Priority(a[i])) 
                        do
                        begin ReadStack_1(head, w);z := z + w; end;
                        WriteStack_1(head, a[i]);
                    end;
                end;
        End;
        Inc(i);
    end;
    //Дополняем строку символами операций, запомненных в стеке
    while Free_1(head) Do begin ReadStack_1(head, w); z := z + w; end;
end;*)
{ **************************** PROCEDURE FOR BUILD TREE ************************ }

procedure PrintTree(root: TFpile);//печать дерева
begin
    if root <> nil then begin
        if (root^.tfleft <> nil) or (root^.tfright <> nil) then write('( ');
        PrintTree(root^.tfleft);
        if root^.znak <> #0 then write(' ', root^.znak, ' ')
        else if root^.perem <> '' then write(root^.perem, ' ')
        else if root^.chislo <> Maxint then write(root^.chislo, ' ')
        else write('ERROR4');
        PrintTree(root^.tfright);
        if (root^.tfleft <> nil) or (root^.tfright <> nil) then Write(')');
    end;
end;
 
procedure Build_Base(s: string; var root: Tfpile);
var
    k, i: Byte;
    x, err: integer;
    work: array[1..255] of integer;
    s1: string;
    //Функция определения места очередного знака из множества op в s
    function SearchOp(s: string; op: oper): Byte;
    var
        i, n, k, x: Byte;
    begin
        n := length(s);
        i := n;
        k := 0;
        while (i >= 1) and not (S[i] in op) do dec(i);
        if i < 1 then SearchOp := 0
        else if s[i] in op then SearchOp := i
        else begin
            if s[i] = '(' then begin
                writeln('Error1'); //Halt
            end;
            if s[i] = ')' then begin
                k := 1;
                while (i >= 1) and (k > 0) do 
                begin
                    i := i - 1;
                    if s[i] = ')' then k := k + 1;
                    if s[i] = '(' then k := k - 1;
                end;
                if (i < 1) then SearchOp := 0
                else if k < 0 then begin
                    writeln('Error2'); //Halt
                end
                else begin
                    x := SearchOp(copy(s, 1, i - 1), op);
                    if x > 0 then SearchOp := x
                    else SearchOp := 0;
                end;
            end;
        end;
    end;
 
begin
    //определяем корректность расстановки скобок
    k := 0;
    for i := 1 to length(s) do 
    begin
        if s[i] = '(' then k := k + 1;
        work[i] := k;
        if s[i] = ')' then k := k - 1;
    end;
    //Если в выражении первый символ открывающая скобка, а последний
    //символ – закрывающая скобка и эти скобки образуют пару, удаляем их
    if (work[1] = 1) and (work[length(s)] = 1) then begin
        k := 0;
        for i := 1 to length(s) do
            if work[i] = 0 then k := k + 1;
        if k = 0 then s := copy(s, 2, length(s) - 1);
    end;
    //ищем операцию * или /
    k := SearchOp(s, ['*', '/']);
    if k > 0 then begin
        new(root);
        root^.znak := s[k];
        root^.perem := '';
        root^.chislo := Maxint;
            Build_Base(copy(s, k + 1, length(s) - k), root^.tfright);
            Build_Base(copy(s, 1, k - 1), root^.tfleft);
    end
    else begin
            //Ищем операции + или -
        k := SearchOp(s, ['+', '-']);
        if k > 0 then begin
            new(root);
            root^.znak := s[k];
            root^.perem := '';
            root^.chislo := Maxint;
            Build_Base(copy(s, k + 1, length(s) - k), root^.tfright);
            Build_Base(copy(s, 1, k - 1), root^.tfleft);
        end
        else begin
                    //Знаков операция не найдено, ищем переменную
            if (length(s) = 1) and (lowcase(s[1]) in ['a'..'z']) then begin
                new(root);
                root^.znak := #0;
                root^.perem := s;
                writeln('Введите ', root^.perem, ':');
                readln(root^.chislo);
                root^.tfleft := nil;
                root^.tfright := nil;
            end
            else begin
                for i := 1 to length(s) do
                    if s[i] in ['0'..'9'] then s1 := s1 + s[i];
                s := s1;
                Val(s, x, err);
                if err = 0 then begin
                    new(root);
                    root^.znak := #0;
                    root^.perem := '';
                    root^.chislo := x;
                    root^.tfleft := nil;
                    root^.tfright := nil;
                end
                else begin
                    writeln('!!!FatalErrorOfHate!!!');
                end;
            end;
        end;
    end;
end;

{ **************************** PROCEDURE FOR COUNT ************************ }
procedure count_(var root: TFpile);//Функция вычисления результата
begin
    if root <> nil then begin
        count_(root^.tfleft);
        count_(root^.tfright);
        if root^.znak <> #0 then 
            if root^.znak = '/' then root^.chislo := root^.TFleft^.chislo / root^.TFright^.chislo else
            if root^.znak = '*' then root^.chislo := root^.TFleft^.chislo * root^.TFright^.chislo else
            if root^.znak = '+' then root^.chislo := root^.TFleft^.chislo + root^.TFright^.chislo else
            if root^.znak = '-' then root^.chislo := root^.TFleft^.chislo - root^.TFright^.chislo;
    end; 
end;
 
{ **************************** PROCEDURE FOR ANALYSIS AND REGENERATION ************************ }
procedure Regeneration(var s_regen: string);
var
    k_length, i_count: integer;
begin
    while s_regen[1] = ' ' do delete(s_regen, 1, 1); //Удаляем лишние пробелы в начале
    while s_regen[length(s_regen)] = ' ' do delete(s_regen, length(s_regen), 1);//и в конце строки
    if pos(' ', s_regen) <> 0 then begin//Если есть пробелы в формуле,удаляем
        i_count := 1;
        k_length := length(s_regen);
        while i_count <> k_length do 
        begin
            if s_regen[i_count] = ' ' then begin//Является ли данный символ пробелом
                delete(s_regen, i_count, 1);
                dec(k_length);
                dec(i_count);
            end;
            inc(i_count);
        end end
end;
 
{ **************************** PROCEDURE FOR ANALYSIS ************************ }
function working_7(s_work: string): boolean;
var
    count: integer; k_count: integer;
    symbols_of_open_close: array[1..255] of integer;
    working_index: boolean;
begin
    working_7 := false;
    working_index := true;
    for count := 1 to length(s_work) do
        if not (s_work[count] in ['A'..'Z', 'a'..'z', '0'..'9', '+', '-', '*', '/', '(', ')']) then
            working_index := false;
    if working_index then begin
        for count := 1 to length(s_work) do 
        begin
            if s_work[count] = '(' then inc(k_count);
            symbols_of_open_close[count] := k_count;
            if s_work[count] = ')' then dec(k_count);
        end;
        working_7 := not (odd(k_count));
        if (symbols_of_open_close[1] = 1) and (symbols_of_open_close[length(s_work)] = 1) then begin
            k_count := 0;
            for count := 1 to length(s_work) do
                if symbols_of_open_close[count] = 0 then inc(k_count);
            if k_count = 0 then s_work := copy(s_work, 2, length(s_work) - 2);
        end;
    end;
end;
 
{ **************************** PROCEDURE FOR PRECHANGE ************************ }
procedure PreChange(var s_change: String);
var
    count_word: longword; length_s_change: integer;
begin
    length_s_change := length(s_change);
    if s_change[1] = '-' then
        s_change := '0' + s_change;
    count_word := 1;
    while count_word <= length_s_change do
        if (s_change[count_word] = '(') and (s_change[count_word + 1] = '-') then
            insert('0', s_change, count_word + 1)
        else
            Inc(count_word);
end;
 
procedure be_easy(var root: tfpile);
begin
    if root <> nil then begin
        be_easy(root^.tfleft);
        if root^.znak <> #0 then 
            if (root^.znak = '/') and (root^.tfleft^.znak = '/')
                then root^.znak := '*';
    end; end;
{ **************************** PROGRAMM BODY ************************ }
begin
    writeln('!ACHTUNG! Программа расчитана на работу только с функции в инфиксной форме,при попытке ввода постфиксной формы вы не получите рез-ов.');
    repeat
        writeln('Введите выражение:');
        readln(s_base); //Вводим строку
        regeneration(s_base);//Удаление пробелов и лишних скобок
        Prechange(s_base);
        count_b := 1;
        if working_7(s_base) then begin//Проверка на работоспособности функции
            if s_base <> '' Then
                    //Convert_expression(s_base, rez_1);//преобразование в постинфиксную форму
                //writeln(rez_1);
                new(result_a); //Создаем корень дерева
                //writeln(s_base);
            {for i := length(s_base) downto 1 do begin
            if s_base[i]=')' then s_base1 := s_base1+'('
            else if s_base[i]='(' then s_base1 := s_base1+')'
            else
                    s_base1 := s_base1+s_base[i];
                    end;
            writeln(s_base1);}
            build_base(s_base, result_a); //Строим дерева
            printtree(result_a);
            writeln;
            be_easy(result_a);
            printtree(result_a);
            writeln;
            writeln('Результат подсчета выражения:');
            count_(result_a);//Печать значения функции
            writeln(result_a^.chislo:5:2);
        end
        else writeln('Функция имеет ошибку,повторите ввод.');
        writeln('Повторить ввод выражения? (Y/N)');
        readln(ch);
    until UpCase(ch) = 'N';
end.

procedure Build_Base(s: string; var root: Tfpile);
var
k, i: Byte;
x, err: integer;
work: array[1..255] of integer;
s1: string;
//Функция определения места очередного знака из множества op в s
function SearchOp(s: string; op: oper): Byte;
var
i, n, k, x: Byte;
begin
n := length(s);
i := n;
k := 0;
while (i >= 1) and not (S[i] in op) do dec(i);
if i < 1 then SearchOp := 0
else if s[i] in op then SearchOp := i
else begin
if s[i] = '(' then begin
writeln('Error1'); //Halt
end;
if s[i] = ')' then begin
k := 1;
while (i >= 1) and (k > 0) do 
begin
i := i - 1;
if s[i] = ')' then k := k + 1;
if s[i] = '(' then k := k - 1;
end;
if (i < 1) then SearchOp := 0
else if k < 0 then begin
writeln('Error2'); //Halt
end
else begin
x := SearchOp(copy(s, 1, i - 1), op);
if x > 0 then SearchOp := x
else SearchOp := 0;
end;
end;
end;
end;
 
begin
//определяем корректность расстановки скобок
k := 0;
for i := 1 to length(s) do 
begin
if s[i] = '(' then k := k + 1;
work[i] := k;
if s[i] = ')' then k := k - 1;
end;
//Если в выражении первый символ открывающая скобка, а последний
//символ – закрывающая скобка и эти скобки образуют пару, удаляем их
if (work[1] = 1) and (work[length(s)] = 1) then begin
k := 0;
for i := 1 to length(s) do
if work[i] = 0 then k := k + 1;
if k = 0 then s := copy(s, 2, length(s) - 1);
end;
//ищем операцию * или /
k := SearchOp(s, ['*', '/']);
if k > 0 then begin
new(root);
root^.znak := s[k];
root^.perem := '';
root^.chislo := Maxint;
Build_Base(copy(s, k + 1, length(s) - k), root^.tfright);
Build_Base(copy(s, 1, k - 1), root^.tfleft);
end
else begin
//Ищем операции + или -
k := SearchOp(s, ['+', '-']);
if k > 0 then begin
new(root);
root^.znak := s[k];
root^.perem := '';
root^.chislo := Maxint;
Build_Base(copy(s, k + 1, length(s) - k), root^.tfright);
Build_Base(copy(s, 1, k - 1), root^.tfleft);
end
else begin
//Знаков операция не найдено, ищем переменную
if (length(s) = 1) and (lowcase(s[1]) in ['a'..'z']) then begin
new(root);
root^.znak := #0;
root^.perem := s;
writeln('Введите ', root^.perem, ':');
readln(root^.chislo);
root^.tfleft := nil;
root^.tfright := nil;
end
else begin
for i := 1 to length(s) do
if s[i] in ['0'..'9'] then s1 := s1 + s[i];
s := s1;
Val(s, x, err);
if err = 0 then begin
new(root);
root^.znak := #0;
root^.perem := '';
root^.chislo := x;
root^.tfleft := nil;
root^.tfright := nil;
end
else begin
writeln('!!!FatalErrorOfHate!!!');
end;
end;
end;
end;
end;