Вывод в порядке возрастания всех правильных несократимых дробей, знаменатели которых не превосходят n

unit nums;
interface
 
type
  TFraction = record
    n, d: integer;
  end;
 
function GCD(a, b: integer): integer; { наибольший общий делитель }
procedure SwapReal(var a, b: Real);
procedure SwapFrac(var a, b: TFraction);
 
implementation
function GCD(a, b: integer): integer;
begin
  while (a<>0) and (b<>0) do
    if a>=b then a:=a mod b else b:=b mod a;
  GCD:=a+b;
end;
 
procedure SwapFrac(var a, b: TFraction);
var t: TFraction;
begin
  t:=a; a:=b; b:=t;
end;
 
procedure SwapReal(var a, b: Real);
var t: Real;
begin
  t:=a; a:=b; b:=t;
end;
 
end.

uses nums;
var
  a: array [0..10578] of TFraction;
  va: array [0..10578] of Real;
  la, i, j, k: integer;
begin
  la:=0;
  for j:=2 to 500 do
    for i:=1 to j-1 do
      if GCD(i,j)=1 then begin
        k:=la; inc(la);
        a[k].n:=i; a[k].d:=j; va[k]:=i/j;
        while (k>0) and (va[k]<va[k-1]) do begin
          SwapFrac(a[k-1],a[k]);
          SwapReal(va[k-1],va[k]);
          dec(k);
        end;
      end;
  for k:=0 to la-1 do with a[k] do WriteLn(n,'/',d);
  WriteLn('Всего: ',la);
end.

uses nums;
var
  la, i, j: integer;
begin
  la:=0;
  for j:=2 to 500 do
    for i:=1 to j-1 do
      if GCD(i,j)=1 then inc(la);
  WriteLn('Всего: ',la);
end.

unit UFarey;
 
interface
 
procedure Farey(ltP, ltQ, rgP, rgQ : integer);
 
var
  n : integer;
 
implementation
 
{ P / Q }
procedure Farey(ltP, ltQ, rgP, rgQ : integer);
var P, Q : integer;
begin
  if (ltQ <= n) and (rgQ <= n) then
  begin
    P := ltP + rgP;
    Q := ltQ + rgQ;
    Farey(ltP, ltQ, P, Q);
    if Q <= n then
      writeln(P, '/', Q);
    Farey(P, Q, rgP, rgQ);
  end;
end;
 
end.

uses UFarey;
 
begin
  write('n = '); readln(n);
  Farey(0, 1, 1, 1);
end.

unit nums;
 
interface
procedure Farey(n: integer; asc: boolean);
 
implementation
procedure Farey(n: integer; asc: boolean);
var
  a, b, c, d, ta, tb, k: LongInt;
begin
  if asc then begin
    a:=0; b:=1; c:=1; d:=n;
  end else begin
    a:=1; b:=1; c:=n-1; d:=n;
  end;
  WriteLn(a,'/',b); { 0/1 asc or 1/1 desc }
  while (asc and (c<=n)) or (not asc and (a>0)) do begin
    k:=(n+b) div d;
    ta:=a; tb:=b; a:=c; b:=d; c:=k*c-ta; d:=k*d-tb;
    WriteLn(a,'/',b);
  end;
end;
 
end.

uses nums;
begin
  Farey(500, true);
end.

procedure Farey(n: integer; asc: boolean);
var
  a, b, c, d, ta, tb, k: LongInt;
begin
  if asc then begin
    a:=1; b:=n; c:=1; d:=n-1;
  end else begin
    a:=n-1; b:=n; c:=n-2; d:=n-1;
  end;
  while (asc and (c<=n)) or (not asc and (a>0)) do begin
    WriteLn(a,'/',b);
    k:=(n+b) div d;
    ta:=a; tb:=b; a:=c; b:=d; c:=k*c-ta; d:=k*d-tb;
  end;
end;