|
P.57.1.
unit Gedel;
interface
uses LargeNumbers;
type
(* *************************** *)
GD1List = ^GD1PPList;
GD1PPList = record
Pred, Nex : GD1List;
Co : string;
end;
(* *************************** *)
GD1Word = record
a : GD1List;
(* слово задается как список номеров символов слова в
алфавите;
*)
b : integer;
(* число символов в слове *)
end;
var
GD1ErrKantor : integer;
(* выдает код ошибки при выполнении процедур
GD1FromPairKantor и GD1ToPairKantor :
0 - ошибки нет;
1 - при выполнении процедуры GD1FromPairKantor результирующая
пара содержит слишком большое число ;
2 - при выполнении процедуры GD1ToPairKantor результирующий
номер является слишком большим; *)
GD1ErrWord : integer;
(* выдает код ошибки при выполнении процедур
GD1ToWord и GD1FromWord :
0 - ошибки нет;
1 - при выполнении процедуры GD1FromWord не хватило
памяти;
2 - при выполнении процедуры GD1FromWord алфавит
результирующего слова слишком большой;
3 - при выполнении процедуры GD1ToWord результирующий
номер является слишком большим; *)
function GD1ToPairKantor( var i1,i2 : string) : string;
(* по числам i1, i2 строит Канторовый номер K(i1,i2) *)
procedure GD1FromPairKantor ( var j, i1, i2 : string);
(* по Канторовскому номеру j=K(i1,i2) строит числа i1, i2 *)
procedure GD1FromWord( var n : string;
var ww : GD1Word);
(* по геделевому номеру n строит слово ww *)
procedure GD1ToWord( var ww : GD1Word;
var n : string);
(* по слову ww строит его геделевый номер n *)
procedure GD1ClearWord( var ww : GD1Word);
(*
очищает слово ww
*)
function GD1ListAdd(var x, y : GD1List) : GD1List;
implementation
function GD1ToPairKantor( var i1,i2 : string) : string;
var
k, r, r1, r2 : string;
begin
k:=LNAdd(i1,i2);
k:=LNMul(k,k);
r:=LNAssign(3);
r:=LNMul(r,i1);
r:=LNAdd(r,i2);
k:=LNAdd(k,r);
r:=LNAssign(2);
LNDivMod(k,r,r1,r2);
{ j:=((i1+i2)*(i1+i2)+3*i1+i2) div 2; }
GD1ToPairKantor:=r1;
if LNErr>0 then GD1ErrKantor:=2;
end;
procedure GD1FromPairKantor ( var j, i1, i2 : string);
var
a1, a2, a8, b, bb, bbb, bbbab, bbbsb,
ca, cs, cc, d, e : string;
begin
a1:=LNAssign(1);
a2:=LNAssign(2);
a8:=LNAssign(8);
b:=LNMul(a8,j);
bb:=LNAdd(b,a1);
bbb:=LNSqr(bb);
bbbab:=LNAdd(bbb,a1);
bbbsb:=LNSub(bbb,a1);
LNDivMod(bbbab,a2,ca,cc);
LNDivMod(bbbsb,a2,cs,cc);
d:=LNMul(ca,cs);
LNDivMod(d,a2,e,cc);
i1:=LNSub(j,e);
i2:=LNSub(cs,i1);
if LNErr>0 then GD1ErrKantor:=1;
{
i1:=j-(((trunc(sqrt(8*j+1)+1) div 2)*((trunc(sqrt(8*j+1))-1) div 2)) div 2);
i2:=trunc((trunc(sqrt(8*j+1))-1)/2)-i1;
}
end;
function GD1ListAdd(var x, y : GD1List) : GD1List;
var
z, t : GD1List;
begin
if x=nil then t:=y
else
if y=nil then
else begin
z:=x;
while z^.Nex<>nil do z:=z^.Nex;
z^.Nex:=y;
y^.Pred:=z;
t:=x;
end;
GD1ListAdd:=t;
end;
procedure GD1FromWord( var n : string; var ww : GD1Word);
label aaaa;
var
a1, aa, l1, l2, ll1, ll2 : string;
k, i, lll : integer;
ff : GD1List;
begin
ww.a:=nil;
GD1FromPairKantor(n,l1,l2);
a1:=LNAssign(1);
aa:=LNAdd(l1,a1);
lll:=LNInteger(aa); (* длина слова *)
ww.b:=lll;
if (GD1ErrKantor>0) or (LNErr>0)
then begin
GD1ErrWord:=2;
GD1ClearWord(ww);
goto aaaa;
end;
for k:=1 to lll-1 do begin
GD1FromPairKantor(l2,ll1,ll2);
if (GD1ErrKantor>0) or
(LNErr>0) then begin
GD1ErrWord:=2;
GD1ClearWord(ww);
goto aaaa;
end;
if MemAvail<1024*10 then begin
GD1ErrWord:=1;
GD1ClearWord(ww);
goto aaaa;
end;
new(ff);
ff^.Pred:=nil; ff^.Nex:=nil;
ff^.Co:=ll1;
ww.a:=GD1ListAdd(ww.a,ff);
l2:=ll2;
end;
new(ff);
ff^.Pred:=nil; ff^.Nex:=nil;
ff^.Co:=l2;
ww.a:=GD1ListAdd(ww.a,ff);
aaaa :
end;
procedure GD1ToWord( var ww : GD1Word; var n : string);
label aaa;
var
q1, q2, q3, a1, ab : string;
ee : GD1List;
begin
ee:=ww.a;
while ee^.Nex<>nil do ee:=ee^.Nex;
q2:=ee^.Co;
ee:=ee^.Pred;
while ee<>nil do begin
q1:=ee^.Co;
q3:=GD1ToPairKantor(q1,q2);
if GD1ErrKantor>0 then begin
GD1ErrWord:=3;
goto aaa;
end;
q2:=q3;
ee:=ee^.Pred;
end;
a1:=LNAssign(1);
ab:=LNAssign(ww.b);
q1:=LNSub(ab,a1);
if LNErr>0 then begin
GD1ErrWord:=3;
goto aaa;
end;
q3:=GD1ToPairKantor(q1,q2);
if GD1ErrKantor>0 then begin
GD1ErrWord:=3;
goto aaa;
end;
n:=q3;
aaa :
end;
procedure GD1ClearWord( var ww : GD1Word);
var
wr, wr1 : GD1List;
begin
ww.b:=0;
wr:=ww.a;
while wr<>nil do begin
wr1:=wr;
wr:=wr^.Nex;
Dispose(wr1);
end;
ww.a:=nil;
end;
begin
GD1ErrKantor:=0;
GD1ErrWord:=0;
end.
|
