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

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

WA on test 25.... Please help me
Послано FailedWing 9 ноя 2005 12:24
  type
        anstype  = array[0..100] of longint;

  var
        l    : longint;
        n    : longint;
        f    : array[1..100, -100..200] of boolean;
        ans  : array[1..2] of anstype;
        go   : array[1..100, 0..100] of longint;
        save : array[1..100, 0..100] of longint;
        g    : array[1..100, 0..100] of longint;
        done : array[1..100] of boolean;
        list : array[1..100, 1..2] of anstype;
        que  : array[1..100] of longint;
        edge : array[1..100, 1..100] of boolean;

  procedure init;
    var
        have       : boolean;
        i, j, a, k : longint;
        hash        : array[0..100] of boolean;
    begin
          readln(n);
          fillchar(g, sizeof(g), 0);
          for i := 1 to n do
            begin
              fillchar(hash, sizeof(hash), false);
              repeat
                read(a);
                hash[a] := true;
              until a = 0;
              for j := 1 to n do
                if (not hash[j]) and (i <> j)
                  then begin
                    have := false;
                    for k := 1 to g[i, 0] do
                      if g[i, k] = j
                        then begin
                          have := true;
                          break;
                        end;
                    if not have
                      then begin
                        inc(g[i, 0]);
                        g[i, g[i, 0]] := j;
                      end;
                    have := false;
                    for k := 1 to g[j, 0] do
                      if g[j, k] = i
                        then begin
                          have := true;
                          break;
                        end;
                    if not have
                      then begin
                        inc(g[j, 0]);
                        g[j, g[j, 0]] := i;
                      end;
                  end;
            end;
          fillchar(edge, sizeof(edge), false);
          for i := 1 to n do
            for j := 1 to g[i, 0] do
              edge[i, g[i, j]] := true;
    end;

  procedure get_tree(start : longint);
    var
        now           : array[1..100] of longint;
        get_in        : array[1..100] of boolean;
        level         : longint;
        i, h, t, k, j : longint;
    begin
          que[1] := start;
          h := 1;
          t := 1;
          now[1] := 1;
          fillchar(get_in, sizeof(get_in), false);
          get_in[start] := true;
          while true do
            begin
              k := que[h];
              level := now[h];
              done[k] := true;
              for i := 1 to g[k, 0] do
                begin
                  if get_in[g[k, i]]
                    then continue;
                  inc(t);
                  que[t] := g[k, i];
                  get_in[g[k, i]] := true;
                  now[t] := level + 1;
                end;
              inc(list[l, level mod 2 + 1, 0]);
              k := list[l, level mod 2 + 1, 0];
              list[l, level mod 2 + 1, k] := que[h];
              inc(h);
              if h > t then break;
            end;
          for k := 1 to 2 do
            for i := 1 to list[l, k, 0] do
              for j := i + 1 to list[l, k, 0] do
                if edge[list[l, k, i], list[l, k, j]]
                  then begin
                    writeln('No solution');
                    halt;
                  end;
    end;

  procedure make;
    var
        i : longint;
    begin
          l := 0;
          fillchar(done, sizeof(done), false);
          for i := 1 to n do
            if not done[i]
              then begin
                inc(l);
                get_tree(i);
              end;
    end;

  procedure dp;
    var
        tmp     : anstype;
        i, t, j : longint;
    begin
          fillchar(f, sizeof(f), false);
          f[1, abs(list[1, 1, 0] - list[1, 2, 0])] := true;
          for i := 2 to l do
            begin
              t := abs(list[i, 1, 0] - list[i, 2, 0]);
              for j := 0 to 100 do
                begin
                  f[i, j] := f[i - 1, j - t] or f[i - 1, j + t];
                  if not f[i, j]
                    then continue;
                  if (f[i - 1, j - t])
                    then begin
                      save[i, j] := j - t;
                      go[i, j] := 2
                    end
                    else begin
                      save[i, j] := j + t;
                      go[i, j] := 1;
                    end
                end;
            end;
          for i := 1 to l do
            if list[i, 1, 0] < list[i, 2, 0]
              then begin
                tmp := list[i, 1];
                list[i, 1] := list[i, 2];
                list[i, 2] := tmp;
              end;
    end;

  procedure add(a, b, c : longint);
    var
        tmp : anstype;
        i   : longint;
    begin
          for i := 1 to list[b, c, 0] do
            ans[a, ans[a, 0] + i] := list[b, c, i];
          inc(ans[a, 0], list[b, c, 0]);
          if ans[1, 0] < ans[2, 0]
            then begin
              tmp := ans[1];
              ans[1] := ans[2];
              ans[2] := tmp;
            end;
    end;

  procedure out(x, y : longint);
    var
        tmp  : anstype;
        i, t : longint;
    begin
          if x = 1
            then begin
              add(1, x, 1);
              add(2, x, 2);
              exit;
            end;
          out(x - 1, save[x, y]);
          if go[x, y] = 1
            then begin
              add(1, x, 2);
              add(2, x, 1);
            end
            else begin
              add(1, x, 1);
              add(2, x, 2);
            end;
    end;

  procedure print;
    var
        i, j, t : longint;
    begin
          fillchar(ans, sizeof(ans), 0);
          for i := 0 to 100 do
            if f[l, i]
              then break;
          out(l, i);
          for t := 1 to 2 do
            begin
              write(ans[t, 0]);
              for i := 1 to ans[t, 0] do
                write(' ', ans[t, i]);
              writeln;
            end;
    end;

  begin
        init;
        make;
        dp;
        print;
  end.