Var I:byte;

begin{distrib1}

set_i(i,sk1-1,1,-1);

if stek[it,i] in oper then inc(i); set_k;

st1:=copy(stek[it],i,sk1-i-1);

st2:=copy(stek[it],sk1+1,k-sk1-1);

st3:=copy(stek[it],k+1,sk2-k-1);

delete(stek[it],i,sk2-i+1);

insert(concat('(',st1,nz,st2,')',z,'(',st1,nz,st3,')'),stek[it],i);

end; {distrib1}

procedure distrib2(sk1,sk2:byte);

Var I:byte;

begin{distrib2}

set_i(i,sk2+1,m,1);

if stek[it,i] in oper then dec(i); set_k;

st1:=copy(stek[it],sk1+1,k-sk1-1);

st2:=copy(stek[it],k+1,sk2-k-1);

st3:=copy(stek[it],sk2+2,i-sk2-1);

delete(stek[it],sk1,i+1-sk1);

insert(concat('(',st1,nz,st3,')',z,'(',st2,nz,st3,')'),stek[it],sk1);

end; {distrib2}

begin{distrib}

found:=false;

if num=1 then distrib1(sk1,sk2) else distrib2(sk1,sk2);

nsk:=[];

end; {distrib}

begin{obrab}

del_space_and_upcase(it);

find_implic(it); nsk:=[]; m:=length(stek[it]);

repeat {пока не вычислим все операции}

not_op:=true;

for sk1:=m downto 1 do

if (stek[it,sk1]='(')and(not(sk1 in nsk)) then break;

for sk2:=sk1 to m do

if (stek[it,sk2]=')')and(not(sk2 in nsk)) then break;

include(nsk,sk1); include(nsk,sk2);

if (stek[it,sk1-1]='^')and(sk1>1)

then de_morgan(sk1,sk2) else begin

for i:=sk1+1 to sk2-1 do if stek[it,i]=z then

if (stek[it,sk1-1]=nz)and(sk1>1) then distrib(sk1,sk2,1)

else if (stek[it,sk2+1]=nz)and(sk2<m) then distrib(sk1,sk2,2);

end;

if sk1<>1 then not_op:=false;

m:=length(stek[it]);

until not_op;

st:='';

for i:=1 to m do begin

if stek[it,i]=z then st:=st+',' else

if ((stek[it,i-1]='^')and(i>1))or(stek[it,i]=nz)

then st:=st+stek[it,i]

else if (stek[it,i]>='A')and(stek[it,i]<='Z')

then st:=st+chr(ord(stek[it,i])+32)

end;

stek[it]:=st;

while pos(',',st)<>0 do

begin

stek[it]:=copy(st,1,pos(',',st)-1);

inc(ik);

stek[ik]:=copy(st,pos(',',st)+1,length(st)-pos(',',st));

st:=stek[ik];

end;

while pos('+',stek[it])<>0 do

delete(stek[it],pos('+',stek[it]),1);

end; {obrab}

procedure Up(ik:byte);

var min,i,j:byte; C,minst:str100;

begin

for i:=1 to ik-1 do begin

min:=i; minst:=stek[i];

for j:=i+1 to ik do

if length(minst)>length(stek[j])

then begin min:=j; minst:=stek[j]; end;

C:=stek[i];stek[i]:=minst;stek[min]:=C;

end;

end; {Up}

begin{reset_var}

inc(ik); it:=1;

for i:=1 to ik do

obrab(i,'*','+');

Up(ik);

end; {reset_var}

procedure rezolut;

type mn = set of char;

var big,small:mn;

i,j,p3:byte; yes,dok:boolean;

function kontrarn(i,j:byte;var yes:boolean):boolean;