ENG  RUSTimus Online Judge
Online Judge
Задачи
Авторы
Соревнования
О системе
Часто задаваемые вопросы
Новости сайта
Форум
Ссылки
Архив задач
Отправить на проверку
Состояние проверки
Руководство
Регистрация
Исправить данные
Рейтинг авторов
Текущее соревнование
Расписание
Прошедшие соревнования
Правила
вернуться в форум

Обсуждение задачи 1112. Покрытие

What's wrong with my program!
Послано gaozhenwei 15 апр 2002 15:00
var d:array[-1000..999] of ^integer;
    p,f:array[-1000..999] of integer;
    t:array[1..100,1..2] of integer;
    k,b,e,i,n:integer;
begin
 for i:=-999 to 999 do d[i]:=nil;
 fillchar(p,sizeof(p),0);
 fillchar(f,sizeof(f),0);
 read(n);
 for i:=1 to n do
 begin
  read(b,e);
  if b>e then
  begin
   k:=b;b:=e;e:=k;
  end;
  new(d[e]);d[e]^:=b;
 end;
 b:=0;f[-999]:=-1000;
 for i:=-999 to 999 do
 begin
  if d[i]=nil then
  begin
   p[i]:=p[i-1];f[i]:=i-1;
  end
   else begin
         p[i]:=p[d[i]^]+1;f[i]:=d[i]^;
        end;
  if p[i]>b then
  begin
   b:=p[i];e:=i;
  end;
 end;
 writeln(b);b:=0;
 while e<>-1000 do
 begin
  if d[e]<>nil then
  begin
   inc(b);t[b,1]:=d[e]^;t[b,2]:=e;
  end;
  e:=f[e];
 end;
 for i:=b downto 1 do writeln(t[i,1],' ',t[i,2]);
end.