There is my sourse below. Topologic sort. It seems to be very simple, and it is, but may be, i don't understand something. Find error, please. Sorry for my english;)

program Mars;

uses
  SysUtils;

type
  TPNext = ^ElemIO;
  ElemIO = record
    Vert: byte;
    Next: TPNext;
  end;

var
  Numbers, Parents: array [1..100] of byte;
  Point: array [1..100, 0..100] of byte;
  Beg, En: TPNext;
  Num, N, w, a, q: Byte;
  NewV: array [1..100] of boolean;
  f: Text;

procedure Push(v: byte);
var ne: TPNext;
begin
  New(ne);
  if Beg = nil then Beg:= Ne;
  Ne^.Vert:= V;
  Ne^.Next:= nil;
  if En = nil then En:= ne
  else begin
    En^.Next:= Ne;
    En:= Ne;
  end;
end;

function Pop: byte;
var ne:TPNext;
begin
  result:= Beg^.Vert;
  Ne:= Beg;
  Beg:= Ne^.Next;
  if Beg = nil then En:= nil;
  Dispose(Ne);
end;

Procedure OW(v: byte);
var i, p: byte;
begin
  Push(v);
  while Beg <> nil do begin
    p:= Pop;
    Numbers[Num]:= p;
    inc(num);
    for I := 1 to Point[p, 0] do
      if NewV[Point[p, i]] then begin
        Push(Point[p, i]);
        NewV[Point[p, i]]:= false;
      end;
  end;
end;

procedure GetTheOldest;
var
  i, q: byte;
begin
  FillChar(Parents, N, 0);
  for i := 1 to N do
    for q := 1 to Point[i, 0] do
      inc(Parents[Point[i, q]]);
  Num:=1;
  for I := 1 to N do
    if Parents[i] = 0 then begin
      OW(i);
      NewV[i]:= false;
    end;
end;

begin
  for w := 1 to 100 do
    for a := 0 to 100 do
      Point[w, a]:= 0;

  AssignFile(f, 'input.txt');
  reset(f);
  N:=0;
  read(f, N);
  for w := 1 to N do
  begin
    read(f, a);
    q:= 1;
    while a <> 0 do begin
      Point[w, q]:= a;
      inc(Point[w, 0]);
      Read(f, a);
      inc(q);
    end;
  end;
  CloseFile(f);


  FillChar(NewV, N, True);
  Beg:= nil;
  En:= nil;
  GetTheOldest;

  For w:=1 to N do
    If NewV[w] then OW(w);
  AssignFile(f, 'output.txt');
  rewrite(f);
  if n <> 0 then
    for w := 1 to N do
      if w = N then write(f, Numbers[w])
      else write(f, Numbers[w], ' ');
  CloseFile(f);
end.