Informatika gyűjtemény

Egy szinttel feljebb mt_egyiptom.pas

2004050607080910

<<  6. óra  >>

<<  Egyiptomi törtek  >>

NézetNyomtat

mt_egyiptom.pas (Vissza)
Az alábbi letöltési lehetőségek közül választhatsz: (segítség)
Karakterkódolás:
Sortörés:
Típus: text/plain
Tartalmaz szöveget
Karakterkódolás: us-ascii
Méret: 1 KB
program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var a,b,h,x,y,c: integer;
    n:array[0..10000] of integer;


function lnko(x,y:integer):integer;
var m:integer;
begin
m:=y mod x;

while m<>0 do
begin
y:=x;
x:=m;
m:=y mod x;
end;

result:=x;
end;

procedure M1;
begin
c:=1;
n[0]:=0;
repeat
x:=lnko(a,b);
a:=a div x;
b:=b div x;
c:=c+1;
if a*c>=b then
begin
n[0]:=n[0]+1;
n[n[0]]:=c;
a:=a*c-b;
b:=b*c;
end;
until a=0;
end;

function keres(f:integer):integer;
label l1;
var i:integer;
begin
for i:=1 to h do
begin
if n[i]>f then goto l1;
end;
i:=h+1;
l1:
result:=i;
end;

procedure torol(c:integer);
var u:integer;
begin
for u:=c to h-2 do
begin
n[u]:=n[u+2];
end;
h:=h-2;
end;

procedure beilleszt(m,p:integer);
var u:integer;
begin
for u:=h downto p do
begin
n[u+1]:=n[u];
end;
n[p]:=m;
h:=h+1;
end;

function MindKul:boolean;
var i:integer;
begin
result:=true;
for i:=1 to h-1 do
begin
if n[i]=n[i+1] then begin result:=false; break; end;
end;
end;

procedure m2;
var
 v,w:integer;
begin
for c:=1 to a do
begin
n[c]:=b;
end;
h:=a;

repeat
c:=1;
while (n[c]<>n[c+1]) and (c<h) do inc(c);
if c<h then
begin
v:=n[c];
torol(c);
if v mod 2=0 then
 begin
  w:=keres(v div 2);
  beilleszt(v div 2,w);
 end
else
 begin
  w:=keres((v+1) div 2);
  beilleszt((v+1) div 2,w);
  w:=keres(((v+1)*v) div 2);
  beilleszt(((v+1)*v) div 2,w);
 end;
end;

for y:=1 to h do
begin
write(n[y],' ');
end;
writeln;

until Mindkul;

n[0]:=h;
end;

begin
readln(a);
readln(b);
writeln('start');

m2;

for y:=1 to h do
begin
writeln(n[y]);
end;
writeln(h);
readln;

end.
(Vissza)