ENG  RUSTimus Online Judge
Online Judge
Problems
Authors
Online contests
About Online Judge
Frequently asked questions
Site news
Webboard
Links
Problem set
Submit solution
Judge status
Guide
Register
Update your info
Authors ranklist
Current contest
Scheduled contests
Past contests
Rules
back to board

Discussion of Problem 1182. Team Them Up!

WA on test 25.... Please help me
Posted by FailedWing 9 Nov 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.