Стек. Логическое выражение

uses
  CRT;
 
{
’а**б«пв®а «®ЈЁзҐбЄЁе ўла*¦Ґ*Ё©.
‚ў®¤Ёвбп «®ЈЁзҐбЄ®Ґ ўла*¦Ґ*ЁҐ Ё§ 0, 1, бЄ®Ў®Є Ё §**Є®ў «®ЈЁзҐбЄЁе ®ЇҐа*жЁ©.
’а**б«пв®а ЇҐаҐў®¤Ёв ўла*¦Ґ*ЁҐ ў Ї®бвдЁЄб*го §*ЇЁбм * §*⥬ ўлзЁб«пҐв ҐЈ® §**зҐ*ЁҐ.
}
 
const
  OperSet: set of char = ['+', '&', '*', '!', '(', ')', 'A', 'V', '>'];
 
var
  S: String;
  OutputString: String;
 
function DelSpase(S: String): String;
var
  T: String;
  I: Word;
begin
  T := '';
  for I := 1 To Length(S) Do 
  begin
    if S[I] <> ' ' Then T := T + S[I];
  end;
  DelSpase := T;
end;
 
function InfixPostfix(N: String): String;
var
  T: String;
  I, TopStack: Word;
  Stack: array [1..10] of Char;
  SymbTmp, Symb: Char;
  
  function ChToInt(C: Char): Integer;
  var
    Result: Integer;
  begin
    case C Of
      '(': Result := 0;
      ')': Result := 1;
      '+': Result := 2;
      'V': Result := 2;
      '*': Result := 3;
      '&': Result := 3;
      '>': Result := 3;
      'A': Result := 3;
      '!': Result := 4;
    End;
    ChToInt := Result;
  end;
  
  function PRCD(Ch1, Ch2: Char): Boolean;
  var
    Result: Boolean;
  begin
    if ChToInt(Ch1) >= ChToInt(Ch2) Then Result := True
    Else Result := False;
    if Ch2 = '(' Then Result := False;
    if Ch1 = '(' Then Result := False;
    if (Ch2 = ')') And (Ch1 <> '(') Then Result := True;
    if (Ch2 = '(') And (Ch1 = ')') Then Result := False;
    PRCD := Result;
  end;
  
  function Empty: Boolean;
  var
    Result: Boolean;
  begin
    if TopStack = 0 Then Result := True
    Else Result := False;
    Empty := Result;
  end;
  
  function TopStackSymb: Char;
  begin
    TopStackSymb := Stack[TopStack];
  end;
  
  procedure Push(Ch: Char);
  begin
    Inc(TopStack);
    Stack[TopStack] := Ch;
  end;
  
  function Pop: Char;
  begin
    Pop := Stack[TopStack];
    Stack[TopStack] := ' ';
    Dec(TopStack);
  end;
 
begin
  T := '';
  TopStack := 0;
  for I := 1 To 10 Do Stack[I] := ' ';
  for I := 1 To Length(N) Do 
  begin
    Symb := N[I];
    if Symb IN OperSet
    Then begin
      while not (Empty) And PRCD(TopStackSymb, Symb) Do 
      begin
        SymbTmp := Pop;
        T := T + SymbTmp;
      end;
      if (Empty) Or (Symb <> ')') Then Push(Symb) 
      Else SymbTmp := Pop;
    end Else T := T + Symb;
  end;
  while not (Empty) Do 
  begin
    SymbTmp := Pop;
    T := T + SymbTmp;
  end;
  InfixPostfix := T;
end;
 
 
function Sintax: Boolean;
var
  Skobka: Word;
  I: Word;
  F: Boolean;
  
  function Lexica(C: Char): Byte;
  var
    Result: Byte;
  begin
    case C Of
      '(': Result := 2;
      ')': Result := 3;
      '+': Result := 1;
      'V': Result := 1;
      '*': Result := 1;
      '&': Result := 1;
      'A': Result := 1;
      '>': Result := 1;
      '!': Result := 0;
      '0': Result := 4;
      '1': Result := 4;
    Else Result := 5
    End;
    Lexica := Result;
  end;
  
  procedure ERROR;
  begin
    F := False;
  end;
  
  procedure SOU; forward; {г**а*л© ®ЇҐа*в®а}
  
  procedure SOB; forward; {ЎЁ**а*л© ®ЇҐа*в®а}
  
  procedure SRO; forward; {а*§¤Ґ«ЁвҐ«м ®вЄалў*ойЁ©}
  
  procedure SRZ; forward; {а*§¤Ґ«ЁвҐ«м §*Єалў*ойЁ©}
  
  procedure SC; forward;  {зЁб«®}
  
  procedure SC;
  begin
    Inc(I);
    if F AND (I <= Length(S))
      Then case Lexica(S[I]) Of
        1: SOB;
        3: SRZ;
      Else ERROR
      End ;
  end;
  
  procedure SOU;
  begin
    Inc(I);
    if F AND (I <= Length(S))
      Then case Lexica(S[I]) Of
        2: SRO;
        4: SC;
      Else ERROR
      End 
    Else ERROR;
  end;
  
  procedure SOB;
  begin
    Inc(I);
    if F AND (I <= Length(S))
      Then case Lexica(S[I]) Of
        0: SOU;
        2: SRO;
        4: SC;
      Else ERROR
      End 
    Else ERROR;
  end;
  
  procedure SRO;
  begin
    Inc(Skobka);
    Inc(I);
    if F AND (I <= Length(S))
      Then case Lexica(S[I]) Of
        0: SOU;
        2: SRO;
        4: SC;
      Else ERROR
      End 
    Else ERROR;
  end;
  
  procedure SRZ;
  begin
    Dec(Skobka);
    Inc(I);
    if F AND (I <= Length(S))
      Then case Lexica(S[I]) Of
        1: SOB;
        3: SRZ;
      Else ERROR
      End ;
  end;
 
begin
  F := True;
  Skobka := 0;
  I := 1;
  if F Then case Lexica(S[I]) Of
      0: SOU;
      2: SRO;
      4: SC;
    Else ERROR
    End ;
  if Skobka <> 0 Then F := False;
  Sintax := F;
end;
 
function Calc(St: String): Boolean;
var
  I: Integer;
  Top: Integer;
  Stack: Array[1..10] Of Boolean;
  
  function CharToBool(N: Char): Boolean;
  begin
    if N = '0' Then CharToBool := FALSE;
    if N = '1' Then CharToBool := TRUE;
  end;
 
begin
  Top := 1;
  Stack[Top] := CharToBool(St[1]);
  
  for I := 2 To Length(St) Do 
  begin
    if St[I] IN OperSet
    Then begin
      case St[I] Of
        {Ё*ўҐабЁп}           '!': Stack[Top] := not (Stack[Top]);
        {Є®*ко*ЄжЁп} '&', 'A', '*': 
          begin
            Stack[Top - 1] := Stack[Top - 1] AND Stack[Top];
            Dec(Top);
          end;
        {¤Ё§ко*ЄжЁп}     '+', 'V': 
          begin
            Stack[Top - 1] := Stack[Top - 1] OR Stack[Top];
            Dec(Top);
          end;
        {Ё¬Ї«ЁЄ*жЁп}         '>': 
          begin
            Stack[Top - 1] := not (Stack[Top - 1]) OR Stack[Top];
            Dec(Top);
          end; {begin}
      End; {case}
    end {then}
    Else begin
      Inc(Top);
      Stack[Top] := CharToBool(St[I]);
    end; {else}
  end;
  Calc := Stack[Top];
end;
 
begin
  ClrScr;
  OutputString := '';
  Write('‚ўҐ¤ЁвҐ «®ЈЁзҐбЄ®Ґ ўла*¦Ґ*ЁҐ Ё§ 0 Ё 1 : ');
  ReadLn(S);
  
  {г¤*«пҐ¬ Їа®ЎҐ«л}
  S := DelSpase(S);
  Write('‚ўҐ¤Ґ*®Ґ ўла*¦Ґ*ЁҐ ЎҐ§ Їа®ЎҐ«®ў : ');
  WriteLn(S);
  
  {Їа®ўҐа塞 ** **«ЁзЁҐ ®иЁЎ®Є}
  if Sintax Then begin
    OutputString := InfixPostfix(S);
    
    Write('Џ®бвдЁЄб**п §*ЇЁбм ўла*¦Ґ*Ёп : ');
    WriteLn(OutputString);
    
    Write('‡**зҐ*ЁҐ ўла*¦Ґ*Ёп : ');
    WriteLn(Calc(OutputString));
    
  end Else WriteLn('‘Ё*в*ЄбЁзҐбЄ*п ®иЁЎЄ*');
  ReadLn;
end.