Book of tasks on programming. Old version

 

 by Aliaksandr N. Prykhodzka

 

тестирование, college, учебный материал, example, path, code, sql, off-line, symbol, DVD, prolog, загрузочный, client, applet, external, while, address, наследование
 

Pascal. Answers. Pc.13. Realization of algorithms. Numerations



главная страница


Pc.13.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.


 

©   Aliaksandr Prykhodzka    1993 - 2007