http://acm.pku.edu.cn/JudgeOnline/problem?id=1112

Код:
program PKU1112;
{$i-,s-,q-,r-}

const maxn = 401;

type integer = longint;
     node = record
       tow, next: integer;
     end;

var hash, mark, g, clo: array[1..maxn] of integer;
    a: array[1..maxn * maxn] of node;
    s: array[0..maxn, 1..2] of integer;
    f, h: array[0..maxn, 0..maxn] of integer;
    n, m, sum1, sum2, tot: integer;

procedure insert(u, v: integer);
begin
  tot := tot + 1;
  a[tot].tow := v; a[tot].next := g[u];
  g[u] := tot;
end;

procedure prepare;
var u, v: integer;
begin
  read(n); tot := 0;
  fillchar(g, sizeof(g), 0);
  fillchar(hash, sizeof(hash), 0);
  for u := 1 to n do begin
    read(v); hash[u] := u;
    while v <> 0 do begin
      hash[v] := u;
      read(v);
    end;
    for v := 1 to n do if hash[v] <> u then begin
      insert(u, v);
      insert(v, u);
    end;
  end;
end;

function search(c, u, p: integer): boolean;
var tmp, v: integer;
begin
  if p = 1 then inc(sum1) else inc(sum2);
  mark[u] := p; clo[u] := c;
  search := false;
  tmp := g[u];
  while tmp <> 0 do begin
    v := a[tmp].tow;
    if mark[v] = mark[u] then exit;
    if (mark[v] = 0) and (not search(c, v, 3 - p)) then exit;
    tmp := a[tmp].next;
  end;
  search := true;
end;

procedure main;
var u, v, i, j, k, x0, y0, ans: integer;
begin
  fillchar(mark, sizeof(mark), 0);
  fillchar(clo, sizeof(clo), 0);
  m := 0;
  for u := 1 to n do if mark[u] = 0 then begin
    sum1 := 0; sum2 := 0;
    m := m + 1;
    if not search(m, u, 1) then begin
      writeln('No solution');
      exit;
    end;
    s[m, 1] := sum1; s[m, 2] := sum2;
  end;
  fillchar(f, sizeof(f), 0);
  fillchar(h, sizeof(h), 0);
  f[s[1, 1], s[1, 2]] := 1;
  h[s[1, 1], s[1, 2]] := 1;
  for k := 2 to m do begin
    for i := n downto 0 do
      for j := n downto 0 do if f[i, j] = k - 1 then begin
        x0 := i + s[k, 1];
        y0 := j + s[k, 2];
        if (x0 <= n) and (y0 <= n) then begin
          f[x0, y0] := k;
          h[x0, y0] := 1;
        end;
        x0 := i + s[k, 2];
        y0 := j + s[k, 1];
        if (x0 <= n) and (y0 <= n) then begin
          f[x0, y0] := k;
          h[x0, y0] := 2;
        end;
      end;
  end;
  x0 := -1; y0 := -1;
  ans := maxint;
  for i := 1 to n - 1 do begin
    j := n - i;
    if (f[i, j] > 0) and (abs(i - j) < ans) then begin
      ans := abs(i - j);
      x0 := i; y0 := j;
    end;
  end;
  if x0 = -1 then begin
    writeln('No solution');
    exit;
  end;
  fillchar(hash, sizeof(hash), 0);
  sum1 := x0; sum2 := y0;
  while (x0 + y0 > 0) do begin
    v := h[x0, y0]; u := f[x0, y0];
    hash[u] := v;
    x0 := x0 - s[u, v]; y0 := y0 - s[u, 3 - v];
  end;
  write(sum1, ' '); for i := 1 to n do if hash[clo[i]] = mark[i] then write(i, ' '); writeln;
  write(sum2, ' '); for i := 1 to n do if hash[clo[i]] <> mark[i] then write(i, ' '); writeln;
end;

begin
  while not eof do begin
    prepare;
    main;
  end;
end.