Informatika gyűjtemény

Egy szinttel feljebb pt_egyiptom.pas

2004050607080910

<<  6. óra  >>

<<  Egyiptomi törtek  >>

NézetNyomtat

pt_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: 2 KB
{$R+}{$Q+}{$I+}
program egyiptom;
var p,q:longint;

procedure swap(var x,y:longint);
var t:longint;
begin
  t:=x;
  x:=y;
  y:=t;
end;

function lnko(x,y:longint):longint;
var m:longint;
begin
  if x>y then swap(x,y);
  m:=y mod x;
  while(m<>0)do
    begin
      y:=x;
      x:=m;
      m:=y mod x;
    end;
  lnko:=x;
end;

procedure a;
var x,y:longint;
    n,c:longint;
begin
  x:=p div lnko(p,q);
  y:=q div lnko(p,q);
  n:=2;
  c:=0;
  repeat
    // x/y>1/n
    if n*x >= y then // x/y:= x/y-1/n = (x*n-y) / (y*n)
      begin
        x:=x*n-y;
        y:=y*n;
        writeln('1/',n);
        inc(c);
      end;    
    inc(n);
  until x=0;
  writeln('max:',n-1);
  writeln('c:',c);
end;

const L=10000;



procedure b;
var t:array[1..L]of longint;
    N,i,j,m,k:longint;
    vege:boolean;
begin
  for N:=1 to p do t[n]:=q;
  n:=p;
  
  repeat
    vege:=true;
    for i:=1 to N-1 do
      if t[i]=t[i+1] then
        begin
          vege:=false;
          break;
        end;
      if not(vege) then
        begin
          k:=t[i];
          if (k mod 2) = 0 then
            begin
              t[i]:=k div 2;
              dec(N);
              for j:=i+1 to N do
                t[j]:=t[j+1];
            end else
            begin
              m:=(k+1) div 2;
              //t[i+1]:=k*(k+1) div 2;
              j:=i-1;
              while((j>0)and(t[j]>m)) do
                begin
                  t[j+1]:=t[j];
                  dec(j);
                end;
              t[j+1]:=m;
              
              m:=k*(k+1) div 2;
              j:=i+2;
              while((j<=N)and(t[j]<m)) do
                begin
                  t[j-1]:=t[j];
                  inc(j);
                end;
              t[j-1]:=m;
            end;
        end;
  until vege;
  for i:=1 to N do writeln('1/',t[i]);
  writeln('max:',t[n]);
  writeln('c:',n);
end;

procedure c;
var x,y,t,c,m:longint;
begin
  x:=p;
  y:=q;
  
  c:=0;
  m:=0;
  repeat
    x:=x div lnko(x,y);
    y:=y div lnko(x,y);
    for t:=1 to y-1 do
      begin
        if (x*t-1)mod y = 0 then break;
      end;
      
    writeln('1/',y*t);
    if y*t>m then m:=y*t;
    
    inc(c);
    x:= (x*t-1)div y;
    y:= t;
  until x=0;
  writeln('max:',m);
  writeln('c:',c);
end;

var e:byte;
begin
  write('p,q = ');
  readln(p,q);
  writeln('Melyik elj'#160'r'#160'st szeretn'#130'd? (1-3)');
  readln(e);
  if  e=1 then a else
  if  e=2 then b else
  if  e=3 then c else
  writeln('Hiba!');
  readln;
end.
(Vissza)