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

Обсуждение задачи 1182. Team Them Up!

Please help correct my program.
Послано qiu liyin 23 июл 2003 09:51
const maxn=200;
var g:array[1..maxn,1..maxn] of byte;
    d,t,l:array[0..maxn] of integer;
    f,f1:array[0..maxn] of boolean;
    a:array[1..maxn,1..2] of integer;
    i,j,k,n,now,gr:integer;
procedure sub(p,gr:integer);
  var i:integer;
  begin
    for i:=1 to n do begin
      if (g[p,i]=1)and(t[i]<>gr)and(t[i]<>0) then begin
        writeln('No solution');
        halt;
      end;
      if (g[p,i]=1)and f[i] then begin
        t[i]:=gr; f[i]:=false;
        if odd(gr) then sub(i,gr+1)
          else sub(i,gr-1);
      end;
    end;
  end;
begin
  assign(input,'teams.in');
  reset(input);
  assign(output,'teams.out');
  rewrite(output);
  readln(n);
  for i:=1 to n do
    for j:=1 to n do
      if i<>j then g[i,j]:=1;
  fillchar(d,sizeof(d),0);
  for i:=1 to n do begin
    read(j);
    while j<>0 do begin
      g[i,j]:=0;
      read(j);
    end;
  end;
  for i:=1 to n do
    for j:=1 to n do if g[i,j]=1 then g[j,i]:=1;
  for i:=1 to n do
    for j:=1 to n do
      if g[i,j]=1 then inc(d[i]);
  fillchar(f,sizeof(f),true);
  now:=1;
  repeat
    i:=1;
    while i<=n do
      if f[i] then break
        else inc(i);
    if i>n then break;
    t[i]:=now;
    f[i]:=false;
    sub(i,now+1);
    now:=now+2;
  until false;
  fillchar(a,sizeof(a),0);
  gr:=now-2;
  for i:=1 to n do
    if odd(t[i]) then
      inc(a[t[i],1])
    else inc(a[t[i]-1,2]);
  fillchar(f,sizeof(f),false);
  f[0]:=true;
  for i:=1 to gr do
    if odd(i) then begin
      f1:=f;
      fillchar(f,sizeof(f),false);
      for j:=n downto 0 do
        if f1[j] then begin
          if (not f[j+a[i,1]])and(a[i,1]>0) then begin
            f[j+a[i,1]]:=true;
            l[j+a[i,1]]:=i;
          end;
          if (not f[j+a[i,2]])and(a[i,2]>0) then begin
            f[j+a[i,2]]:=true;
            l[j+a[i,2]]:=-i;
          end;
        end;
    end;
  i:=(n+1) div 2;
  while l[i]=0 do dec(i);
  write(i);
  now:=i;
  fillchar(f,sizeof(f),true);
  while (l[i]<>0)and(i>0) do begin
    for j:=1 to n do
      if ((l[i]>0)and(t[j]=l[i]))or((l[i]<0)and(t[j]=abs(l[i])+1))
then begin
        write(' ',j);
        f[j]:=false;
      end;
    if l[i]>0 then i:=i-a[l[i],1]
      else i:=i-a[-l[i],2];
  end;
  writeln;
  write(n-now);
  for i:=1 to n do
    if f[i] then write(' ',i);
  writeln;
  close(input);
  close(output);
end.