Var k:byte;
st:str100;
procedure in_the(m:mn;C:shortint;i,j:byte);
var d,s:byte;
begin{in_the}
if stek[i,k] in m
then if pos(chr(ord(stek[i,k])+C),stek[j])<>0
then begin
yes:=true;
delete(stek[j],pos(chr(ord(stek[i,k])+C),stek[j]),1);
delete(stek[i],k,1);
st:=stek[i]+stek[j];
if st='' then dok:=true;
for d:=i to j-2 do stek[d]:=stek[d+1];
for d:=j-1 to ik-2 do stek[d]:=stek[d+2];
ik:=ik-2;
for d:=1 to ik do
if length(stek[d])=length(st)
then begin
for s:=ik downto d do stek[s+1]:=stek[s];
stek[d]:=st; inc(ik);
break;
end;
end;
end; {in_the}
begin
for k:=1 to length(stek[i]) do
begin
in_the(big,32,i,j);
in_the(small,-32,i,j);
end;
kontrarn:=yes;
end;
begin{доказательство теоремы методом резолюции}
{исходные данные:
массив stek(ik) - в нем хранятся формулы посылок и теорема}
big:=['A'..'Z']; small:=['a'..'z'];
dok:=false;
repeat
for p3:=1 to ik do
if length(stek[p3])>2 then break;
yes:=false;
for i:=1 to p3-1 do
begin
for j:=i+1 to ik do
if kontrarn(i,j,yes) then break;
if yes then break;
end;
if dok then break;
until not yes;
if dok then writeln('Теорема доказана.')
else writeln('Теорема не доказана.');
end; {rezolut}
begin{начало основной программы}
clrscr; {очистка экрана}
set_var;{ввод посылок и теоремы}
reset_var;{подготовка исходных данных к обработке}
rezolut;{доказательство теоремы методом естественного вывода}
end. {конец основной программы}
(Рабочая программа по методу пропозициональной резолюции).
uses crt;
Type mas=array [1..50,1..40] of string[2];
VAR stp:mas;
sx:array[1..40] of byte;
i,j,n:byte;
{ Процедура ввода и преобразования формул }
Procedure Wwod;
var np,j,i,k,n1,n2:byte;
ss,s1:string; sc:char;
Procedure Obrab(c1,c2:char); Procedure zamena;
var i:byte; begin i:=pos('[',s1); while i<>0 do
begin s1[i]:='('; i:=pos('[',s1);
end; i:=pos(']',s1);while i<>0 do begin
s1[i]:=')'; i:=pos(']',s1); end;
i:=pos('-',s1); while i<>0 do begin s1[i]:='^'; i:=pos('-',s1);
end; end;
{ Процедура применения закона Де Моргана }
Procedure DeMorgan(var s1:string);
var i,j,k:byte;
begin i:=pos('^',s1); delete(s1,i,2); k:=pos(')',s1); delete(s1,k,1); while true do
begin if s1[i]='^' then
begin delete(s1,i,1); inc(i); dec(k) end
else begin insert('-',s1,i); inc(i,2); inc(k) end;
if i=k then break; if s1[i]='+' then s1[i]:='*' else s1[i]:='+'; inc(i); end; end;
{ Процедура применения дистрибутивновного закона }
Procedure Disp; var i,j,k:byte; sp:string; Function dis(s:string):string;
var x,l,i,j,p,n:byte; s1,s2,sn:string[80];
begin i:=pos('(',s); j:=pos(')',s); sn:=''; if (s[j+1]=c1)and(j<>length(s)) then
begin x:=i; s1:=copy(s,i+1,j-i-1);
l:=length(s); p:=l;
for n:=j+2 to l do if s[n]=c2 then begin l:=n; break end; if l=p then s2:=copy(s,j+1,l-j)
else s2:=copy(s,j+1,l-j-1); if l=p then delete(s,i,l-i+1)
else delete(s,i,l-i); repeat i:=pos(c2,s1); if i=0 then
begin i:=length(s1); insert(copy(s1,1,i)+s2+',',sn,1);
delete(sn,length(sn),1); insert(sn,s,x); delete(sn,1,80);
break; end; insert(copy(s1,1,i-1)+s2+',',sn,1); delete(s1,1,i)
until false;
end else begin s1:=copy(s,i+1,j-i-1); l:=1; for n:=i-2 downto 1 do
if s[n]=c2 then begin l:=n; break end; if l=1 then begin s2:=copy(s,1,i-l);
x:=1; end else begin s2:=copy(s,l+1,i-l-1); x:=l+1; end; if l=1 then delete(s,1,j)
else delete(s,l+1,j-l); repeat i:=pos(c2,s1);
if i=0 then begin i:=length(s1);
insert(s2+copy(s1,1,i)+',',sn,1); delete(sn,length(sn),1); insert(sn,s,x);
delete(sn,1,80); break; end;
insert(s2+copy(s1,1,i-1)+',',sn,1); delete(s1,1,i); until false;
end; dis:=s; end; begin repeat i:=pos('(',s1); j:=pos('^',s1); k:=pos(')',s1);
if i=j+1 then if ((s1[j-1]=c2)or(s1[j-1]=',')or(j=1))and
((s1[k+1]=c2)or(s1[k+1]=',')or(k=length(s1)))then
begin DeMorgan(s1);
continue; end;
if (i<>j+1)and(j<i)and(j<>0) then begin s1[j]:='-';
continue; end;
if (i=j+1) then begin sp:=copy(s1,j,k-i+2); delete(s1,j,1);
delete(s1,i,k-i-1); DeMorgan(sp); insert(sp,s1,i);
end; if i>0 then s1:=dis(s1); until pos('(',s1)=0;
end;begin if pos('(',s1)>0 then Disp; zamena; end;{ Процедура инверсии формулы (строки) s1}
Procedure inversia; var i,j,k:byte; s:string; Procedure proverka;
var s:^string; begini:=pos('[',s1); j:=pos(']',s1);
while i<>0 do
begin s^:=copy(s1,i+1,j-1-i); if (((i=1)or(s1[i-1]='+'))and(s1[i-1]<>'^'))
and((s1[j+1]='+')or(j=length(s1))) then begin delete(s1,i,1);
delete(s1,j-1,1) end else
if (pos('+',s^)=0)and((((i=1)or(s1[i-1]='*'))and(s1[i-1]<>'^')) and((s1[j+1]='*')or(j=length(s1))))then begin delete(s1,i,1); delete(s1,j-1,1) end
else begin s1[j]:=')'; s1[i]:='('; end; i:=pos('[',s1); j:=pos(']',s1);
end;end; begin i:=pos('(',s1); j:=0;
while i<>0 do begin
if (i=1)or(s1[i-1]<>'^') then
begin insert('^',s1,i); inc(i) end else begin
delete(s1,i-1,1); dec(i) end; k:=pos(')',s1);
s1[i]:='['; s1[k]:=']'; i:=pos('(',s1); end; s:=s1;
repeat i:=pos('[',s); if (i=1)or(i=2) then begin
k:=pos(']',s); j:=j+k+1; if j-1<length(s1) then begin
if s1[j]='*' then s1[j]:='+' else s1[j]:='*' end;
delete(s,1,k+1); end else begin if s[1]='^' then
begin delete(s1,j+1,1);
delete(s,1,3); inc(j,2);
if j<length(s1) then begin
if s1[j]='+' then s1[j]:='*' else s1[j]:='+' end; end else
begin
insert('^',s1,j+1); inc(j,3); if j<length(s1) then
begin if s1[j]='+' then s1[j]:='*'
else s1[j]:='+' end;
delete(s,1,2); end
end until length(s)=0; proverka;
end;
{Процедура исключения импликации путём замены на эквивалентную формулу в строке s1}
Procedure implik;
var i,j,k:byte; begin while pos('>',s1)<>0 do begin i:=pos('>',s1); if s1[i-1]=')' then
begin j:=pos(')',s1); while j<>i-1 do begin
k:=pos('(',s1); s1[j]:=']'; s1[k]:='[';
j:=pos(']',s1); end; k:=pos('(',s1);
insert('^',s1,k); s1[i+1]:='+'; end else begin insert('^',s1,i-1); s1[i+1]:='+'; end;
end;end; { Процедура исключения двойного отрицания из строки s1}
Procedure inverX2;
var i:byte; begin while pos('^',s1)<>0 do
begin i:=pos('^',s1); if s1[i+1]='^' then delete(s1,i,2)
else s1[i]:='-'; end;while pos('-',s1)>0 do
begin i:=pos('-',s1);
s1[i]:='^'; end;
end;{Процедура исключения эквиваленции путём замены на эквивалентную формулу в строке s1} Procedure ekvivalentia;
var i,j,k:byte; s2,s3:string[2]; ss:string[20]; begin
repeat i:=pos('<',s1); if (s1[i-2]='^')and(i-1<>1) then begin s2:=copy(s1,i-2,2); j:=i-2
end else begin s2:=copy(s1,i-1,1); j:=i-1 end;
if (s1[i+2]='^')and(i+1<>length(s1)) then begin
s3:=copy(s1,i+2,2); k:=i+4-j end else
begin k:=i+3-j; s3:=copy(s1,i+2,1); end; delete(s1,j,k);
ss:='('+'^'+s2+'+'+s3+')'+'*'+'('+s2+'+'+'^'+s3+')'; insert(ss,s1,j); until pos('<>',s1)=0;
end; begin clrscr; write(' Введите количество посылок:');
readln(np); writeln; n:=0; for i:=1 to np do
begin write('введите',i,'-ю строку:');
readln(s1);
if pos('<>',s1)<>0 then ekvivalentia;
if pos('>',s1)<>0 then implik; inverX2;
Obrab('+','*'); j:=pos('*',s1); while j<>0 do begin
s1[j]:=','; j:=pos('*',s1); end;
repeat n1:=1; inc(n); k:=pos(',',s1); if k=0 then k:=length(s1)+1;
ss:=copy(s1,1,k-1); delete(s1,1,k); repeat n2:=pos('+',ss);
if n2=0 then n2:=length(ss)+1; stp[n,n1]:=copy(ss,1,n2-1);
delete(ss,1,n2); inc(n1); until length(ss)=0; sx[n]:=n1-1;
until length(s1)=0; end; write('введите теорему:'); readln(s1);
if pos('<>',s1)<>0 then ekvivalentia; if pos('>',s1)<>0 then implik;
Obrab('+','*'); inverX2; inversia; inverX2; i:=pos('*',s1); while i<>0 do
begin s1[i]:=','; i:=pos('*',s1); end; repeat n1:=1;
inc(n); k:=pos(',',s1); if k=0 then k:=length(s1)+1;
ss:=copy(s1,1,k-1); delete(s1,1,k); repeat n2:=pos('+',ss); if n2=0 then n2:=length(ss)+1;
stp[n,n1]:=copy(ss,1,n2-1); delete(ss,1,n2);
inc(n1); until length(ss)=0; sx[n]:=n1-1;
until length(s1)=0; end;
{Процедура применения метода пропозициональной резолюции к группу формул
(массива )}
Procedure MetRezolut(var a:mas);
procedure cop(var sw:string;ss:string);
beginsw:='';
while length(ss)<>0 do begin if ss[1]='^' then begin
sw:=sw+copy(ss,1,2)+'+'; delete(ss,1,2) end else
begin sw:=sw+copy(ss,1,1)+'+'; delete(ss,1,1)
end; end;delete(sw,length(sw),1); end; var b:boolean; q,i,j,j1,h,k:byte; x:string[2];
s:string; f:text; sj1,sj,si:set of byte; sw1,sw2,sw3:string; begin
clrscr; assign(f,'rez.txt'); rewrite(f); writeln(f,' введеные строки ');
writeln(f,'*****************************************');
for i:=1 to n do begin s:=''; for j:=1 to sx[i] do s:=s+a[i,j]+'+';
delete(s,length(s),1); writeln(f,s,' <- ',i,'-я строка ');
end;writeln(f,'******************************************');for q:=1 to n do
begin s:=''; si:=[]; include(si,q); for j:=1 to sx[q] do s:=s+a[q,j];
sw1:=''; cop(sw1,s); writeln(f,sw1,' <- исходная строка ');
repeat b:=false; for i:=1 to n do begin if not(i in si) then
begin sj:=[]; sw1:=''; cop(sw1,s); for j:=1 to sx[i] do
begin x:=a[i,j]; h:=length(x); if h=2 then
begin delete(x,1,1); dec(h)end
else begin insert('^',x,1);
inc(h) end;
k:=pos(x,s); if (k>0)and(s[k-1]='^')and(a[i,j]=copy(s,k-1,2)) then
begin k:=0; sj:=sj+[j]; end
else if k>0 then begin sj1:=sj1+[j]; delete(s,k,h) end;
end; if sj1<>[] then begin for j:=1 to sx[i] do if (not(j in sj1)) and (not(j in sj))
then s:=s+a[i,j]; b:=true; include(si,i); sj1:=[]; sw2:='';
for j:=1 to sx[i] do sw2:=sw2+a[i,j]; cop(sw2,sw2); if length(s)<>0 then cop(sw3,s)
else sw3:='__'; writeln(f,sw3,' выведена из :',sw1,' и ',sw2);
if length(s)=0 then begin writeln(f,’ получили противоречие, значит теорема доказана ');
writeln(f,'***********************'); close(f); exit; end; break; end; end; if b then break end;
if (i=n)and(not(b)) then break; until false;
writeln(f,''Не возможно построить ни одного нового предложения ');
end; writeln(f,' теорема не доказана, т.к. не возможно получить противоречия ');
writeln(f,'******************************************');
close(f); end;
BEGIN
for i:=1 to 50 do
for j:=1 to 40 do stp[i,j]:='0';
Wwod;
clrscr;
MetRezolut(stp);
writeln('результат смотрите в файле rez.txt');
END.