And,shouldn't this problem have a special judge?There may be many situations.
__
var col:array[1..100] of longint;
    c,c1,map:array[0..100,0..100] of boolean;
    t:array[1..3,1..100] of boolean;
    a,a1:array[0..100] of boolean;
    sum:array[0..3] of longint;
    n,i,j,k,l,x,ans:longint;

procedure dfs(x,v:longint);
var i:longint;
begin
 if col[x]<>0 then exit;
 if col[x]+v=3 then begin writeln('No solution');halt;end;
 col[x]:=v;inc(sum[v]);t[v,x]:=true;
 for i:=1 to n do if x<>i then
  if map[x,i] and map[i,x] then dfs(i,3-v);
end;

begin                assign(input,'1.txt');reset(input);
  readln(n);fillchar(col,sizeof(col),0);a[0]:=true;
  for i:=1 to n do begin read(x);while x<>0 do begin map[i,x]:=true;read(x);end;end;
  for i:=1 to n do if col[i]=0 then begin
   fillchar(t,sizeof(t),0);sum[1]:=0;sum[2]:=0;dfs(i,1);
   fillchar(a1,sizeof(a1),0);
   for k:=1 to 2 do
    for j:=0 to n-sum[k] do
     if a[j] and not a1[j+sum[k]] then begin
      a1[j+sum[k]]:=true;
      for l:=1 to n do c1[j+sum[k],l]:=c[j,l] or t[k,l];
     end;a:=a1;c:=c1;
  end;ans:=n;while(not a[ans])and(ans>=1) do dec(ans);
  write(ans);for i:=1 to n do if c[ans,i] then write(' ',i);writeln;
  write(n-ans);for i:=1 to n do if not c[ans,i] then write(' ',i);writeln;
end.