{$r-,q-,s-,i-,o+}
const
  inf=1000000000;

var
  last,min,nom,ans,t,tmp,x,kg,sum,n,i,j:longint;
  used:array[0..500500]of boolean;
  kol,kol2,a,q:array[0..500500]of longint;
  d:array[0..555,0..555]of longint;

begin
  read(n);
  for i:=1 to n do read(a[i]);
  fillchar(d,sizeof(d),$0);
  for i:=1 to n do begin
    read(kg);
    for j:=1 to kg do begin
      read(x);
      d[x][i]:=1;
      inc(kol2[i]);
    end;
  end;
  ans:=inf;
  for i:=1 to n do begin
    if (kol2[i]<>0)then continue;
    for j:=1 to n do kol[j]:=kol2[j];
    for j:=1 to n do used[j]:=false;
    sum:=0;
    used[i]:=true;
    last:=i;
    for j:=1 to n do
      if (d[i][j]=1)then dec(kol[j]);
    for j:=1 to n-1 do begin
      min:=inf;
      nom:=0;
      for x:=1 to n do
        if (not used[x])and((a[x]-a[last]+9)mod 3<min)and(kol[x]=0)then begin
          nom:=x;
          min:=(a[x]-a[last]+9)mod 3;
        end;
      if (nom=0)then begin
        sum:=inf;
        break;
      end;
      last:=nom;
      used[nom]:=true;
      sum:=sum+min;
      for x:=1 to n do
        if (d[nom][x]=1)then dec(kol[x]);
    end;
    if (sum<ans)then ans:=sum;
  end;
  writeln(ans+n);
end.

uses
  math;
const
  l=300;
var
  g:array[1..l,1..l] of longint;
  comp:array[1..l] of longint;
  used:array[1..l] of boolean;
  ans,n,m,i,j,x,k:longint;

function check(x:longint):longint;
var
  res,i,j,k,cnt,next,prev:longint;
  ready:boolean;
begin
  res:=0;
  repeat
    prev:=res;
    for i:=1 to n do
    begin
      if (comp[i]<>x) or (used[i]) then continue;
      cnt:=0;
      for j:=1 to n do if (g[i,j]=1) and (not used[j]) then inc(cnt);
      if (cnt<>0) then continue;
      inc(res);
      used[i]:=true;
    end;
  until (prev=res);
  ready:=true;
  for i:=1 to n do ready:=ready and used[i];
  if (ready) then begin check:=res; exit; end;
  if (x=1) then next:=2;
  if (x=2) then next:=3;
  if (x=3) then next:=1;
  res:=res+check(next)+1;
  check:=res;
end;

begin
  read(n);
  for i:=1 to n do read(comp[i]);
  for i:=1 to n do
  begin
    read(k);
    for j:=1 to k do begin read(x); g[i,x]:=1; end;
  end;
  ans:=maxlongint;
  for i:=1 to 3 do
  begin
    fillchar(used,sizeof(used),false);
    ans:=min(ans,check(i));
  end;
  writeln(ans);
end.

{$MODE OBJFPC}
const inp = '';
      outp= '';
      base= 250;

var fi,fo : text;
    n,kq,ans : longint;
    a,head : array[1..base] of longint;
    c : array[1..base,1..base] of boolean;
    free : array[1..base] of longint;
    check : array[1..base] of boolean;

procedure Input;
var i,x,j : longint;
begin
  assign(fi,inp); assign(fo,outp);
  reset(fi); rewrite(fo);
  readln(fi,n);
  for i:= 1 to n do read(fi,a[i]);
  for i:= 1 to n do
    begin
      read(fi,head[i]);
      for j:= 1 to head[i] do
        begin
          read(fi,x);
          c[i,x] := true;
        end;
    end;
end;

procedure dfs(u : longint);
var com,v,i : longint;
begin
  com := a[u];
  for v:= 1 to n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      dfs(v);
    end;
  com := a[u] + 1;
  if com > 3 then com := 1;
  for v:= 1 to  n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      inc(kq);
      dfs(v);
    end;
  com := 6 - com - a[u];
  for v := 1 to n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      kq := kq + 2;
      dfs(v);
    end;
end;

procedure Solve;
var i,j : longint;
begin
  ans := high(longint);
  for i:= 1 to n do
  if head[i] = 0 then
    begin
      for j:= 1 to n do check[j] := false;
      for j:= 1 to n do
        begin
          free[j] := head[j];
          if c[j,i] then dec(free[j]);
        end;
      check[i] := true;
      kq := n;
      dfs(i);
      if kq < ans then ans := kq;
    end;
  writeln(fo,ans);
end;

procedure Output;
begin
  close(fi); close(fo);
end;

begin
  Input;
  Solve;
  Output;
end.

program Project2;

{$APPTYPE CONSOLE}

var n,i,j,k,l,m,max,s,k1,k2,q,t,xxx:integer;
    used,used2: array [1..200] of boolean;
    x: array [1..200] of integer;
    a: array [1..200,1..200] of boolean;

procedure proc(y:integer);
var s,q,i,j:integer;
 begin
 q:=1;
 while q=1 do
  begin
  q:=0;
  for i:= 1 to n do
  if not used[i] then
   begin
   s:=0;
   for j:= 1 to n do if ((a[i,j]) and (not used2[j])) then s:=1;
   if s=0 then used[i]:=true;
   end;

  for i:= 1 to n do
   if x[i]=y then if ((used[i]) and (not used2[i])) then begin used2[i]:=true; q:=1; end;
  end;
 q:=0;
 for i:= 1 to n do if not used2[i] then q:=1;
 if q=1 then begin m:=m+1; proc(y mod 3 +1 );end;
 end;

begin
read(n);
for i:= 1 to n do read(x[i]);
for i:= 1 to n do
 begin
 read(t);
 for j:= 1 to t do begin read(m); a[i,m]:=true; end;
 end;
max:=999999;
for xxx:= 1 to 3 do
 begin
 for i:= 1 to n do used[i]:=false;
 for i:= 1 to n do used2[i]:=false;
 m:=n;
 proc(xxx);
 if m<max then max:=m;
 end;
write(max);
read(i);
end.

var n,i,j,num,time,m,h,answ,first:longint;
    a:array[0..301] of longint;
    b:array[0..301,0..301] of longint;
    used:array[0..301] of boolean;
    c:array[1..3,1..3] of longint;

function solve(k:longint):boolean;
var i,num:longint;
begin
 for i:= 1 to b[k][0] do
  begin
   num:=b[k][i];
   if used[num]=false then
    begin
     solve:=false;
     exit;
    end;
  end;
 solve:=true;
end;

begin
 c[1][2]:=1; c[1][3]:=2;
 c[2][1]:=2; c[2][3]:=1;
 c[3][1]:=1; c[3][2]:=2;
 //assign(input,'input.txt');
 //reset(input);
 readln(n);
 for i:= 1 to n do
  read(a[i]);
 for i:= 1 to n do
  begin
   read(b[i][0]);
   for j:= 1 to b[i][0] do
    read(b[i][j]);
  end;

 answ:=100000000;
 for first:= 1 to 3 do
 begin

 num:=first;

 fillchar(used,sizeof(used),false);
 time:=0;
 m:=n;
  //num:=num+1;
  //if num = 4 then num:=1;
  h:=0;
  while m>0 do
   begin
    for i:= 1 to n do
     if (used[i]=false) and (a[i]=num) and (solve(i))  then
      begin
       used[i]:=true;
       time:=time+1;
       m:=m-1;
      end;
     h:=h+1;
     if h = n+1 then
      begin
       h:=0;
       num:=num+1;
       if num = 4 then num:=1;
       time:=time+1;
      end;
end;
    if time<answ then answ:=time;
  end;
writeln(answ);
end.

                 program pr1;

{$APPTYPE CONSOLE}
 type
 zap=record p1,p2,p3:int64;end; zap1=^zap;
     chislo=record ch,st:int64;end; chislo1=^chislo;
const nn=1000001; besk=200000000000000;
   nnn=2000000;  eps=1e-14;
 label 1,2,3,4;
var st,len,i0,tt,j0,kolzn,k,kk,step,i,j,start,finish,per:longint;
x1,x2,x3,y1,y2,y3,p,t,t2,dx1,dy1,t1old,t2old,f,n,mmin,imin,p1,p2,s,l,m,k1,k2,a2:int64;
centr,aa,bb,cc,koef:int64;  ch,ch1,ch2:char;
ott:zap; ott1:zap1;
ot,pl,kol:array[0..1000] of int64;
a:array[0..1000,0..1000] of int64;
flag2,flag1,flag:boolean;
c1,c2:char;
sdelano:array[0..2000] of boolean;
ppp:array[0..1000000] of int64;
dd :double;
namemin:string;
ss1,ss2,ss:string;{array[0..1100000] of char;}
name:array[0..2000] of string;
spname: array[0..10000] of string;
function min (a,b:int64):int64;begin min:=b;if a<b then min:=a;  end;
function max (a,b:int64):int64;begin max:=b;if a>b then max:=a;  end;

function nod(a,b:int64):int64; var p,t:int64;
begin if (a>0)and(b>0) then
   begin while (b>0) do begin t:=a mod b;a:=b;b:=t;    end;
    p:=a;
   end else if a=0 then p:=b else p:=a;
nod:=p;
end;

 function vyp(num:longint):boolean; var i,j,k:longint; fl:boolean;
   begin
       fl:=true;
        for i:=1 to kol[num] do if not sdelano[a[num,i]] then fl:=false;
      vyp:=fl;
   end;

begin
{assign (input,'input.txt');reset(input);
      assign (output,'output.txt'); rewrite(output);
}                  read(n);
             for i:=1 to n do  read(pl[i]);
             for i:=1 to n do
               begin  read(kol[i]); for j:=1 to kol[i] do read(a[i,j]);

               end;
       {  for i:=1 to n do writeln(vyp(i)); writeln;
        sdelano[5]:=true;
         for i:=1 to n do writeln(vyp(i)); writeln;  }
    for   st:=1 to 3 do
 begin  start:=st;  for i:=1 to n do sdelano[i]:=false;
   2:
     3: kk:=ot[st];
        for i:=1 to n do
          begin
            if vyp(i)and (pl[i]=start)and(not sdelano[i]) then begin inc(ot[st]); sdelano[i]:=true;   end;

          end;  if kk<>ot[st] then goto 3;
             if start<3 then inc(start) else start:=1;
            inc(ot[st]);  flag:=false;
            for i:=1 to n do if not sdelano[i] then flag:=true;
            if flag then goto 2;
  end;
   { for i:=1 to 3 do   writeln(ot[i]); }
    kk:=1000000000;
   for i:=1 to 3 do kk:=min(kk,ot[i]);
   writeln(kk-1);

   1:          close(output);
end.

{$A8,B-,C+,D+,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q+,R+,S+,T-,U-,V+,W-,X+,Y+,Z1}
program ProbA;

{$APPTYPE CONSOLE}

uses
  SysUtils, Math;

const
  MaxN = 200;

type
  int = longint;
  matrix = array[1..MaxN, 0..MaxN] of int;
  spisok = array[1..3, 0..MaxN] of int;

var
  i, j, x, k, n: int;
  a, b, p: matrix;
  sp: spisok;
  c: array[1..MaxN] of int;
  was, used: array[1..MaxN] of boolean;
  ans, cans: int;

function rec(cur: int): int;
var
  i, j, x, z: int;
begin
  if sp[1, 0] + sp[2, 0] + sp[3, 0] = 0 then begin
    result := 0;
    exit;
  end;
  i := sp[cur, 0];
  result := 0;
  while i > 0 do begin
    x := sp[cur, sp[cur, 0]];
    was[x] := True;
    dec(sp[cur, 0]);
    inc(result);
    for j := 1 to n do begin
      if was[j] or used[j] then continue;
      if p[x, j] = 1 then
        dec(b[j, 0]);
      if (b[j, 0] = 0) then begin
        inc(sp[c[j], 0]);
        used[j] := True;
        sp[c[j], sp[c[j], 0]] := j;
      end;
    end;
    i := sp[cur, 0];
  end;
  z := rec(cur mod 3 + 1);
  if z > 0 then
    result := result + z + 1;
end;

begin
  //reset(input, 'input.txt');
  //rewrite(output, 'output.txt');
  read(n);
  for i := 1 to n do
    read(c[i]);
  for i := 1 to n do begin
    read(k);
    for j := 1 to k do begin
      read(x);
      a[i, x] := 1;
      inc(a[i, 0]);
      p[x, i] := 1;
    end;
  end;
  ans := maxlongint;
  for j := 1 to 3 do begin
    fillchar(sp, sizeof(sp), 0);
    fillchar(was, sizeof(was), False);
    fillchar(used, sizeof(used), False);
    b := a;
    for i := 1 to n do
      if a[i, 0] = 0 then begin
        inc(sp[c[i], 0]);
        used[i] := True;
        sp[c[i], sp[c[i], 0]] := i;
    end;
    cans := rec(j);
    ans := min(cans, ans);
  end;
  writeln(ans);
  //close(input);
  //close(output);
end.

{$R+,O-}
// Aimakov Yeldar, AtyrauKTL, 11 class
Uses Math, SysUtils;
type
	int = longint;
	bool = boolean;
const
	mx = maxint;
var
	was : array [0..201] of bool;
	res, ans, i, j, n, l, x, k, pos, sz, u : int;
	len, len1, a, v, t, f : array [0..201*201] of int;

procedure add(xx, yy : int);
begin
	inc(l);
	v[l] := yy;
	t[l] := f[xx];
	f[xx] := l;
end;

begin
//	assign(input, 'a.in'); reset(input);
//	assign(output, 'a.out'); rewrite(output);
	read(n); l := 0; res := mx;
	for i := 1 to n do read(a[i]);
	for i := 1 to n do begin
		read(len[i]);
		for j := 1 to len[i] do begin
			read(x);
			add(x, i);
		end;
	end;
	for i := 1 to n do
		if (len[i] = 0) then begin
			len1 := len; u := i;
			k := a[i]; sz := 0; ans := 0;
			fillchar(was, sizeof(was), false);
			while (sz <> n) do begin
				if (not was[u]) then begin
					inc(sz);
          pos := f[u];
					was[u] := true;
					while (pos > 0) do begin
						dec(len1[v[pos]]);
						pos := t[pos];
					end;
				end;
				for j := 1 to n do
					if (len1[j] = 0) and (k = a[j]) and (not was[j]) then begin
					    u := j;
						break;
					end;
				if (not was[u]) then continue;
				inc(k); inc(ans);
				if (k = 4) then k := 1;
			end;
			res := min(res, ans);
		end;
	writeln(res+n-1);
end.

{$APPTYPE CONSOLE}

uses
  SysUtils,math;
const dist:array[1..3,1..3] of integer=((0,1,2),(2,0,1),(1,2,0));
var
 used:Array[1..1000] of integer;
 k,c:array[1..1000] of integer;
 mas:array[1..500,1..500 ] of integer;
 v,timer,n,cand:int64;
 i,j,vertex:integer;
function check(v:integer):boolean;
var bool:boolean;
  i : integer;
begin
 bool:=true;
 for i:=1 to k[v] do
  if used[mas[v,i]]<2 then bool:=false;
 check:=bool;
end;
function solve(v : integer) : uint64;
var timer : uint64;
begin
 fillchar(used,sizeof(used),0);
 used[v]:=2;
 timer := 0;
 for vertex:=1 to n-1 do
 begin
  cand := -1;
  for i:=1 to n do
  begin
   if (used[i]=0) and (check(i)) then
    used[i]:=1;
   if (used[i] = 1) then
    if (cand = -1) or (dist[c[v],c[i]]<dist[c[v],c[cand]]) then
     cand:=i;
  end;
  inc(timer,dist[c[v],c[cand]]);
  v:=cand;
  used[v]:=2;
 end;
 solve := timer;
end;

begin
 readln(n);
 for i:=1 to n do
  read(c[i]);
 for i:=1 to n do
 begin
  read(k[i]);
  for j :=  1 to k[i] do
   read(mas[i,j]);
  readln;
 end;
 timer := 10000000000000000;
 for i:=1 to n do
  if (k[i] =0 ) and (c[i] = 1) then
   begin
    timer:=min(timer,solve(i));
    break;
   end;
 for i:=1 to n do
  if (k[i] = 0) and (c[i] = 2) then
   begin
    timer:=min(timer,solve(i));
    break;
   end;
 for i:=1 to n do
  if (k[i]= 0) and (c[i] =3) then
   begin
    timer:=min(timer,solve(i));
     break;
   end;
 writeln(timer + n);
end.

{$R-,S-,Q-,I-,O+}
var
  q,n,i,j,kr,cur,ans,best,st: longint;
  dd: boolean;
  kg,bad,c: array [0..210] of longint;
  ok: array [0..210] of boolean;
  g: array [0..210,0..210] of longint;
begin
  read(n);
  for i:=1 to n do read(c[i]);
  fillchar(g,sizeof(g),0);
  for i:=1 to n do
  begin
    read(kg[i]);
    for j:=1 to kg[i] do
    begin
      read(q);
      g[q,i]:=1;
    end;
  end;
  best:=maxlongint;
  for st:=1 to 3 do
  begin
    for i:=1 to n do bad[i]:=kg[i];
    for i:=1 to n do ok[i]:=False;
    cur:=st; kr:=0; ans:=0;
    while kr < n do
    begin
      dd:=True;
      while dd do
      begin
        dd:=False;
        for i:=1 to n do
          if (not ok[i]) and (c[i] = cur) and (bad[i] = 0) then
          begin
            dd:=True;
            ok[i]:=True;
            inc(kr);
            inc(ans);
            for j:=1 to n do
              if g[i,j] = 1 then dec(bad[j]);
          end;
      end;
      if kr = n then break;
      cur:=cur mod 3+1;
      inc(ans);
    end;
    if ans < best then best:=ans;
  end;
  writeln(best);
end.

program Codeforces;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Math;

var
  A: array[1..200, 1..200] of integer;
  k: array[1..200] of integer;
  n, i, j, x: integer;

  u: array[1..200] of integer;
  c: array[1..200] of integer;
  SC: array[1..200] of integer;
  Cans, minans, Curc, va, g, Cdel: integer;

begin
{$IFNDEF ONLINE_JUDGE}
  reset(input, 'input.txt');
  rewrite(output, 'output.txt');
{$ENDIF}
  read(n);

  for i := 1 to n do
    read(c[i]);

  for i := 1 to n do
  begin
    read(k[i]);
    for j := 1 to k[i] do
    begin
      read(x);
      a[i, x] := 1;
    end;
  end;

  minans := maxint;
  for va := 1 to 3 do
  begin
    cdel := 0;
    cans := 0;
    curc := va;
    for i := 1 to n do
    begin
      u[i] := 0;
      SC[i] := k[i];
    end;

    while Cdel <> N do
    begin

      g := 0;
      while (true) do
      begin
        for i := 1 to n do
          if (u[i] = 0) and (c[i] = curc) and (sc[i] = 0) then
          begin
            g := i;
            break;
          end;
        if g = 0 then
        begin
          inc(Cans);
          Curc := curc mod 3 + 1;
        end
        else
          break;
      end;

      begin
        u[g] := 1;
        for i := 1 to n do
          if a[i, g] = 1 then
            dec(sc[i]);
        inc(cdel);
        inc(cans);
      end;

    end;

    if Cans < minans then
      minans := cans;
  end;

  write(minans);
end.

var i,j,n,s,x,ans:longint;
    c,k,l:array[0..201] of longint;
    a:array[0..201,0..201] of longint;

procedure tt(x:longint);
var i,j,m:longint;
    ok:boolean;
 begin
  l:=k;
  m:=n;

  while m>0 do
   begin

    ok:=true;
    while ok do
     begin
      ok:=false;
      for i:=1 to n do
       if (c[i]=x) and
          (l[i]=0) then begin
                         dec(m);
                         inc(s);
                         for j:=1 to n do
                          if a[i,j]=1 then dec(l[j]);

                         ok:=true;
                         l[i]:=-1;
                        end;
     end;

    if m=0 then break;

    inc(s);
    inc(x);
    if x=4 then x:=1;
   end;
 end;

 begin
  read(n);
  for i:=1 to n do
   read(c[i]);

  for i:=1 to n do
   begin
    read(k[i]);
    for j:=1 to k[i] do
     begin
      read(x);
      a[x,i]:=1;
     end;

   end;

  ans:=maxlongint;
  for i:=1 to 3 do
   begin
    s:=0;
    tt(i);
    if s<ans then ans:=s;
   end;

  writeln(ans);
 end.

{$r-,q-,s-,o+}
{$IFNDEF ONLINE_JUDGE}
{$o-,r+,q+,s-}
{$ENDIF}
{$M 16777216}

program sample;

uses
  SysUtils,
  Math;

type mass1=array[1..3,1..200] of byte;
     mass2=array[1..200,0..200] of byte;

var a,aa:mass1;b,bb:mass2;
    n:integer;

procedure readdata;
var i,j,k,x:integer;
begin
  readln(n);

  for i:=1 to n do
   begin
     read(k);
     a[k][i]:=1;
   end;

  for i:=1 to n do
   begin
    read(k);
    b[i,0]:=k;
    for j:=1 to k do
      begin
        read(x);
        b[i,x]:=1;
      end;
   end;
  aa:=a;
  bb:=b;
end;

function findway(k:integer):integer;
var i,j,cnt:integer;f:Boolean;
begin
 a:=aa;b:=bb;cnt:=n;result:=n;
 while (cnt<>0) do
  begin
    f:=false;

    while (f=False) do
     begin
       f:=True;
       for i:=1 to n do
        if (a[k][i]=1)and(b[i,0]=0) then
           begin
            a[k][i]:=0;
            for j:=1 to n do
             if b[j][i]=1 then dec(b[j][0]);
            f:=false;
            Dec(cnt);
           end;
     end;

    if cnt<>0 then inc(Result);

    inc(k);
    if k=4 then k:=1;
  end;
end;

var ans:integer;
begin
 {$IFNDEF ONLINE_JUDGE}
   assign(input, 'input.txt');reset(input);
   assign(output, 'output.txt');rewrite(output);
 {$ENDIF}
  readdata;
  ans:=1000000;
  ans:=min(ans,findway(1));
  ans:=min(ans,findway(2));
  ans:=min(ans,findway(3));
  writeln(ans);
end.

var j,n,i,res,st,t,ost,q:longint;
    comp,s:array[0..300] of longint;
    used:array[0..300] of boolean;
    any,flag:boolean;
    a:array[0..300,0..300] of longint;
 begin
   read(n);
   for i:=1 to n do
    read(comp[i]);

   for i:=1 to n do
    begin
      read(s[i]);
      for j:=1 to s[i] do
       read(a[i][j]);
    end;

   res:=maxlongint;

   for st:=1 to 3 do
    begin
      fillchar(used,sizeof(used),false);

      t:=st;
      ost:=n;
      q:=0;

      while ost>0 do
       begin
         while true do
          begin
            any:=false;
            for i:=1 to n do
             if (not used[i]) and (comp[i]=t) then
              begin
                flag:=true;
                for j:=1 to s[i] do
                 if not used[a[i][j]] then
                  begin
                    flag:=false;
                    break;
                  end;
                if flag then
                 begin
                   used[i]:=true;
                   ost:=ost-1;
                   any:=true;
                 end;
              end;
            if not any then break;
          end;

         t:=t mod 3+1;
         q:=q+1;
       end;

      if q-1<res then res:=q-1;
    end;

   writeln(res+n);
 end.

var a,count,count1:array[1..200]of longint;
    map,map1:array[1..200,1..200]of boolean;
    used:array[1..200]of boolean;
    n,i,j,k,x,where,ans,minans,finish:longint;
    flag:boolean;
begin
  readln(n);
  for i:=1 to n do
    read(a[i]);
  fillchar(map,sizeof(map),false);
  for i:=1 to n do
    begin
      read(k);
      count[i]:=k;
      for j:=1 to k do
        begin
          read(x);
          map[x,i]:=true;
        end;
    end;
  minans:=maxlongint;
  for k:=1 to n do
    if count[k]=0 then
      begin
        where:=a[k];
        fillchar((used),sizeof(used),false);
        map1:=map;
        count1:=count;
        finish:=0;
        ans:=n;
        while finish<n do
          begin
            while true do
              begin
                flag:=false;
                for i:=1 to n do
                  if(not used[i])and(a[i]=where)and(count[i]=0)then
                    begin
                      inc(finish);
                      flag:=true;
                      used[i]:=true;
                      for j:=1 to n do
                        if map[i,j]=true then begin map[i,j]:=false;dec(count[j]);end;
                    end;
                if not flag then break;
              end;
            inc(where);
            inc(ans);
            if where=4 then where:=1;
          end;
        if ans-1<minans then minans:=ans-1;
        map:=map1;
        count:=count1;
      end;
  writeln(minans);
end.

uses math;
var
 n1,n2,n3,t,l,x,y,ans,n,j,k,nom,z,m,rez:longint;
 i:longint;
 d,dp:array[1..200,1..200] of longint;
 f:array[1..200] of boolean;
  a,b:array[0..100003] of longint;
 //t:int64;
 st,ss,s:ansistring;
 r,a1,b1:real;

begin
   read(n);
   for i:=1 to n do
    begin
     read(x);
     inc(a[x]);
     dp[x,a[x]]:=i;
    end;
   for i:=1 to n do
    begin
      read(b[i]);
      for j:=1 to b[i] do
       read(d[i,j]);

    end;

   rez:=maxlongint;
   for y:=1 to 3 do
   begin
    k:=0;t:=y;
    fillchar(f,sizeof(f),false);
    ans:=0;
   while k<>n do
     begin
       repeat
        l:=0;
        for i:=1 to a[t] do
         begin
          nom:=dp[t,i];
          if not f[nom] then
           begin
             x:=0;
             for j:=1 to b[nom] do
              if not f[d[nom,j]] then x:=1;
            if x=0 then begin inc(k);inc(ans);f[nom]:=true;l:=1;end;
           end;
         end;
       until l=0 ;
      inc(t);
      if t=4 then t:=1;
      if ans<>0 then inc(ans);
     end;
   if rez>ans then rez:=ans;

   end;
   write(rez-1);
end.

program form;
var s: string;
i,n,j,r,l: longint;
kol,kol1,k,gen,ans,m,x,min: int64;
co,count: array [1..3] of longint;
d,di,c: array [1..200] of longint;
f: array [1..200] of boolean;
a,b: array [1..200,1..200] of boolean;
fi: boolean;
begin
{assign (input, 'input.txt');
reset (input);
assign (output, 'output.txt');
rewrite (output); }
read (n);
for i:= 1 to n do
 begin read (c[i]); inc (count[c[i]]); end;
for i:= 1 to n do
 begin
 read (k);
 d[i]:= k;
 for l:= 1 to k do begin read (j); a[i,j]:= true; end;
 end;
k:= 1;
min:= 1000000000;
ans:= -1;
gen:= 0;
for i:= 1 to 3 do co[i]:= count[i];
for i:= 1 to n do
 for j:= 1 to n do b[i,j]:= a[i,j];
for i:= 1 to n do di[i]:= d[i];
for i:= 1 to n do f[i]:= false;
while true do
begin
inc (k);
if gen = n then break;
inc (ans);
if k=4 then k:= 1;
fi:= true;
if count[k]<>0 then
while fi=true do
begin
fi:= false;
 for i:= 1 to n do
  if f[i]=false then
   if d[i]=0 then
    if c[i]=k then
     begin
     dec (count[k]);
     inc (gen);
     fi:= true;
     f[i]:= true;
     for j:= 1 to n do
      begin
      if a[j,i]=true then dec (d[j]);
      a[j,i]:= false;
      end;
     end;
end;
end;
if ans<min then min:= ans;

k:= 2;
ans:= -1;
gen:= 0;
for i:= 1 to n do f[i]:= false;
for i:= 1 to 3 do count[i]:= co[i];
for i:= 1 to n do
 for j:= 1 to n do a[i,j]:= b[i,j];
for i:= 1 to n do d[i]:= di[i];
while true do
begin
inc (k);
if gen = n then break;
inc (ans);
if k=4 then k:= 1;
fi:= true;
if count[k]<>0 then
while fi=true do
begin
fi:= false;
 for i:= 1 to n do
  if f[i]=false then
   if d[i]=0 then
    if c[i]=k then
     begin
     dec (count[k]);
     inc (gen);
     fi:= true;
     f[i]:= true;
     for j:= 1 to n do
      begin
      if a[j,i]=true then dec (d[j]);
      a[j,i]:= false;
      end;
     end;
end;
end;
if ans<min then min:=ans;

k:= 3;
ans:= -1;
gen:= 0;
for i:= 1 to n do f[i]:= false;
for i:= 1 to 3 do count[i]:= co[i];
for i:= 1 to n do
 for j:= 1 to n do a[i,j]:= b[i,j];
for i:= 1 to n do d[i]:= di[i];
while true do
begin
inc (k);
if gen = n then break;
inc (ans);
fi:= true;
if k=4 then k:= 1;
if count[k]<>0 then
while fi=true do
begin
fi:= false;
 for i:= 1 to n do
  if f[i]=false then
   if d[i]=0 then
    if c[i]=k then
     begin
     dec (count[k]);
     inc (gen);
     fi:= true;
     f[i]:= true;
     for j:= 1 to n do
      begin
      if a[j,i]=true then dec (d[j]);
      a[j,i]:= false;
      end;
     end;
end;
end;
if ans <min then min:= ans;
writeln (min+n);

{close (input);
close (output); }

end.

var
  q,n,i,j,kr,cur,ans,best,st: longint;
  dd: boolean;
  kg,bad,c: array [0..210] of longint;
  ok: array [0..210] of boolean;
  g: array [0..210,0..210] of longint;
begin
  read(n);
  for i:=1 to n do read(c[i]);
  fillchar(g,sizeof(g),0);
  for i:=1 to n do
  begin
    read(kg[i]);
    for j:=1 to kg[i] do
    begin
      read(q);
      g[q,i]:=1;
    end;
  end;
  best:=maxlongint;
  for st:=1 to 3 do
  begin
    for i:=1 to n do bad[i]:=kg[i];
    for i:=1 to n do ok[i]:=False;
    cur:=st; kr:=0; ans:=0;
    while kr < n do
    begin
      dd:=True;
      while dd do
      begin
        dd:=False;
        for i:=1 to n do
          if (not ok[i]) and (c[i] = cur) and (bad[i] = 0) then
          begin
            dd:=True;
            ok[i]:=True;
            inc(kr);
            inc(ans);
            for j:=1 to n do
              if g[i,j] = 1 then dec(bad[j]);
          end;
      end;
      if kr = n then break;
      cur:=cur mod 3+1;
      inc(ans);
    end;
    if ans < best then best:=ans;
  end;
  writeln(best);
end.

VAR
        a,b,i,j,n,m:longint;
        x:array[0..200,0..200]of boolean;
        d,ind,q,pos:array[0..200]of longint;
        vis:array[0..200]of boolean;
        ans,temp:int64;
        l,r:longint;

BEGIN
        read(n);
        for i:=1 to n do read(pos[i]);
        for i:=1 to n do begin
                read(a);
                for j:=1 to a do begin
                        read(b);
                        x[b,i]:=true;
                        inc(d[i]);
                end;
        end;
        ans:=maxlongint;
        for i:=1 to 3 do begin
                j:=i;m:=n;temp:=0;
                fillchar(vis,sizeof(vis),false);
                for a:=1 to n do ind[a]:=d[a];
                while m>0 do begin
                        l:=0;r:=0;
                        for a:=1 to n do if (pos[a]=j)and(not vis[a])and(ind[a]<=0)then begin
                                inc(r);
                                q[r]:=a;
                                vis[a]:=true;
                        end;
                        while l<>r do begin
                                inc(l);
                                dec(m);
                                a:=q[l];
                                for b:=1 to n do if (x[a,b]) then begin
                                        dec(ind[b]);
                                        if (not vis[b])and(ind[b]<=0)and(pos[b]=j) then begin
                                                inc(r);
                                                q[r]:=b;
                                                vis[b]:=true;
                                        end;
                                end;
                        end;
                        j:=j mod 3+1;
                        if m>0 then inc(temp);
                end;
                if ans>temp then ans:=temp;
        end;
        writeln(ans+n);
END.

var n, i, time, j, x, s, min, p, k1, w: Longint;
    k, c: array [1..1000] of Longint;
    l, r: array [1..3] of Longint;
    q: array [1..3, 1..1000] of Longint;
    a: array [1..300, 1..300] of Boolean;

Begin
    read(n);
    for i := 1 to n do
        read(c[i]);
    for i := 1 to n do begin
        read(k[i]);
        for j := 1 to k[i] do begin
            read(x);
            a[x, i] := true;
        end;
    end;
    min := 1000000;

    for w := 1 to 3 do begin
    time := 0;
    i := w;
    for j := 1 to 3 do begin
        l[j] := 1;
        r[j] := 0;
    end;
    for j := 1 to n do begin
        k1 := 0;
        for p := 1 to n do
            if a[p, j] = true then
                inc(k1);
        if k1 = 0 then begin
            inc(r[c[j]]);
            q[c[j], r[c[j]]] := j;
        end;
        k[j] := k1;
    end;
    while r[1] - l[1] + r[2] - l[2] + r[3] - l[3] > -3 do begin
        while l[i] <= r[i] do begin
            inc(time);
            for j := 1 to n do
                if a[q[i, l[i]], j] = true then begin
                    dec(k[j]);
                    if k[j] = 0 then begin
                        inc(r[c[j]]);
                        q[c[j], r[c[j]]] := j;
                    end;
                end;
            inc(l[i]);
        end;
        inc(i);
        if i = 4 then
            i := 1;
        if time <> 0 then
            inc(time);
    end;
    if time <= min then
        min := time - 1;
    end;
    write(min);
End.

var
 stn,c:array[0..1000]of longint;
 f:array[0..1000]of boolean;
 st:array[0..1000,0..1000]of byte;
 ve,g,i,j,n,v,z,r,min,mini,min1,ans:longint;
begin
{ assign(input,'a.in');
 reset(input);
 assign(output,'a.out');
 rewrite(output);   }
 readln(n);
 for i:=1 to n do read(c[i]);
 readln;
 for i:=1 to n do
 begin
  read(stn[i]);
  if stn[i]=0 then mini:=i;
  for j:=1 to stn[i] do read(st[i,j]);
  readln;
 end;
 min1:=maxlongint;
 for i:=1 to 3 do
 begin
  v:=i;
  ans:=0;
  fillchar(f,sizeof(f),0);
  f[0]:=true;
  for ve:=1 to n do
  begin
   min:=10;
   for r:=1 to n do if f[r]=false then
   begin
    for z:=0 to stn[r] do
    if (f[st[r,z]]=true) then
    begin
     if z=stn[r] then
     begin
      if (v=c[r]) then g:=0;
      if (v=1)and(c[r]=2) then g:=1;
      if (v=1)and(c[r]=3) then g:=2;
      if (v=2)and(c[r]=1) then g:=2;
      if (v=2)and(c[r]=3) then g:=1;
      if (v=3)and(c[r]=1) then g:=1;
      if (v=3)and(c[r]=2) then g:=2;
      if g<min then
      begin
       min:=g;
       mini:=r;
      end;
     end;
    end else break;
   end;
   v:=c[mini];
   inc(ans);
   inc(ans,min);
   f[mini]:=true;
  end;
  if ans<min1 then min1:=ans;
 end;
 writeln(min1);
end.

uses math;
Var x,n,i,j,ans:longint;
    e,left,c:array[0..222]of longint;
    a:array[0..222,0..222]of boolean;
    used:array[0..222]of boolean;
 procedure go(tmp:longint);
   var res,cnt,i,j:longint;
       ok:boolean;
     begin
       res:=n;
       cnt:=0;
       for i:=1 to n do
        begin
         left[i]:=e[i];
         used[i]:=false;
        end;
       while cnt<n do
         begin
           ok:=false;
           for i:=1 to n do
             if left[i]=0 then if c[i]=tmp then if not used[i] then
               begin
                 ok:=true;
                 used[i]:=true;
                 inc(cnt);
                 for j:=1 to n do
                   if a[i,j] then dec(left[j]);
               end;
            if cnt=n then break;
           if not ok then
             begin
               tmp:=tmp+1;
               res:=res+1;
               if tmp=4 then tmp:=1;
             end;
         end;
       ans:=min(ans,res);
     end;
  begin
    read(n);
    for i:=1 to n do
      read(c[i]);
    for i:=1 to n do
      begin
        read(e[i]);
        for j:=1 to e[i] do
         begin
           read(x);
           a[x,i]:=true;

         end;
      end;
    ans:=maxlongint;
    go(1);
    go(2);
    go(3);
    writeln(ans);
  end.

var was,a:array[1..300] of longint;
    edge,uedge:array[1..300,1..300] of longint;
    ans,i,j,n,x,k:longint;

    function min(a,b:longint):longint;
     begin
      if a<b then min:=a else min:=b;
     end;

   function not_empty:boolean;
    var i:longint;
     begin
      for i:=1 to n do if was[i]=1 then exit(true);
      exit(false);
     end;

   function find(p:longint):longint;
    var res:longint;
        i,j:longint;
        fl,fl2:boolean;
     begin
      res:=0;
      for i:=1 to n do was[i]:=1;
       edge:=uedge;
      while not_empty do
       begin
        fl:=false;
        for i:=1 to n do
         if (a[i]=p) and (was[i]=1) then
          begin
           fl2:=true;
           for j:=1 to n do if edge[i][j]=1 then begin fl2:=false; break; end;
           if fl2 then
            begin
             fl:=true;
             inc(res);
             for j:=1 to n do edge[j][i]:=0;
             was[i]:=0;
            end;
           end;
         if not fl then begin inc(res); p:=(p+1) mod 3; end;
       end;
      exit(res);
    end;

     begin
      readln(n);
      for i:=1 to n do
       begin
        read(x);
        a[i]:=x-1;
       end;
      for i:=1 to n do
       begin
        read(k);
        while k<>0 do
         begin
          read(x);
          dec(k);
          uedge[i][x]:=1;
         end;
       end;
     ans:=find(0);
     ans:=min(ans,find(1));
     ans:=min(ans,find(2));
    writeln(ans);
   end.

var a:array[1..200,1..200]of boolean;
    b,c:array[1..200]of boolean;
    x:array[1..200]of longint;
    tmin,i,f,n,p,t,k,l,num:longint;
function prb:boolean;
var i:longint;
begin
 prb:=false;
 for i:=1 to n do
  if not(b[i]) then begin prb:=true;break;end;
end;
function prbp:boolean;
var i,f:longint;log:boolean;
begin
 prbp:=false;
 for i:=1 to n do
 begin
  log:=false;
  if (x[i]=p)and(not(b[i])) then
  begin
   for f:=1 to n do
    if (not(b[f]))and(a[i,f]) then begin log:=true;break;end;
   if not(log) then begin prbp:=true;num:=i;break;end;
  end;
 end;
end;
begin
 readln(n);tmin:=99999999;
 for i:=1 to n do
  read(x[i]);
 for i:=1 to n do
 begin
  read(k);
  for f:=1 to k do
  begin
   read(l);
   a[i,l]:=true;
  end;
 end;
 p:=1;t:=0;
 while prb do
 begin
  while prbp do
  begin
   b[num]:=true;
   t:=t+1;
  end;
  inc(p);inc(t);
  if p=4 then p:=1;
 end;
 if t<tmin then tmin:=t;
 p:=2;t:=0;b:=c;
 while prb do
 begin
  while prbp do
  begin
   b[num]:=true;
   t:=t+1;
  end;
  inc(p);inc(t);
  if p=4 then p:=1;
 end;
 if t<tmin then tmin:=t;
 p:=3;t:=0;b:=c;
 while prb do
 begin
  while prbp do
  begin
   b[num]:=true;
   t:=t+1;
  end;
  inc(p);inc(t);
  if p=4 then p:=1;
 end;
 if t<tmin then tmin:=t;
 writeln(tmin-1);
end.

var l,ans,v,min,q,start,w,n,i,j:longint;
    c:array[1..200] of longint;
    d:array[1..200] of boolean;
    b,k:array[1..200] of longint;
    a:array[1..200,1..200] of longint;
 begin
  read(n);
  min:=maxlongint;
  for i:=1 to n do
   read(c[i]);
  for i:=1 to n do
   begin
    read(k[i]);
    for j:=1 to k[i] do
     read(a[i,j]);
    b[i]:=k[i];
   end;
  for start:=1 to 3 do
   begin
    l:=0;
    ans:=-1;
    v:=start;
    for i:=1 to n do
     begin
      d[i]:=false;
      b[i]:=k[i];
     end;
    while l<n do
     begin
      ans:=ans+1;
      for w:=1 to 5 do
      for i:=1 to n do
       if (c[i]=v)and(b[i]=0)and not(d[i]) then
        begin
         inc(l);
         d[i]:=true;
         ans:=ans+1;
         if l=n then break;
         for j:=1 to n do
          for q:=1 to k[j] do
           if a[j,q]=i then dec(b[j]);
        end;
       v:=(v mod 3)+1;
     end;
    if ans<min then min:=ans;
   end;
  writeln(min);
 end.

var i,j,n,t,ans:longint;
    v:array[0..201] of boolean;
    a,s:array[0..201] of longint;
    c:array[1..3,1..3] of longint;
    b:array[0..201,0..201] of longint;

procedure tt(x:longint);
var i,j,p,lt:longint;
    ok:boolean;
 begin
  s[1]:=0;
  s[2]:=0;
  s[3]:=0;
  for p:=1 to n do
   begin
    lt:=t;

    for i:=1 to n do
     begin
      if v[i] then continue;

      ok:=true;
      for j:=1 to b[i,0] do
       if not(v[b[i,j]]) then begin ok:=false;break; end;

      if ok then begin
                  if (a[i]=x) then begin
                                    inc(t);
                                    v[i]:=true;
                                   end;
                 end;
     end;

    if t=lt then break;
   end;
  for i:=1 to n do
   begin
    if v[i] or (a[i]=x) then continue;

    ok:=true;
    for j:=1 to b[i,0] do
     if not(v[b[i,j]]) then begin ok:=false;break; end;

    if ok then inc(s[a[i]]);
   end;

  for i:=1 to 3 do
   if (s[i]>0) and (c[x,i]=1) then begin t:=t+1;tt(i);exit; end;

  for i:=1 to 3 do
   if s[i]>0 then begin t:=t+c[x,i];tt(i);exit;end;
 end;

 begin
  read(n);
  for i:=1 to n do
   read(a[i]);
  for i:=1 to n do
   begin
    read(b[i,0]);
    for j:=1 to b[i,0] do
     read(b[i,j]);
   end;

  c[1,2]:=1;
  c[1,3]:=2;
  c[2,1]:=2;
  c[2,3]:=1;
  c[3,1]:=1;
  c[3,2]:=2;

  ans:=maxlongint;
  for i:=1 to 3 do
   begin
    fillchar(v,sizeof(v),false);

    t:=0;
    tt(i);

    if t<ans then ans:=t;
   end;

  writeln(ans);
 end.

var k, c, kol, kols: array [1..10000] of Longint;
    a: array [1..200, 1..40000] of Longint;
    x1, k1, n, i, t, j: Longint;
    q: array [1..3, 1..100000] of Longint;
    min, sum, now, mark: Longint;
    l, r: array [1..3] of Longint;

Begin
     read(n);
     for i := 1 to n do
         read(c[i]);
     for i := 1 to n do begin
         read(k1);
         kols[i] := k1;
         for j := 1 to k1 do begin
             read(x1);
             inc(k[x1]);
             a[x1, k[x1]] := i;
         end;
     end;
     min := maxlongint;
     for t := 1 to 3 do begin
         for i := 1 to 3 do
             r[i] := 0;
         for i := 1 to n do
             kol[i] := kols[i];
         mark := 0;
         for i := 1 to n do
             if kol[i] = 0 then begin
                inc(r[c[i]]);
                q[c[i], r[c[i]]] := i;
             end;
         for i := 1 to 3 do
             l[i] := 1;
         now := t;
         sum := 0;
         while (l[1] <= r[1]) or (l[2] <= r[2]) or (l[3] <= r[3]) do begin
             if l[now] > r[now] then begin
                inc(now);
                if now > 3 then
                   now := now - 3;
                inc(sum);
                continue;
             end;
             sum := sum + 1;
             inc(mark);
               for j := 1 to k[q[now, l[now]]] do begin
                   x1 := a[q[now, l[now]], j];
                   dec(kol[x1]);
                   if kol[x1] = 0 then begin
                      inc(r[c[x1]]);
                      q[c[x1], r[c[x1]]] := x1;
                   end;
               end;
               if mark = n then
                  break;
               inc(l[now]);
               if l[now] > r[now] then begin
                  now := now + 1;
                  inc(sum);
               end;
               if now > 3 then
                  now := now - 3;
         end;
         if sum < min then
            min := sum;
     end;
     writeln(min);
End.

Program zad3;

Var
 w: boolean;
 j, i, h, p, n, t: byte;
 a: array [1..200, 1..200] of byte;
 c, k: array [1..200] of byte;
 sum, res: word;
 s, q: set of byte;

Function dost (i: byte): boolean;
 var
  d: boolean;
  h: byte;
 begin
  d:=true;
  h:=1;
  while d and (h<=k[i]) do
   begin
    if a[i, h] in s
     then d:=false
     else inc (h);
   end;
  dost:=d;
 end;

Begin
 {assign (input, 'input.txt');
 assign (output, 'output.txt');
 reset (input);
 rewrite (output);}
 readln (n);
 q:=[];
 for i:=1 to n do
  read (c[i]);
 readln;
 for i:=1 to n do
  begin
   include (q, i);
   read (k[i]);
   for j:=1 to k[i] do
    read (a[i, j]);
   readln;
  end;
 sum:=high(word);
 for i:=1 to 3 do
  begin
   res:=0;
   s:=q;
   t:=i;
   while s<>[] do
    begin
     repeat
      w:=false;
      for j:=1 to n do
       if (c[j]=t) and (j in s) and dost(j)
	then
	 begin
	  inc (p);
	  exclude (s, j);
	  w:=true;
	 end;
     until not w;
     inc (res, p+1);
     t:=t mod 3+1;
     p:=0;
    end;
   if (res-1)<sum
    then sum:=res-1;
  end;
 writeln (sum);
End.

program Project2;

{$APPTYPE CONSOLE}

var n,m,i,j,k,l,s,w,t,c,max,xx:integer;
    a: array [1..200,1..200] of boolean;
    stack,x: array [1..200] of integer;
    used,used2: array [1..200] of boolean;
procedure prop(xx:integer);
var q:integer;
begin
q:=0;
      while q=0 do begin
      q:=1;
      for i:= 1 to n do
      begin
      k:=0;
      for j:= 1 to n do if ((a[i,j]) and (not used2[j])) then k:=1;
      if ((k=0) and (not used[i])) then used[i]:=true;
      end;

      for i:= 1 to n do
       if x[i]=xx then if ((used[i]) and (used2[i]=false)) then
         begin used2[i]:=true; q:=0; end;
                        end;
      w:=0;
      for i:= 1 to n do if not used2[i] then w:=1;
      if w=1 then begin m:=m+1; prop(xx mod 3 +1); end;
end;

begin
read(n);
for i:= 1 to n do read(x[i]);
for i:= 1 to n do
 begin
 read(t);
 for j:= 1 to t do begin read(c); a[i,c]:=true; end;
 end;

max:=999999;
for xx:= 1 to 3 do
 begin
 for i:= 1 to n do used[i]:=false;
 for i:= 1 to n do used2[i]:=false;
 m:=n;
 prop(xx);
 if m<max then max:=m;
 end;
write(max);
read(i);
end.

uses    math;
const   fi='';{'1.inp';}
        fo='';{1.out';}
        nmax = 200;
var     A:array[1..nmax,1..nmax] of integer;
        may,free,bacvao,bacra,Q1,Q2,Q3:array[1..nmax] of integer;
        N,kq,count,res:longint;
        f1,f2,f3,l1,l2,l3:longint;
        f:Text;

procedure khoitao;
begin
        fillchar(free,sizeof(free),0);
        fillchar(Q1,sizeof(Q1),0);
        fillchar(Q2,sizeof(Q2),0);
        fillchar(Q3,sizeof(Q3),0);
end;

procedure doc;
var     i,j,k,t:integer;
begin
        assign(f,fi); reset(f);
        readln(f,N);
        for i:=1 to N do read(f,may[i]);
        readln(f);
        for i:=1 to N do
        begin
                read(f,k);
                for j:=1 to k do
                Begin
                        read(f,t);
                        A[t,i] := 1;
                        inc(bacvao[i]);
                        inc(bacra[t]);
                end;
                readln(f);
        end;
        close(f);
end;

function kt(u:longint):boolean;
var     v:longint;
begin
        kt := true;
        for v:=1 to N do
        if (A[v,u] = 1) and (free[v]=0) then exit(false);
end;

procedure xuly_may(u:longint);
var     v,k:longint;
begin
        for v:=1 to N do
        if A[u,v] = 1 then
        if free[v] = 0 then
        if kt(v) then
        begin
                case may[v] of
                1:      begin   inc(l1); Q1[l1]:=v; end;
                2:      begin   inc(l2); Q2[l2]:=v; end;
                3:      begin   inc(l3); Q3[l3]:=v; end;
                end;
        end;
end;

procedure tinhtoan(mm:longint);
var     i,j,count,k:longint;
begin
        f1:=0;l1:=0;f2:=0;l2:=0;f3:=0;l3:=0;
        for i:=1 to N do
        if bacvao[i] = 0 then
        begin
                case may[i] of
                1:      begin
                                inc(l1);
                                Q1[l1]:=i;
                        end;
                2:      begin
                                inc(l2);
                                Q2[l2]:=i;
                        end;
                3:      begin
                                inc(l3);
                                Q3[l3]:=i;
                        end;
                end;
        end;
        count :=N;
        kq:=0;
        repeat
                case mm of
                1:      if f1 <= l1 then
                        while true do
                        begin
                                inc(f1);
                                if f1 > l1 then
                                if count > 0 then
                                        begin dec(f1); inc(kq); mm:=2; break; end
                                else exit;
                                dec(count);
                                i := Q1[f1];
                                free[i]:=1;
                                xuly_may(i);
                        end;
                2:      if f2 <=l2 then
                        while true do
                        Begin
                                inc(f2);
                                if f2 > l2 then
                                if count > 0 then
                                        begin dec(f2); inc(kq); mm:=3; break; end
                                else exit;
                                dec(count);
                                i := Q2[f2];
                                free[i]:=1;
                                xuly_may(i);
                        end;
                3:      if f3 <= l3 then
                        while true do
                        Begin
                                  inc(f3);
                                  if f3 > l3 then
                                  if count > 0 then
                                        begin dec(f3); inc(kq); mm:=1; break; end
                                  else exit;
                                  dec(count);
                                  i := Q3[f3];
                                  free[i]:=1;
                                  xuly_may(i);
                        end;
                end;
        until count=0;
end;

procedure xuly;
var     i:longint;
begin

        res:=maxlongint;
        for i:=1 to 3 do
        begin
                khoitao;
                tinhtoan(i);
                res:=min(res,kq);
        end;
end;

procedure ghi;
begin
        assign(f,fo); rewrite(f);
        write(f,res+N);
        close(f);
end;

BEGIN
        khoitao;
        doc;
        {sort;}
        xuly;
        ghi;
END.

program z2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  a,a0: array[1..200,1..200] of longint;
  num: array[1..200]  of longint;
  k,k0: array[1..200] of LongInt;
  n,i,j,c,p,q,hours,ans,comp: longint;
  f: Boolean;

procedure play;
var f: integer;
begin
f:=0;
   for i:=1 to n do
      if (num[i]=comp) and (k[i]=0) then
      begin
      Inc(f);
      Dec(k[i]);
      for j:=1 to n do
          if a[j][i]=1 then begin dec(k[j]); a[j][i]:=0; end;
      end;
if f>0 then begin hours:=hours+f; play; end;
end;

begin
//Assign(input,'input.txt'); Reset(input);
//assign(output,'output.txt'); Rewrite(output);

for i:=1 to n do
 for j:=1 to n do
  a[i][j]:=0;

Readln(n);
for i:=1 to n do
  read(num[i]);
for i:=1 to n do
begin
  read(k[i]);
  for j:=1 to k[i] do
  begin
    read(q);
    a[i][q]:=1;
  end;
end;

ans:=2147000000;  k0:=k; a0:=a;
for c:=1 to 3 do
begin
  comp:=c;
  hours:=0;
  f:=true;
  while f do
  begin
  play;
  f:=false;
  for i:=1 to n do
    if k[i]<>-1 then f:=True;
    comp:=comp mod 3+1; if f then inc(hours);
  end;
  k:=k0; a:=a0;
  if hours<ans then ans:=hours;
end;

Writeln(Ans);

//close(input);
//close(output);
end.

{$apptype console}
const maxn = 200;

var n, total: integer;
    p, need, nc : array [1..maxn] of integer;
    nx: array [1..maxn] of record cnt : integer; d : array [1..maxn] of integer; end;
    mask : array [1..maxn] of boolean;

function play( c : integer ):integer;
var chg : boolean;
    i, j : integer;
begin
  result := 0;
  chg := true;
  while chg do begin
    chg := false;
    for i := 1 to n do if not mask[i] and (nc[i] = 0) and ( p[i] = c) then begin
       mask[i] := true;
       for j := 1 to nx[i].cnt do
          dec( nc[ nx[i].d[j] ] );
       chg := true;
       inc(result);
       inc(total);
    end;
  end;
  if total < n then
    result := result + 1 + play(c mod 3 + 1);
end;

var t, min, i, j, k, v : integer;
begin
  read( n );
  for i := 1 to n do read(p[i] );
{}
  for i := 1 to n do nx[i].cnt := 0;
{}
  for i := 1 to n do begin
     read( k);
     need[i] := k;
     for j := 1 to k do begin
        read(v);
        with nx[v] do begin
          inc(cnt);
          d[cnt] := i;
        end;
     end;
  end;
{}
  total := 0;
  fillchar( mask, sizeof(mask), false);
  move( need, nc, sizeof(need) );
  min := play(1);

  total := 0;
  fillchar( mask, sizeof(mask), false);
  move( need, nc, sizeof(need) );
  t := play(2);
  if t < min then min := t;

  total := 0;
  fillchar( mask, sizeof(mask), false);
  move( need, nc, sizeof(need) );
  t := play(3);
  if t < min then min := t;
{}
  writeln(min);
end.

program aa;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
 n,sum1,min,sum,m,k,i,it,ot,p,j:longint;
 f:array[1..200000]of boolean;
 a:array[1..2000,1..2000]of longint;
 col,sch:array[1..10000]of longint;
 o,g:boolean;
begin
{  reset(input, 'input.txt');
  rewrite(output, 'output.txt'); }
  read(n);
  min := maxlongint;
  for i:=1 to n do
    read(col[i]);
  for i:=1 to n do
    begin
      read(sch[i]);
      for j:=1 to sch[i] do
        read(a[i][j]);
    end;
  for p:=1 to 3 do
    begin
      for i:=1 to n do
        begin
         f[i] := false;
        end;
      it:=0;
      i := p;
      ot := 0;
      while (it < n) do
        begin
          o:=false;
          for j:=1 to n do
            begin
              if f[j] = false then
               begin
                g:=false;
                for k:=1 to sch[j] do
                 if f[a[j][k]] = false then
                   g := true;
                 if (g = false)and(col[j] = i) then
                  begin
                    f[j] := true;
                    o:=true;
                    inc(ot);
                    inc(it);
                    if (it = n) then
                      begin
                        if ot < min then
                          min :=ot;
                      end;
                   end;
                end;
            end;
          if (o = false) then
            begin
              inc(ot);
              if (i = 3) then
                i:=1 else
                inc(i);
            end;
        end;
    end;
    write (min);
end.

var
  p,tmp,c:array[1..200] of longint;
  w:array[1..200,1..200] of boolean;
  v:array[1..200] of boolean;
  i,j,k,x,ans,n,num,s,q:longint;
begin
  readln(n);
  for i:=1 to n do read(c[i]);
  for i:=1 to n do
    begin
      read(p[i]);
      for j:=1 to p[i] do
        begin
          read(x);
          w[x,i]:=true;
        end;
    end;
  for i:=1 to n do tmp[i]:=p[i];
  ans:=10000;
  s:=1; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=s mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  for i:=1 to n do p[i]:=tmp[i];
  fillchar(v,sizeof(v),0);
  s:=2; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=s mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  fillchar(v,sizeof(v),0);
  for i:=1 to n do p[i]:=tmp[i];
  s:=3; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=s mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  writeln(ans);
end.

uses math;
const
      oo=high(longint);
      _oo=high(int64);
      roo=1e30;
      dx:array[0..7] of longint=(-1,0,1,0,-1,1,1,-1);
      dy:array[0..7] of longint=(0,1,0,-1,1,1,-1,-1);
type point=record x,y:longint; end;
     rpoint=record x,y:double; end;
var f,g:text;
    fi,fo:string;
    id,countt,count,degg,fa,deg:array[0..333] of longint;
    a:array[0..300,0..300] of boolean;
    ans,i,j,n,st,cv,k,t,v,anss:longint;
procedure closefile; begin close(g); close(F); end;
begin
        randomize;
        {$IFNDEF ONLINE_JUDGE} fi := 'i.inp'; fo := ''; {$ENDIF}
        assign(f,fi); reset(f);
        assign(g,fo); rewrite(g);
            readln(f,n);

            for i:=1 to n do read(f,id[i]);
            for i:=1 to n do begin
                read(f,k);
                for j:=1 to k do begin
                    read(f,t);
                    a[t,i]:=true;
                end;
                readln(f);
                degg[i]:=k;
                if k=0 then inc(countt[id[i]]);

            end;
            ans:=oo;
            for i:=1 to 3 do
             if countt[i]>0 then begin
                 deg:=degg;
                 count:=countt;
                 cv:=n;
                 anss:=0;
                 st:=i;
                 repeat
                   while count[st]>0 do begin
                    for j:=1 to n do
                      if (id[j]=st) and (deg[j]=0) then begin
                         dec(cv);
                         deg[j]:=-1;
                         dec(count[st]);
                         for v:=1 to n do
                          if a[j,v] then begin
                               dec(deg[v]);
                               if deg[v]=0 then inc(count[id[v]]);
                          end;
                         anss:=anss+1;
                      end;
                    end;
                    if cv=0 then break;
                    st:=st+1;
                    anss:=anss+1;
                    if st=4 then st:=1;
                 until cv=0;
                 if anss<ans then ans:=anss;
             end;
            writeln(g,ans);
        closefile;
end.

var
 f,delt:array[1..1000,1..1000]of longint;
 c,kol,t,us,s:array[0..1000000]of longint;
 g,h,x,ot,o,st,n,m,i,j,k,z,otv:longint;
begin
 readln(n);
 for i:=1 to n do read(c[i]);
 for i:=1 to n do
 begin
  read(k);
  for j:=1 to k do
  begin
   read(x);
   f[x,i]:=1;
   inc(kol[i]);
  end;
 end;
 delt[1,2]:=1;
 delt[2,1]:=2;
 delt[1,3]:=2;
 delt[3,1]:=1;
 delt[2,3]:=1;
 delt[3,2]:=2;
 otv:=maxlongint;
 c[0]:=1;
 for o:=1 to 3 do
 begin
  ot:=0;
  x:=o;
  for i:=1 to n do
  begin
   t[i]:=0;
   us[i]:=0;
  end;
  for h:=1 to n do
  begin
   g:=0;
   for j:=1 to n do
    if ((delt[x,c[j]]<delt[x,c[g]])or(g=0))and(kol[j]=t[j])and(us[j]=0)then g:=j;
   ot:=ot+delt[x,c[g]];
   us[g]:=1;
   for j:=1 to n do
    if f[g,j]=1 then inc(t[j]);
   x:=c[g];
   inc(ot);
  end;
  if ot<otv then otv:=ot;
 end;
 writeln(otv);
end.

uses math;
const maxn=300;
var f1,f2:text;
T:array[1..maxn] of longint;
A:array[1..maxn,0..maxn] of longint;
D,D2:array[1..maxn] of longint;
Q:array[1..maxn] of longint;
i,n,j,res,u:longint;

Procedure process;
var g,i,x,sum,sl:longint;
fr,re:longint;
found:boolean;
begin
        res:=high(longint);
        For g:=1 to 3 do
        begin
          sum:=0;
          x:=g;
          D:=D2;
          sl:=n;
          Repeat
            repeat
            found:=false;
            for i:=1 to n do
            begin
              if (D[i]=0) then
              Begin
                if T[i]=x then
                Begin
                  For j:=1 to A[i,0] do
                    Dec(D[A[i,j]]);
                  D[i]:=-1;
                  dec(sl);
                  found:=true;
                End;
              End;
            end;
            until found=false;
            if sl=0 then break;
            inc(sum);
            x:=x mod 3+1;
          Until sl=0;
          res:=min(res,sum);
        end;
        writeln(F2,res+n);
end;

begin
        assign(f1,'');reset(f1);
        assign(f2,'');rewrite(f2);
        readln(f1,n);
        For i:=1 to n do read(f1,T[i]);
        for i:=1 to n do
        Begin
          read(f1,D[i]);
          for j:=1 to D[i] do
          Begin
            read(F1,u);
            inc(A[u,0]);
            A[u,A[u,0]]:=i;
          End;
        End;
        D2:=D;
        Process;
        close(f1);
        close(F2);
end.

uses math;
const
    tfi='';//213a.inp';
    tfo='';//213a.out';

var
    fi,fo:text;
    n:longint;
    a:array[0..200,0..200] of boolean;
    free:array[0..200] of boolean;
    r,c,k:array[0..200] of longint;

procedure nhap;
    var i,j,u:longint;
    begin
        read(fi,n);
        for i:=1 to n do read(fi,c[i]);
        for i:=1 to n do
            begin
                read(fi,k[i]);
                for j:=1 to k[i] do
                    begin
                        read(fi,u);
                        a[u,i]:=true;
                    end;
            end;
    end;

procedure xuli;
    var i,j,t,tg,res,kq,cnt:longint;
    ok:boolean;
    begin
        kq:=1000000000;
        for t:=1 to 3 do
        begin
            tg:=t;
            res:=n;
            cnt:=0;
            for i:=1 to n do
                begin
                    r[i]:=k[i];
                    free[i]:=false;
                end;
            while cnt<n do
                begin
                    ok:=false;
                    for i:=1 to n do
                        if (r[i]=0) and ( c[i]=tg) and( not free[i]) then
                            begin
                                ok:=true;
                                free[i]:=true;
                                inc(cnt);
                                for j:=1 to n do
                                    if a[i,j] then dec(r[j]);
                            end;
                    if cnt=n then break;
                    if not ok then
                        begin
                            tg:=(tg mod 3)+1;
                            res:=res+1;
                        end;
                end;
            kq:=min(kq,res);
        end;
        writeln(fo,kq);
    end;

begin
    assign(fi,tfi);
    assign(fo,tfo);
    reset(fi);
    rewrite(fo);
    nhap;
    xuli;
    close(fo);
end.

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  comp, ans, count, n, i, j, c1, answer: integer;
  a: array[1..1000, 1..1000] of integer;
  c, top: array[1..1000] of integer;
  used: array[1..1000] of boolean;
  f, f1: boolean;

procedure start(v: integer);
begin
  comp := v;
  ans := 0;
  count := 0;
  while count < n do
  begin
    f1 := true;
    while f1 do
    begin
      f1 := false;
      for i := 1 to n do
      begin
        if (comp = c[i]) and (not used[i]) then
        begin
          f := false;
          for j := 1 to top[i] do
          begin
            if not used[a[i, j]] then
              f := true;
          end;
          if not f then
          begin
            used[i] := true;
            inc(ans);
            inc(count);
            f1 := true;
          end;
        end;
      end;
    end;
    comp := (comp + 1) mod 3;
    inc(ans);
  end;
  dec(ans);
end;

begin
  //reset(input, 'input.txt'); rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
  begin
    read(c[i]);
    dec(c[i]);
  end;
  for i := 1 to n do
  begin
    read(top[i]);
    for j := 1 to top[i] do
      read(a[i, j]);
  end;
  answer := 1000000000;
  for c1 := 0 to 2 do
  begin
    fillchar(used, sizeof(used), false);
    start(c1);
    if answer > ans then
      answer := ans;
  end;
  writeln(answer);
end.

{$R+,Q+,I+}
{$apptype console}
Uses SysUtils;
Var
   a,a1:Array[1..200,1..200] of Boolean;
   c,c1:Array[1..3,1..200] of Boolean;
   b,b1:Array[1..200] of Integer;
   l:Array[1..200] of Boolean;
   n,i,r,k,j,min,s,t,f,i1,j1:Integer;
Begin
   Read(n);
   For i:=1 To n Do Begin
      Read(r);
      c[r,i]:=true;
   End;
   For i:=1 To n Do Begin
      Read(k);
      b[i]:=k;
      For j:=1 To k Do Begin
         Read(r);
         a[i,r]:=true;
      End;
   End;
   min:=High(min);
   For i:=1 To 3 Do Begin
      t:=0;
      s:=i;
      For i1:=1 To n Do
         For j1:=1 To n Do a1[i1,j1]:=a[i1,j1];
      FOr i1:=1 To n Do l[i1]:=false;
      For i1:=1 To n Do b1[i1]:=b[i1];
      For i1:=1 To 3 Do
         For j1:=1 To n Do c1[i1,j1]:=c[i1,j1];
      While True Do Begin
         For j1:=1 To n Do
         For j:=1 To n Do
            If (b1[j]=0) and (c1[s,j]=true) and (not(l[j])) Then Begin
               t:=t+1;
               l[j]:=true;
               For r:=1 To n Do
                  If a1[r,j]=true Then Begin
                     b1[r]:=b1[r]-1;
                     a1[r,j]:=false;
                  End;
            End;
         f:=0;
         For j:=1 To n Do
            If not (l[j]) Then Begin
               f:=1;
               Break;
            End;
         If f=0 Then Break;
         t:=t+1;
         If t>min Then Break;
         s:=s mod 3+1;
      End;
      If t<min Then min:=t;
   End;
   Write(min);
End.

{$APPTYPE CONSOLE}
{$M 99777216}
{$R-,Q-,O+,S+,H+}
uses
  Math,SysUtils;
var
  cnt, cnt2, num : array [1..200] of LongInt;
  a : array [1..200, 1..200] of longint;
  Ans, i, n, j : longint;
  used : array [1..200] of boolean;
procedure swap(var a, b : longint);
var
  c : LongInt;
begin
  c := a;
  a := b;
  b := c;
end;
procedure del(v, cur : longint; var cans : longint);
var
  j, k : longint;
begin
  used[v] := true;
  Inc(cans);
  for j := 1 to n do
    for k := 1 to cnt[j] do
      if a[j, k] = v then
        begin
          swap(a[j, k], a[j, cnt[j]]);
          dec(cnt[j]);
          break;
        end;
  for j := 1 to n do
    if not used[j] and (cnt[j] = 0) and (num[j] = cur) then
      del(j, cur, cans);
end;
procedure game(cur : longint);
var
  cans, i : longint;
  ok : boolean;
begin
  cans := 0;
  while true  do
    begin
      for i := 1 to n do
        if (cnt[i] = 0) and (cur = num[i]) and not used[i] then
          del(i, cur, cans);
      ok := True;
      for i := 1 to n do
        if not used[i] then
          ok := false;
      if ok then
        Break;
      Inc(cur);
      if cur > 3 then
        cur := 1;
      Inc(cans);
    end;
  if ans > cans then
    ans := cans;
end;
begin
//  reset(input, 'input.txt');
//  rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
    read(num[i]);
  for i := 1 to n do
    begin
      read(cnt[i]);
      for j := 1 to cnt[i] do
        read(a[i, j]);
    end;
  ans := maxlongint;
  cnt2 := cnt;
  for i := 1 to 3 do
    begin
      FillChar(used, sizeof(used), 0);
      game(i);
      cnt := cnt2;
    end;
  Writeln(ans);
end.

program Project1;

{$APPTYPE CONSOLE}

uses
  Math,
  SysUtils;

var
  g : array [0..200, 0..200] of boolean;
  now : array [0..200] of boolean;
  k, m, how, t : array[0..200] of longint;
  table : array [1..3, 0..200] of longint;
  ok, cur, n, i, j, x, ans : longint;

procedure go(i : longint);
var
  flag : boolean;
  j, l : longint;
begin
  flag := true;
  while flag do
  begin
    flag := false;
    for j := 1 to how[i] do
    begin
      if (k[table[i][j]] = 0) and not(now[table[i][j]]) then
      begin
        flag := true;
        inc(ok);
        inc(cur);
        now[table[i][j]] := true;
        for l := 1 to n do
        begin
          if g[l][table[i][j]] then
            dec(k[l]);
        end;
      end;
    end;
  end;

  if ok = n then
    exit;

  inc(cur);
  go((i mod 3) + 1);

end;

begin
  {$ifndef online_judge}
	assign(input,'c.in'); reset(input);
	assign(output,'c.out'); rewrite(output);
	{$endif}

	readln(n);

  for i := 1 to n do
    read(t[i]);

  for i := 1 to 3 do
    for j := 1 to n do
    begin
      if t[j] = i then
      begin
        inc(how[i]);
        table[i][how[i]] := j;
      end;
    end;

  for i := 1 to n do
  begin
    read(m[i]);
    k[i] := m[i];
    for j := 1 to m[i] do
    begin
      read(x);
      g[i][x] := true;
    end;
  end;

  for i := 1 to n do
  begin
    k[i] := m[i];
    now[i] := false;
  end;
  ok := 0;

  cur := 0;
  go(1);

  ans := cur;

  for i := 1 to n do
  begin
    k[i] := m[i];
    now[i] := false;
  end;
  ok := 0;
  cur := 0;
  go(2);
  if cur < ans then
    ans := cur;

  for i := 1 to n do
  begin
    k[i] := m[i];
    now[i] := false;
  end;
  ok := 0;
  cur := 0;
  go(3);
  if cur < ans then
    ans := cur;

  writeln(ans);
	{$ifndef online_judge}
	close(input); close(output);
	{$endif}
end.

{$R-,S-,Q-,I-,O+}
{$M 16000000}

{$APPTYPE CONSOLE}

uses Math;
const
maxn = 222;
inf = round(1e9);
var
n,i,j,x,k : integer;
ans,all,cur : longint;
c : array [1..3,0..maxn] of integer;
cc : array [1..maxn] of integer;
need : array [1..maxn,0..maxn] of integer;
f : array [1..maxn] of boolean;

function can (x : integer) : boolean;
var
i : integer;
begin
 for i:=1 to need [x,0] do
 if not f [need [x,i]] then
 begin
  can:=false;
  exit;
 end;
 can:=true;
end;

procedure rec (x : integer);
var
i : integer;
begin
 for i:=1 to c [x,0] do
 if can (c [x,i]) and not f [c [x,i]] then
 begin
  inc (cur);
  inc (all);
  f [c [x,i]]:=true;
  rec (x);
 end;
 if all=n then exit;
 case x of
 1 : begin inc (cur); rec (2); end;
 2 : begin inc (cur); rec (3); end;
 3 : begin inc (cur); rec (1); end;
 end;
end;

begin
 //reset (input,'input.txt');
 //rewrite (output,'output.txt');
 fillchar (c,sizeof(c),0);
 readln (n);
 for i:=1 to n do
 begin
  read (x);
  inc (c [x,0]);
  c [x,c [x,0]]:=i;
  cc [i]:=x;
 end;
 readln;
 for i:=1 to n do
 begin
  read (k);
  need [i,0]:=k;
  for j:=1 to k do
  begin
   read (x);
   need [i,j]:=x;
  end;
  readln;
 end;
 ans:=maxlongint;
 for i:=1 to 3 do
 begin
  fillchar (f,sizeof(f),false);
  all:=0;
  cur:=0;
  rec (i);
  if cur<ans then ans:=cur;
 end;
 writeln (ans);
end.

var i,n,m,j,q,x,k,e,ans,ans1,kr:longint;
    f:boolean;
    s:string;
    a,was,bad:array [0..1000] of longint;
    c:array [0..4,0..4] of longint;
    b,r:array [0..300,0..300] of longint;

begin           {
assign (input,'input.txt');
assign (output,'output.txt');
reset (input);
rewrite (output); }
readln (n);
for i:=1 to n do
  begin
    read(a[i]);
  end;
for i:=1 to n do
  begin
    read (b[i,0]);
    for j:=1 to b[i,0] do
      begin
        read (b[i,j]);
        r[b[i,j],0]:=r[b[i,j],0]+1;
        r[b[i,j],r[b[i,j],0]]:=i;
      end;
  end;
for i:=1 to 3 do c[0,i]:=0;
for i:=0 to 3 do c[i,i]:=0;
c[1,2]:=1;
c[3,1]:=1;
c[2,3]:=1;
c[2,1]:=2;
c[3,2]:=2;
c[1,3]:=2;
ans:=maxlongint;
for q:=1 to 3 do
  begin
    for i:=1 to n do was[i]:=0;
    for i:=1 to n do bad[i]:=b[i,0];
    e:=q;
    kr:=0;
    ans1:=0;
    while kr<n do
      begin
        f:=true;
        while f do
          begin
            f:=false;
            for i:=1 to n do
              if (was[i]=0) and (a[i]=e) and (bad[i]=0) then
                begin
                  f:=true;
                  was[i]:=1;
                  inc (kr);
                  inc (ans1);
                  for j:=1 to r[i,0] do
                    dec(bad[r[i,j]]);
                end;
          end;
        if kr=n then break;
        e:=e mod 3+1;
        inc (ans1);
      end;
    if ans1<ans then ans:=ans1;
  end;
write (ans);
end.
end.

uses math;
Var x,n,i,j,ans:longint;
    e,left,c:array[0..222]of longint;
    a:array[0..222,0..222]of boolean;
    used:array[0..222]of boolean;
 procedure go(tmp:longint);
   var res,cnt,i,j:longint;
       ok:boolean;
     begin
       res:=n;
       cnt:=0;
       for i:=1 to n do
        begin
         left[i]:=e[i];
         used[i]:=false;
        end;
       while cnt<n do
         begin
           ok:=false;
           for i:=1 to n do
             if left[i]=0 then if c[i]=tmp then if not used[i] then
               begin
                 ok:=true;
                 used[i]:=true;
                 inc(cnt);
                 for j:=1 to n do
                   if a[i,j] then dec(left[j]);
               end;
            if cnt=n then break;
           if not ok then
             begin
               tmp:=tmp+1;
               res:=res+1;
               if tmp=4 then tmp:=1;
             end;
         end;
       ans:=min(ans,res);
     end;
  begin
    read(n);
    for i:=1 to n do
      read(c[i]);
    for i:=1 to n do
      begin
        read(e[i]);
        for j:=1 to e[i] do
         begin
           read(x);
           a[x,i]:=true;

         end;
      end;
    ans:=maxlongint;
    go(1);
    go(2);
    go(3);
    writeln(ans);
  end.

uses math;
const
 next:array[1..3] of longint=(2,3,1);
type
 arr1=array[1..500] of longint;
 arr2=array[1..3,0..500] of longint;
var
 i,j,k,t,n,ans:longint;
 d:arr1;
 a:arr2;
 b:array[1..500] of longint;
 map:array[1..500,0..500] of longint;
function work(x:longint):longint;
 var
  i,j,k,tmp,now,rem:longint;
  d1:arr1;
  a1:arr2;
 begin
  now:=x;a1:=a;d1:=d;rem:=n;tmp:=0;
  while true do begin
   i:=1;
   while i<=a1[now,0] do begin
    k:=a1[now,i];
    for j:=1 to map[k,0] do begin
     dec(d1[map[k,j]]);
     if d1[map[k,j]]=0 then begin
      inc(a1[b[map[k,j]],0]);a1[b[map[k,j]],a1[b[map[k,j]],0]]:=map[k,j];
     end;
    end;
    inc(i);
   end;
   dec(rem,a1[now,0]);inc(tmp,a1[now,0]);a1[now,0]:=0;
   if rem>0 then inc(tmp) else break;
   now:=next[now];
  end;
  exit(tmp);
 end;
begin
 //assign(input,'a.in');reset(input);
 fillchar(map,sizeof(map),0);fillchar(a,sizeof(a),0);fillchar(d,sizeof(d),0);
 readln(n);
 for i:=1 to n do read(b[i]);readln;
 for i:=1 to n do begin
  read(d[i]);
  if d[i]=0 then begin
   inc(a[b[i],0]);a[b[i],a[b[i],0]]:=i;
  end;
  for j:=1 to d[i] do begin
   read(t);inc(map[t,0]);map[t,map[t,0]]:=i;
  end;
  readln;
 end;
 ans:=maxlongint;
 for i:=1 to 3 do
  if a[i,0]>0 then ans:=min(ans,work(i));
 writeln(ans);
end.

var l,ans,v,min,q,start,w,n,i,j:longint;
    c:array[1..200] of longint;
    d:array[1..200] of boolean;
    b,k:array[1..200] of longint;
    a:array[1..200,1..200] of longint;
 begin
  read(n);
  min:=maxlongint;
  for i:=1 to n do
   read(c[i]);
  for i:=1 to n do
   begin
    read(k[i]);
    for j:=1 to k[i] do
     read(a[i,j]);
    b[i]:=k[i];
   end;
  for start:=1 to 3 do
   begin
    l:=0;
    ans:=-1;
    v:=start;
    for i:=1 to n do
     begin
      d[i]:=false;
      b[i]:=k[i];
     end;
    while l<n do
     begin
      ans:=ans+1;
      for w:=1 to 5 do
      for i:=1 to n do
       if (c[i]=v)and(b[i]=0)and not(d[i]) then
        begin
         inc(l);
         d[i]:=true;
         ans:=ans+1;
         if l=n then break;
         for j:=1 to n do
          for q:=1 to k[j] do
           if a[j,q]=i then dec(b[j]);
        end;
       v:=(v mod 3)+1;
     end;
    if ans<min then min:=ans;
   end;
  writeln(min);
 end.

uses math;
const
        tfi      =      '';
        tfo      =      '';
        nmax     =      201;
var
        fi,fo:text;
        n,m,dem,res:longint;
        c,k,deg,next,head,ke:array[0..nmax] of longint;
        g:Array[0..nmax,0..nmax] of boolean;
procedure add(u,v:longint);
var j:longint;
begin
        inc(m);
        next[m]:=head[u];head[u]:=m;ke[m]:=v;
end;
procedure nhap;
var i,j,u,v:longint;
begin
        read(fi,n);
        for i:=1 to n do read(fi,c[i]);
        for i:=1 to n do
          begin
            read(fi,k[i]);
            for j:=1 to k[i] do
              begin
                read(fi,u);
                g[u][i]:=true;
              end;
          end;
end;
function check(vt:longint):longint;
var i,j,u,v:longint;
begin
        m:=0;
        for i:=1 to 3 do head[i]:=0;
        for i:=1 to n do
          begin
            deg[i]:=k[i];
            if deg[i]=0 then add(c[i],i);
          end;
        dem:=0;
        repeat
          i:=head[vt];
          head[vt]:=0;
          while i<>0 do
            begin
              v:=ke[i];
              for j:=1 to n do if g[v][j] then
               begin
                 dec(deg[j]);
                 if deg[j]=0 then add(c[j],j);
               end;
              i:=next[i];
            end;
          if (head[1]=0)and(head[2]=0)and(head[3]=0) then exit(dem);
          if head[vt]=0 then
            begin
              inc(dem);
              vt:=vt+1;
              if vt=4 then vt:=1;
            end;
        until false;
end;
procedure xuly;
var i,j,u,v:longint;
begin
        res:=maxlongint;
        for i:=1 to 3 do
          res:=min(res,check(i));
        writeln(fo,res+n);
end;
begin
        assign(fi,tfi);reset(fi);
        assign(fo,tfo);rewrite(fo);
          nhap;
          xuly;
        close(fi);
        close(fo);
end.

VAR
  a, b, c, i, j, j1, N, No, t, Kol, flag, time: LONGINT;
  Mas, M, k: ARRAY[0..200000] OF LONGINT;
  Massiv: ARRAY[0..200,0..200] OF LONGINT;
BEGIN
  READLN(N);
  FOR i := 1 TO N DO
    READ(Mas[i]);
  FOR j := 1 TO N DO
    BEGIN
      READ(k[j]);
      FOR i := 1 TO k[j] DO
        READ(Massiv[j,i]);
      READLN;
    END;
  time := 20000000;
  FOR i := 1 TO 3 DO
    BEGIN
      Kol := 0;
      No := i;
      t := 0;
      FOR j := 1 TO N DO
        M[j] := Mas[j];
      WHILE Kol<N
      DO
        BEGIN
          flag := 0;
          FOR j := 1 TO N DO
            IF (M[j]=No)
            THEN
              BEGIN
                a := 0;
                FOR j1 := 1 TO k[j] DO
                  IF M[Massiv[j,j1]]<>-1
                  THEN
                    a := 1;
                IF (a=0)
                THEN
                BEGIN
                flag := 1;
                M[j] := -1;
                Kol := Kol+1;
                END;
              END;
          IF (flag<>1)
          THEN
            BEGIN
              No := (No MOD 3)+1;
              t := t+1;
            END;
        END;
      IF t<time
      THEN
        time := t;
    END;
  time := time+N;
  WRITELN(time);
END.

program Project2;

{$APPTYPE CONSOLE}

var n,m,i,j,k,l,s,w,t,c,max,xx:integer;
    a: array [1..200,1..200] of boolean;
    stack,x: array [1..200] of integer;
    used,used2: array [1..200] of boolean;
procedure prop(xx:integer);
begin

      for l:= 1 to n do begin
      for i:= 1 to n do
      begin
      k:=0;
      for j:= 1 to n do if ((a[i,j]) and (not used2[j])) then k:=1;
      if ((k=0) and (not used[i])) then used[i]:=true;
      end;

      for i:= 1 to n do
       if x[i]=xx then if ((used[i]) and (used2[i]=false)) then
         used2[i]:=true;
                        end;
      w:=0;
      for i:= 1 to n do if not used2[i] then w:=1;
      if w=1 then begin m:=m+1; prop(xx mod 3 +1); end;
end;

begin
read(n);
for i:= 1 to n do read(x[i]);
for i:= 1 to n do
 begin
 read(t);
 for j:= 1 to t do begin read(c); a[i,c]:=true; end;
 end;

max:=999999;
for xx:= 1 to 3 do
 begin
 for i:= 1 to n do used[i]:=false;
 for i:= 1 to n do used2[i]:=false;
 m:=n;
 prop(xx);
 if m<max then max:=m;
 end;
write(m);
read(i);
end.

program Project2;

{$APPTYPE CONSOLE}

var n,i,j,k,l,m,max,s,k1,k2,q,t,xxx:integer;
    used,used2: array [1..200] of boolean;
    x: array [1..200] of integer;
    a: array [1..200,1..200] of boolean;

procedure proc(y:integer);
var s,q,i,j:integer;
 begin
 q:=1;
 while q=1 do
  begin
  q:=0;
  for i:= 1 to n do
  if not used[i] then
   begin
   s:=0;
   for j:= 1 to n do if ((a[i,j]) and (not used{}[j])) then s:=1;
   if s=0 then used[i]:=true;
   end;

  for i:= 1 to n do
   if x[i]=y then if ((used[i]) and (not used2[i])) then begin used2[i]:=true; q:=1; end;
  end;
 q:=0;
 for i:= 1 to n do if not used2[i] then q:=1;
 if q=1 then begin m:=m+1; proc(y mod 3 +1 );end;
 end;

begin
read(n);
for i:= 1 to n do read(x[i]);
for i:= 1 to n do
 begin
 read(t);
 for j:= 1 to t do begin read(m); a[i,m]:=true; end;
 end;
max:=999999;
for xxx:= 1 to 3 do
 begin
 for i:= 1 to n do used[i]:=false;
 for i:= 1 to n do used2[i]:=false;
 m:=n;
 proc(xxx);
 if m<max then max:=m;
 end;
write(max);
read(i);
end.

{$APPTYPE CONSOLE}

uses
  SysUtils;
const dist:array[1..3,1..3] of integer=((0,1,2),(2,0,1),(1,2,0));
var
 used:Array[1..1000] of integer;
 k,c:array[1..1000] of integer;
 mas:array[1..500,1..500 ] of integer;
 v,timer,n,cand:int64;
 i,j,vertex:integer;
function check(v:integer):boolean;
var bool:boolean;
  i : integer;
begin
 bool:=true;
 for i:=1 to k[v] do
  if used[mas[v,i]]<2 then bool:=false;
 check:=bool;
end;
begin
 readln(n);
 for i:=1 to n do
  read(c[i]);
 for i:=1 to n do
 begin
  read(k[i]);
  if k[i] = 0 then v:=i;
  for j :=  1 to k[i] do
   read(mas[i,j]);
  readln;
 end;
 fillchar(used,sizeof(used),0);
 used[v]:=2;
 timer := 0;
 for vertex:=1 to n-1 do
 begin
  cand := -1;
  for i:=1 to n do
  begin
   if (used[i]=0) and (check(i)) then
    used[i]:=1;
   if (used[i] = 1) then
    if (cand = -1) or (dist[c[v],c[i]]<dist[c[v],c[cand]]) then
     cand:=i;
  end;
  inc(timer,dist[c[v],c[cand]]);
  v:=cand;
  used[v]:=2;
 end;
 writeln(timer + n);
end.

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  used: array[1..1000] of boolean;
  a: array[1..1000, 1..1000] of integer;
  n, i, j, x, ans: integer;
  top, c: array[1..1000] of integer;

function dfs(v: integer): integer;
var
  i: integer;
begin
  result := 1;
  used[v] := true;
  for i := 1 to n do
  begin
    if not used[i] then
      result := result + a[v, i] + dfs(i);
  end;
end;

begin
  //reset(input, 'input.txt'); rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
    read(c[i]);
  for i := 1 to n do
  begin
    readln(top[i]);
    for j := 1 to top[i] do
    begin
      read(x);
      if c[i] = 1 then
      begin
        if c[x] = 1 then
          a[x, i] := 0;
        if c[x] = 2 then
          a[x, i] := 1;
        if c[x] = 3 then
          a[x, i] := 2;
      end;
      if c[i] = 2 then
      begin
        if c[x] = 1 then
          a[x, i] := 2;
        if c[x] = 2 then
          a[x, i] := 0;
        if c[x] = 3 then
          a[x, i] := 1;
      end;
      if c[i] = 3 then
      begin
        if c[x] = 1 then
          a[x, i] := 1;
        if c[x] = 2 then
          a[x, i] := 2;
        if c[x] = 3 then
          a[x, i] := 0;
      end;
    end;
  end;
  ans := 0;
  for i := 1 to n do
    if top[i] = 0 then
      ans := ans + (dfs(i));
  writeln(ans);
end.

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  used: array[1..200] of boolean;
  a: array[0..200, 0..200] of integer;
  n, i, j, x, ans, d: integer;
  top, c: array[1..200] of integer;

function dfs(v: integer): integer;
var
  i: integer;
begin
  result := 1;
  used[v] := true;
  for i := 1 to n do
  begin
    if not used[i] then
      result := result + a[c[i], v] + dfs(i);
  end;
end;

begin
  //reset(input, 'input.txt'); rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
    read(c[i]);
  for i := 1 to n do
  begin
    read(top[i]);
    for j := 1 to top[i] do
    begin
      read(x);
      if c[i] = 1 then
      begin
        if c[x] = 1 then
          a[x, i] := 0;
        if c[x] = 2 then
          a[x, i] := 1;
        if c[x] = 3 then
          a[x, i] := 2;
      end;
      if c[i] = 2 then
      begin
        if c[x] = 1 then
          a[x, i] := 2;
        if c[x] = 2 then
          a[x, i] := 0;
        if c[x] = 3 then
          a[x, i] := 1;
      end;
      if c[i] = 3 then
      begin
        if c[x] = 1 then
          a[x, i] := 1;
        if c[x] = 2 then
          a[x, i] := 2;
        if c[x] = 3 then
          a[x, i] := 0;
      end;
    end;
  end;
  ans := 0;
  d := 0;
  for i := 1 to n do
    if top[i] = 0 then
    begin
      ans := ans + (dfs(i)) + a[i, d];
      d := i;
    end;
  writeln(ans);
end.

program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  used: array[1..200] of boolean;
  a: array[0..200, 0..200] of integer;
  n, i, j, x, ans, d: integer;
  top, c: array[1..200] of integer;

function dfs(v: integer): integer;
var
  i: integer;
begin
  result := 1;
  used[v] := true;
  for i := 1 to n do
  begin
    if not used[i] then
      result := result + a[c[i], v] + dfs(i);
  end;
end;

begin
  //reset(input, 'input.txt'); rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
    read(c[i]);
  for i := 1 to n do
  begin
    readln(top[i]);
    for j := 1 to top[i] do
    begin
      read(x);
      if c[i] = 1 then
      begin
        if c[x] = 1 then
          a[x, i] := 0;
        if c[x] = 2 then
          a[x, i] := 1;
        if c[x] = 3 then
          a[x, i] := 2;
      end;
      if c[i] = 2 then
      begin
        if c[x] = 1 then
          a[x, i] := 2;
        if c[x] = 2 then
          a[x, i] := 0;
        if c[x] = 3 then
          a[x, i] := 1;
      end;
      if c[i] = 3 then
      begin
        if c[x] = 1 then
          a[x, i] := 1;
        if c[x] = 2 then
          a[x, i] := 2;
        if c[x] = 3 then
          a[x, i] := 0;
      end;
    end;
  end;
  ans := 0;
  d := 0;
  for i := 1 to n do
    if top[i] = 0 then
    begin
      ans := ans + (dfs(i)) + a[i, d];
      d := i;
    end;
  writeln(ans);
end.

{$APPTYPE CONSOLE}
{$M 99777216}
{$R-,Q-,O+,S+,H+}
uses
  Math,SysUtils;
var
  cnt, cnt2, num : array [1..200] of LongInt;
  a : array [1..200, 1..200] of longint;
  Ans, i, n, j : longint;
procedure swap(var a, b : longint);
var
  c : LongInt;
begin
  c := a;
  a := b;
  b := c;
end;
procedure game(cur : longint);
var
  cans, i, j, k : longint;
  ok : boolean;
begin
  cans := 0;
  ok := false;
  while not ok do
    begin
      for i := 1 to n do
        if (cnt[i] = 0) and (cur = num[i]) then
          begin
            Inc(cans);
            for j := 1 to n do
              for k := 1 to cnt[j] do
                if a[j, k] = i then
                  begin
                    swap(a[j, k], a[j, cnt[j]]);
                    dec(cnt[j]);
                    break;
                  end;
          end;
      ok := True;
      for i := 1 to n do
        if cnt[i] <> 0 then
          ok := false;
      Inc(cur);
      if cur > 3 then
        cur := 1;
      Inc(cans);
    end;
  if ans > cans then
    ans := cans;
end;
begin
//  reset(input, 'input.txt');
//  rewrite(output, 'output.txt');
  readln(n);
  for i := 1 to n do
    read(num[i]);
  for i := 1 to n do
    begin
      read(cnt[i]);
      for j := 1 to cnt[i] do
        read(a[i, j]);
    end;
  ans := maxlongint;
  cnt2 := cnt;
  for i := 1 to 3 do
    begin
      game(i);
      cnt := cnt2;
    end;
  Writeln(ans);
end.

var a,count:array[1..200]of longint;
    map:array[1..200,1..200]of boolean;
    used:array[1..200]of boolean;
    n,i,j,k,x,where,ans,finish:longint;
    flag:boolean;
begin
  readln(n);
  for i:=1 to n do
    read(a[i]);
  fillchar(map,sizeof(map),false);
  for i:=1 to n do
    begin
      read(k);
      count[i]:=k;
      for j:=1 to k do
        begin
          read(x);
          map[x,i]:=true;
        end;
    end;
  fillchar((used),sizeof(used),false);
  where:=0;
  for i:=1 to n do
    if count[i]=0 then begin where:=a[i];break;end;
  finish:=0;
  ans:=n;
  while finish<n do
    begin
      while true do
        begin
          flag:=false;
          for i:=1 to n do
            if(not used[i])and(a[i]=where)and(count[i]=0)then
              begin
                inc(finish);
                flag:=true;
                used[i]:=true;
                for j:=1 to n do
                  if map[i,j]=true then begin map[i,j]:=false;dec(count[j]);end;
              end;
          if not flag then break;
        end;
      inc(where);
      inc(ans);
      if where=4 then where:=1;
    end;
  writeln(ans-1);
end.

uses math;
var
 n1,n2,n3,n4,c2,l,x,y,ans,n,j,k,nom,z,m:longint;
 i:longint;
 d,dp:array[1..200,1..200] of longint;
 f:array[1..200] of boolean;
  a,b:array[0..100003] of longint;
 t:int64;
 st,ss,s:ansistring;
 r,a1,b1:real;

begin
   read(n);
   for i:=1 to n do
    begin
     read(x);
     inc(a[x]);
     dp[x,a[x]]:=i;
    end;
   for i:=1 to n do
    begin
      read(b[i]);
      for j:=1 to b[i] do
       read(d[i,j]);

    end;

   ans:=0;
   k:=0;t:=1;
   while k<>n do
     begin
       repeat
        l:=0;
        for i:=1 to a[t] do
         begin
          nom:=dp[t,i];
          if not f[nom] then
           begin
             x:=0;
             for j:=1 to b[nom] do
              if not f[d[nom,j]] then x:=1;
            if x=0 then begin inc(k);inc(ans);f[nom]:=true;l:=1;end;
           end;
         end;
       until l=0 ;
      inc(t);
      if t=4 then t:=1;
      if ans<>0 then inc(ans);
     end;
   write(ans-1);
end.

VAR
        a,b,i,j,n,m:longint;
        x:array[0..200,0..200]of longint;
        pos,num,ind,d:array[0..200]of longint;
        l,r:longint;
        q:array[0..1000]of longint;
        vis:array[0..200]of boolean;
        temp,ans:longint;

BEGIN
        read(n);
        for i:=1 to n do read(pos[i]);
        for i:=1 to n do begin
                read(a);
                for j:=1 to a do begin
                        read(b);
                        inc(d[b]);
                        inc(num[i]);
                        x[i,num[i]]:=b;
                end;
        end;
        ans:=maxlongint;
        for i:=1 to 3 do begin
                fillchar(vis,sizeof(vis),false);
                for a:=1 to n do ind[a]:=d[a];
                j:=i;m:=n;temp:=0;
                while m>0 do begin
                        l:=0;r:=0;
                        for a:=1 to n do if (pos[a]=j)and(ind[a]<=0)and(not vis[a]) then begin
                                inc(r);
                                q[r]:=a;
                                vis[a]:=true;
                        end;
                        while l<>r do begin
                                inc(l);
                                dec(m);
                                inc(temp);
                                a:=q[l];
                                for b:=1 to num[a] do begin
                                        dec(ind[x[a,b]]);
                                        if (ind[x[a,b]]<=0)and(not vis[x[a,b]])and(pos[x[a,b]]=j) then begin
                                                vis[x[a,b]]:=true;
                                                inc(r);
                                                q[r]:=x[a,b];
                                        end;
                                end;
                        end;
                        if m>0 then begin
                                j:=j mod 3 +1;
                                inc(temp);
                        end;
                end;
                if ans>temp then ans:=temp;
        end;
        writeln(ans);
END.

VAR
        a,b,i,j,n,m:longint;
        x:array[0..200,0..200]of boolean;
        d,ind,q,pos:array[0..200]of longint;
        vis:array[0..200]of boolean;
        ans,temp:int64;
        l,r:longint;

BEGIN
        read(n);
        for i:=1 to n do read(pos[i]);
        for i:=1 to n do begin
                read(a);
                for j:=1 to a do begin
                        read(b);
                        x[i,b]:=true;
                        inc(d[b]);
                end;
        end;
        ans:=maxlongint;
        for i:=1 to 3 do begin
                j:=i;m:=n;
                fillchar(vis,sizeof(vis),false);
                for a:=1 to n do ind[a]:=d[a];
                while m>0 do begin
                        l:=0;r:=0;
                        for a:=1 to n do if (pos[a]=j)and(not vis[a])and(ind[a]<=0)then begin
                                inc(r);
                                q[r]:=a;
                                vis[a]:=true;
                        end;
                        while l<>r do begin
                                inc(l);
                                dec(m);
                                a:=q[l];
                                for b:=1 to n do if (x[a,b]) then begin
                                        dec(ind[b]);
                                        if (not vis[b])and(ind[b]<=0)and(pos[b]=j) then begin
                                                inc(r);
                                                q[r]:=b;
                                                vis[b]:=true;
                                        end;
                                end;
                        end;
                        j:=j mod 3+1;
                        if m>0 then inc(temp);
                end;
                if ans>temp then ans:=temp;
        end;
        writeln(ans+n);
END.

VAR
        a,b,i,j,n,m:longint;
        x:array[0..200,0..200]of longint;
        pos,num,ind,d:array[0..200]of longint;
        l,r:longint;
        q:array[0..1000]of longint;
        vis:array[0..200]of boolean;
        temp,ans:longint;

BEGIN
        read(n);
        for i:=1 to n do read(pos[i]);
        for i:=1 to n do begin
                read(a);
                for j:=1 to a do begin
                        read(b);
                        inc(d[b]);
                        inc(num[i]);
                        x[i,num[i]]:=b;
                end;
        end;
        ans:=maxlongint;
        for i:=1 to 3 do begin
                fillchar(vis,sizeof(vis),false);
                for a:=1 to n do ind[a]:=d[a];
                j:=i;m:=n;temp:=0;
                while m>0 do begin
                        l:=0;r:=0;
                        for a:=1 to n do if (pos[a]=j)and(ind[a]<=0)and(not vis[a]) then begin
                                inc(r);
                                q[r]:=a;
                                vis[a]:=true;
                        end;
                        while l<>r do begin
                                inc(l);
                                dec(m);
                                a:=q[l];
                                for b:=1 to num[a] do begin
                                        dec(ind[x[a,b]]);
                                        if (ind[x[a,b]]<=0)and(not vis[x[a,b]])and(pos[x[a,b]]=j) then begin
                                                vis[x[a,b]]:=true;
                                                inc(r);
                                                q[r]:=x[a,b];
                                        end;
                                end;
                        end;
                        if m>0 then begin
                                j:=j mod 3 +1;
                                inc(temp);
                        end;
                end;
                if ans>temp then ans:=temp;
        end;
        writeln(ans+n);
END.

var n, i, time, j, x, s: Longint;
    k, c: array [1..1000] of Longint;
    l, r: array [1..3] of Longint;
    q: array [1..3, 1..100] of Longint;
    a: array [1..1000, 1..1000] of Boolean;

Begin
    read(n);
    for i := 1 to n do
        read(c[i]);
    for i := 1 to n do begin
        read(k[i]);
        for j := 1 to k[i] do begin
            read(x);
            a[x, i] := true;
        end;
        if k[i] = 0 then begin
            inc(r[c[i]]);
            q[c[i], r[c[i]]] := i;
        end;
    end;
    time := 0;
    i := 1;
    l[1] := 1;
    l[2] := 1;
    l[3] := 1;
    while r[1] - l[1] + r[2] - l[2] + r[3] - l[3] > -3 do begin
        while l[i] <= r[i] do begin
            inc(time);
            for j := 1 to n do
                if a[q[i, l[i]], j] = true then begin
                    dec(k[j]);
                    if k[j] = 0 then begin
                        inc(r[c[j]]);
                        q[c[j], r[c[j]]] := j;
                    end;
                end;
            inc(l[i]);
        end;
        inc(i);
        if i = 4 then
            i := 1;
        if time <> 0 then
            inc(time);
    end;
    write(time - 1);
End.

var was,a:array[1..300] of longint;
    edge:array[1..300,1..300] of longint;
    ans,i,j,n,x,k:longint;

    function min(a,b:longint):longint;
     begin
      if a<b then min:=a else min:=b;
     end;

   function not_empty:boolean;
    var i:longint;
     begin
      for i:=1 to n do if was[i]=1 then exit(true);
      exit(false);
     end;

   function find(p:longint):longint;
    var res:longint;
        i,j:longint;
        fl,fl2:boolean;
     begin
      res:=0;
      for i:=1 to n do was[i]:=1;
      while not_empty do
       begin
        fl:=false;
        for i:=1 to n do
         if (a[i]=p) and (was[i]=1) then
          begin
           fl2:=true;
           for j:=1 to n do if edge[i][j]=1 then begin fl2:=false; break; end;
           if fl2 then
            begin
             fl:=true;
             inc(res);
             for j:=1 to n do edge[j][i]:=0;
             was[i]:=0;
            end;
           end;
         if not fl then begin inc(res); p:=(p+1) mod 3; end;
       end;
      exit(res);
    end;

     begin
      readln(n);
      for i:=1 to n do
       begin
        read(x);
        a[i]:=x-1;
       end;
      for i:=1 to n do
       begin
        read(k);
        while k<>0 do
         begin
          read(x);
          dec(k);
          edge[i][x]:=1;
         end;
       end;
     ans:=find(0);
     ans:=min(ans,find(1));
     ans:=min(ans,find(2));
    writeln(ans);
   end.

var a:array[0..9]of longint;
    n,i,k,s:longint;
begin
 readln(n);
 for i:=1 to n do
 begin
  read(k);
  inc(a[k]);
  s:=s+k;
 end;
 if a[0]=0 then begin writeln(-1);halt(0);end;
 if s mod 3=1 then
 begin
  if a[1]>0 then begin dec(a[1]);s:=s-1;end else
  if a[4]>0 then begin dec(a[4]);s:=s-4;end else
  if a[7]>0 then begin dec(a[7]);s:=s-7;end else
  if (a[2]>1)and(a[2]>1) then begin dec(a[2]);dec(a[2]);s:=s-4;end else
  if (a[2]>0)and(a[5]>0) then begin dec(a[2]);dec(a[5]);s:=s-7;end else
  if (a[5]>1)and(a[5]>1) then begin dec(a[5]);dec(a[5]);s:=s-10;end else
  if (a[2]>0)and(a[8]>0) then begin dec(a[2]);dec(a[8]);s:=s-10;end else
  if (a[5]>0)and(a[8]>0) then begin dec(a[5]);dec(a[8]);s:=s-13;end else
  if (a[8]>1)and(a[8]>1) then begin dec(a[8]);dec(a[8]);s:=s-16;end else
  begin writeln(0);halt(0);end;
 end;
 if s mod 3=2 then
 begin
  if a[2]>0 then begin dec(a[2]);s:=s-2;end else
  if a[5]>0 then begin dec(a[5]);s:=s-5;end else
  if a[8]>0 then begin dec(a[8]);s:=s-8;end else
  if (a[1]>1)and(a[1]>1) then begin dec(a[1]);dec(a[1]);s:=s-2;end else
  if (a[1]>0)and(a[4]>0) then begin dec(a[1]);dec(a[4]);s:=s-5;end else
  if (a[4]>1)and(a[4]>1) then begin dec(a[4]);dec(a[4]);s:=s-8;end else
  if (a[1]>0)and(a[7]>0) then begin dec(a[1]);dec(a[7]);s:=s-8;end else
  if (a[4]>0)and(a[7]>0) then begin dec(a[4]);dec(a[7]);s:=s-11;end else
  if (a[7]>1)and(a[7]>1) then begin dec(a[7]);dec(a[7]);s:=s-14;end else
  begin writeln(0);halt(0);end;
 end;
 if s=0 then begin writeln('0');halt(0);end;
 for i:=1 to a[9] do
  write('9');
 for i:=1 to a[8] do
  write('8');
 for i:=1 to a[7] do
  write('7');
 for i:=1 to a[6] do
  write('6');
 for i:=1 to a[5] do
  write('5');
 for i:=1 to a[4] do
  write('4');
 for i:=1 to a[3] do
  write('3');
 for i:=1 to a[2] do
  write('2');
 for i:=1 to a[1] do
  write('1');
 for i:=1 to a[0] do
  write('0');
end.

var k, c, kol, kols: array [1..10000] of Longint;
    a: array [1..200, 1..40000] of Longint;
    x1, k1, n, i, t, j: Longint;
    q: array [1..3, 1..100000] of Longint;
    min, sum, now, mark: Longint;
    l, r: array [1..3] of Longint;

Begin
     read(n);
     for i := 1 to n do
         read(c[i]);
     for i := 1 to n do begin
         read(k1);
         kols[i] := k1;
         for j := 1 to k1 do begin
             read(x1);
             inc(k[x1]);
             a[x1, k[x1]] := i;
         end;
     end;
     min := maxlongint;
     for t := 1 to 3 do begin
         for i := 1 to 3 do
             r[i] := 0;
         for i := 1 to n do
             kol[i] := kols[i];
         mark := 0;
         for i := 1 to n do
             if kol[i] = 0 then begin
                inc(r[c[i]]);
                q[c[i], r[c[i]]] := i;
             end;
         for i := 1 to 3 do
             l[i] := 1;
         now := t;
         sum := 0;
         while (l[1] <= r[1]) or (l[2] <= r[2]) or (l[3] <= r[3]) do begin
             if l[now] > r[now] then begin
                inc(now);
                if now > 3 then
                   now := now - 3;
                inc(sum);
                continue;
             end;
             sum := sum + 1;
             inc(mark);
               for j := 1 to k[q[now, r[now]]] do begin
                   x1 := a[q[now, r[now]], j];
                   dec(kol[x1]);
                   if kol[x1] = 0 then begin
                      inc(r[c[x1]]);
                      q[c[x1], r[c[x1]]] := x1;
                   end;
               end;
               if mark = n then
                  break;
               inc(l[now]);
               if l[now] > r[now] then begin
                  now := now + 1;
                  inc(sum);
               end;
               if now > 3 then
                  now := now - 3;
         end;
         if sum < min then
            min := sum;
     end;
     writeln(min);
End.

Program zad3;

Var
 j, i, n, t: byte;
 b: array [1..200] of boolean;
 a: array [1..200, 1..200] of byte;
 c, k: array [1..200] of byte;
 z: array [1..3, 1..3] of byte;
 sum: word;

Function dost (i: byte): boolean;
 var
  d: boolean;
  h: byte;
 begin
  d:=true;
  h:=1;
  while d and (h<=k[i]) do
   begin
    if not (b[a[i][h]])
     then d:=false
     else inc (h);
   end;
  dost:=d;
 end;

Procedure qwe (t1, t2: byte; res: longint);
 var
  h, p: byte;
  r: array [1..200] of byte;
 begin
  h:=1;
  while (h<=n) and b[h] do
   inc (h);
  if h>n
   then
    begin
     dec (res, z[t1, t2]);
     if res<sum
      then sum:=res;
    end;
  p:=0;
  for h:=1 to n do
   if not b[h] and (c[h]=t2) and dost(h)
    then
     begin
      inc (p);
      r[p]:=h;
      b[h]:=true;
     end;
  if p>0
   then
    begin
     for h:=1 to 3 do
      if h<>t
       then qwe (t2, h, res+p+z[t2, h]);
    end;
  for h:=1 to p do
   b[r[p]]:=false;
 end;

Begin
 {assign (input, 'input.txt');
 assign (output, 'output.txt');
 reset (input);
 rewrite (output);}
 readln (n);
 for i:=1 to n do
  read (c[i]);
 readln;
 for i:=1 to n do
  begin
   read (k[i]);
   for j:=1 to k[i] do
    read (a[i, j]);
   readln;
  end;
 z[1, 2]:=1;
 z[1, 3]:=2;
 z[2, 1]:=2;
 z[2, 3]:=1;
 z[3, 1]:=1;
 z[3, 2]:=2;
 sum:=high(word);
 qwe (1, 1, 0);
 qwe (2, 2, 0);
 qwe (3, 3, 0);
 writeln (sum);
End.

Program zad3;

Var
 j, i, n, t: byte;
 b: array [1..200] of boolean;
 a: array [1..200, 1..200] of byte;
 c, k: array [1..200] of byte;
 z: array [1..3, 1..3] of byte;
 sum: word;

Function dost (i: byte): boolean;
 var
  d: boolean;
  h: byte;
 begin
  d:=true;
  h:=1;
  while d and (h<=k[i]) do
   begin
    if not (b[a[i][h]])
     then d:=false
     else inc (h);
   end;
  dost:=d;
 end;

Procedure qwe (t1, t2: byte; res: word);
 var
  h, p: byte;
  r: array [1..200] of byte;
 begin
  h:=1;
  while (h<=n) and b[h] do
   inc (h);
  if h>n
   then
    begin
     dec (res, z[t1, t2]);
     if res<sum
      then sum:=res;
     exit;
    end;
  p:=0;
  for h:=1 to n do
   if not b[h] and (c[h]=t2) and dost(h)
    then
     begin
      inc (p);
      r[p]:=h;
      b[h]:=true;
     end;
  if p>0
   then
    begin
     for h:=1 to 3 do
      if h<>t
       then qwe (t2, h, res+p+z[t2, h]);
    end;
  for h:=1 to p do
   b[r[p]]:=false;
 end;

Begin
 {assign (input, 'input.txt');
 assign (output, 'output.txt');
 reset (input);
 rewrite (output);}
 readln (n);
 for i:=1 to n do
  read (c[i]);
 readln;
 for i:=1 to n do
  begin
   read (k[i]);
   for j:=1 to k[i] do
    read (a[i, j]);
   readln;
  end;
 z[1, 2]:=1;
 z[1, 3]:=2;
 z[2, 1]:=2;
 z[2, 3]:=1;
 z[3, 1]:=1;
 z[3, 2]:=2;
 sum:=high(word);
 qwe (1, 1, 0);
 qwe (2, 2, 0);
 qwe (3, 3, 0);
 writeln (sum);
End.

var
  p,tmp,c:array[1..200] of longint;
  w:array[1..200,1..200] of boolean;
  v:array[1..200] of boolean;
  i,j,k,x,ans,n,num,s,q:longint;
begin
  readln(n);
  for i:=1 to n do read(c[i]);
  for i:=1 to n do
    begin
      read(p[i]);
      for j:=1 to p[i] do
        begin
          read(x);
          w[x,i]:=true;
        end;
    end;
  for i:=1 to n do tmp[i]:=p[i];
  ans:=10000;
  s:=1; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=(s+1)mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  for i:=1 to n do p[i]:=tmp[i];
  fillchar(v,sizeof(v),0);
  s:=2; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=(s+1)mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  fillchar(v,sizeof(v),0);
  for i:=1 to n do p[i]:=tmp[i];
  s:=3; num:=0; q:=0;
  while num<n do
    begin
      k:=0;
      for i:=1 to n do if (not v[i])and(p[i]=0)and(c[i]=s)then
        begin k:=i; break; end;
      if k=0 then s:=(s+1)mod 3+1
      else
        begin
          inc(num);
          for i:=1 to n do if w[k,i] then dec(p[i]);
          v[k]:=true;
        end;
      inc(q);
    end;
  if q<ans then ans:=q;
  writeln(ans);
end.

uses math;
const
      oo=high(longint);
      _oo=high(int64);
      roo=1e30;
      dx:array[0..7] of longint=(-1,0,1,0,-1,1,1,-1);
      dy:array[0..7] of longint=(0,1,0,-1,1,1,-1,-1);
type point=record x,y:longint; end;
     rpoint=record x,y:double; end;
var f,g:text;
    fi,fo:string;
    id,count,fa,deg:array[0..333] of longint;
    a:array[0..300,0..300] of boolean;
    ans,i,j,n,st,cv,k,t,v:longint;
procedure closefile; begin close(g); close(F); end;
begin
        randomize;
        {$IFNDEF ONLINE_JUDGE} fi := 'i.inp'; fo := ''; {$ENDIF}
        assign(f,fi); reset(f);
        assign(g,fo); rewrite(g);
            readln(f,n);

            for i:=1 to n do read(f,id[i]);
            for i:=1 to n do begin
                read(f,k);
                for j:=1 to k do begin
                    read(f,t);
                    a[t,i]:=true;
                end;
                readln(f);
                deg[i]:=k;
                if k=0 then inc(count[id[i]]);

            end;
            cv:=n;
            ans:=0;
            for i:=1 to 3 do
             if count[i]>0 then begin
                 st:=i;
                 repeat

                   while count[st]>0 do begin
                    for j:=1 to n do
                      if (id[j]=st) and (deg[j]=0) then begin
                         dec(cv);
                         deg[j]:=-1;
                         dec(count[st]);
                         for v:=1 to n do
                          if a[j,v] then begin
                               dec(deg[v]);
                               if deg[v]=0 then inc(count[id[v]]);
                          end;
                         ans:=ans+1;
                      end;
                    end;
                    if cv=0 then break;
                    st:=st+1;
                    ans:=ans+1;
                    if st=4 then st:=1;
                 until cv=0;
                 if cv=0 then break;
             end;
            writeln(g,ans);
        closefile;
end.

{$r-,q-,s-,i-,o+}
var
  t,tmp,x,kg,sum,n,i,j:longint;
  a,q:array[0..500500]of longint;
  d:array[0..555,0..555]of longint;

begin
  read(n);
  for i:=1 to n do read(a[i]);
  fillchar(d,sizeof(d),$0);
  for i:=1 to n do begin
    read(kg);
    for j:=1 to kg do begin
      read(x);
      d[x][i]:=1;
    end;
  end;
  for i:=1 to n do q[i]:=i;
  for t:=1 to n do
    for i:=1 to n do
      for j:=i+1 to n do
        if (d[q[j]][q[i]]=1)or((d[q[i]][q[j]]=0)and(a[q[i]]>a[q[j]]))then begin
          tmp:=q[i];q[i]:=q[j];q[j]:=tmp;
        end;
  sum:=0;
  for i:=1 to n-1 do begin
    sum:=sum+a[q[i+1]]-a[q[i]];
    if (a[q[i+1]]<a[q[i]])then inc(sum,3);
  end;
  writeln(sum+n);
end.

var
 f:array[1..228,0..228]of longint;
 fk,k,a:array[1..228]of longint;
 jj,ff,ot,otv,i,j,n,m,kol:longint;
function dfs(i,j:longint):longint;
begin
 for jj:=1 to k[i] do
 begin
  if fk[f[i,jj]]=1 then continue;
  if a[f[i,jj]]<>j then exit(0);
  if dfs(f[i,jj],j)=1 then continue;
  exit(0);
 end;
 inc(otv);
 dec(kol);
 fk[i]:=1;
 if ot=0 then ot:=j;
 exit(1);
end;
begin
 readln(n);
 for i:=1 to n do read(a[i]);
 for i:=1 to n do
 begin
  read(k[i]);
  for j:=1 to k[i] do read(f[i,j]);
  readln;
 end;
 kol:=n;
 j:=1;
 while(kol<>0)do
 begin
  for i:=1 to n do
  if(a[i]=j)and(fk[i]=0)then
  begin
   dfs(i,j);
  end;
  if kol=0 then break;
  inc(otv);
  j:=(j mod 3)+1;
 end;
 writeln(otv-ot+1);
end.

var
 f:array[1..1000,1..1000]of longint;
 c,us,s,t:array[1..1000000]of longint;
 x,ot,o,st,n,m,i,j,k,z,otv:longint;
procedure dfs(v:longint);
var j:longint;
begin
 if us[v]=1 then exit;
 us[v]:=1;
 for j:=1 to n do if f[v,j]=1 then dfs(j);
 inc(st);
 s[st]:=v;
end;
begin
 readln(n);
 for i:=1 to n do read(c[i]);
 for i:=1 to n do
 begin
  read(k);
  for j:=1 to k do
  begin
   read(z);
   f[z,i]:=1;
  end;
 end;
 for i:=1 to n do dfs(i);
 otv:=maxlongint;
 for o:=1 to 3 do
 begin
  x:=o;
  ot:=0;
  for i:=n downto 1 do
  begin
   while(x<>c[s[i]])do
   begin
    inc(ot);
    inc(x);
    if x=4 then x:=1;
   end;
   inc(ot);
  end;
  if otv>ot then otv:=ot;
 end;
 writeln(otv);
end.
//2>1
//2>5
//1>5
//3>4
//3>5
//4>5
//5 1 3 4 2

var
 f:array[1..228,0..228]of longint;
 fk,k,a,tp:array[1..228]of longint;
 ii,s,jj,ff,ot,otv,i,j,n,m,kol:longint;
function dfs(i:longint):longint;
var j:longint;
begin
 fk[i]:=1;
 for j:=1 to k[i] do if fk[f[i,j]]=0 then dfs(f[i,j]);
 inc(s);
 tp[s]:=i;
end;
begin
 readln(n);
 for i:=1 to n do read(a[i]);
 for i:=1 to n do
 begin
  read(k[i]);
  for j:=1 to k[i] do read(f[i,j]);
  readln;
 end;
 for i:=1 to n do if fk[i]=0 then dfs(i);
 kol:=n;
 j:=1;
 for i:=1 to n do fk[i]:=0;
 while(kol<>0)do
 begin
  for ii:=1 to n do
  begin
   i:=tp[ii];
   if(a[i]=j)and(fk[i]=0)then
   begin
    ff:=0;
    for jj:=1 to k[i] do if fk[f[i,jj]]=0 then ff:=1;
    if ff=0 then
    begin
     inc(otv);
     dec(kol);
     if ot=0 then ot:=j;
     fk[i]:=1;
    end;
   end;
  end;
  if kol=0 then break;

  inc(otv);
  inc(j);
  if j=4 then j:=1;
 end;
 writeln(otv-ot+1);
end.

var
 f:array[1..228,0..228]of longint;
 fk,k,a:array[1..228]of longint;
 jj,ff,ot,otv,i,j,n,m,kol:longint;
function dfs(i,j:longint):longint;
begin
 for jj:=1 to k[i] do
 begin
  if fk[f[i,jj]]=1 then continue;
  if a[f[i,jj]]<>j then exit(0);
  if dfs(f[i,jj],j)=1 then continue;
  exit(0);
 end;
 inc(otv);
 dec(kol);
 fk[i]:=1;
 if ot=0 then ot:=j;
 exit(1);
end;
begin
 readln(n);
 for i:=1 to n do read(a[i]);
 for i:=1 to n do
 begin
  read(k[i]);
  for j:=1 to k[i] do read(f[i,j]);
  readln;
 end;
 kol:=n;
 j:=1;
 while(kol<>0)do
 begin
  for i:=1 to n do
  if(a[i]=j)and(fk[i]=0)then dfs(i,j);

  if kol=0 then break;

  inc(otv);
  inc(j);
  if j=4 then j:=1;
 end;
 writeln(otv-ot+1);
end.

VAR
  a, b, c, i, j, j1, N, No, t, Kol, flag, time: LONGINT;
  Mas, M, k: ARRAY[0..200000] OF LONGINT;
  Massiv: ARRAY[0..200,0..200] OF LONGINT;
BEGIN
  READLN(N);
  FOR i := 1 TO N DO
    READ(Mas[i]);
  FOR j := 1 TO N DO
    BEGIN
      READ(k[j]);
      FOR i := 1 TO k[j] DO
        READ(Massiv[j,i]);
      READLN;
    END;
  time := 20000000;
  FOR i := 1 TO 3 DO
    BEGIN
      Kol := 0;
      No := i;
      FOR j := 1 TO N DO
        M[j] := Mas[j];
      WHILE Kol<N
      DO
        BEGIN
          flag := 0;
          FOR j := 1 TO N DO
            IF (M[j]=No)
            THEN
              BEGIN
                FOR j1 := 1 TO k[j] DO
                  IF M[Massiv[j,j1]]<>-1
                  THEN
                    BREAK;
                flag := 1;
                M[j] := -1;
                Kol := Kol+1;
              END;
          IF flag<>1
          THEN
            BEGIN
              No := (No MOD 3)+1;
              t := t+1;
            END;
        END;
      IF t<time
      THEN
        time := t;
    END;
  time := time+N;
  WRITELN(time);
END.

VAR
  a, b, c, i, j, j1, N, No, t, Kol, flag, time: LONGINT;
  Mas, M, k: ARRAY[0..200000] OF LONGINT;
  Massiv: ARRAY[0..200,0..200] OF LONGINT;
BEGIN
  READLN(N);
  FOR i := 1 TO N DO
    READ(Mas[i]);
  FOR j := 1 TO N DO
    BEGIN
      READ(k[j]);
      FOR i := 1 TO k[j] DO
        READ(Massiv[j,i]);
      READLN;
    END;
  time := 20000000;
  FOR i := 1 TO 3 DO
    BEGIN
      Kol := 0;
      No := i;
      FOR j := 1 TO N DO
        M[j] := Mas[j];
      WHILE Kol<N
      DO
        BEGIN
          flag := 0;
          FOR j := 1 TO N DO
            IF (M[j]=No)
            THEN
              BEGIN
                a := 0;
                FOR j1 := 1 TO k[j] DO
                  IF M[Massiv[j,j1]]<>-1
                  THEN
                    a := 1;
                IF (a=0)
                THEN
                BEGIN
                flag := 1;
                M[j] := -1;
                Kol := Kol+1;
                END;
              END;
          IF (flag<>1)
          THEN
            BEGIN
              No := (No MOD 3)+1;
              t := t+1;
            END;
        END;
      IF t<time
      THEN
        time := t;
    END;
  time := time+N;
  WRITELN(time);
END.

{$MODE OBJFPC}
const inp = '';
      outp= '';
      base= 250;

var fi,fo : text;
    n,kq,ans : longint;
    a,head : array[1..base] of longint;
    c : array[1..base,1..base] of boolean;
    free : array[1..base] of longint;
    check : array[1..base] of boolean;

procedure Input;
var i,x,j : longint;
begin
  assign(fi,inp); assign(fo,outp);
  reset(fi); rewrite(fo);
  readln(fi,n);
  for i:= 1 to n do read(fi,a[i]);
  for i:= 1 to n do
    begin
      read(fi,head[i]);
      for j:= 1 to head[i] do
        begin
          read(fi,x);
          c[i,x] := true;
        end;
    end;
end;

procedure dfs(u : longint);
var com,v,i : longint;
begin
  com := a[u];
  for v:= 1 to n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      dfs(v);
    end;
  com := a[u] + 1;
  if com > 3 then com := 1;
  for v:= 1 to  n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      inc(kq);
      dfs(v);
    end;
end;

procedure Solve;
var i,j : longint;
begin
  ans := 0;
  for i:= 1 to n do
  if head[i] = 0 then
    begin
      for j:= 1 to n do
        begin
          free[j] := head[j];
          if c[j,i] then dec(free[j]);
        end;
      check[i] := true;
      kq := n;
      dfs(i);
      if kq > ans then ans := kq;
    end;
  writeln(fo,ans);
end;

procedure Output;
begin
  close(fi); close(fo);
end;

begin
  Input;
  Solve;
  Output;
end.

{$MODE OBJFPC}
const inp = '';
      outp= '';
      base= 250;

var fi,fo : text;
    n,kq,ans : longint;
    a,head : array[1..base] of longint;
    c : array[1..base,1..base] of boolean;
    free : array[1..base] of longint;
    check : array[1..base] of boolean;

procedure Input;
var i,x,j : longint;
begin
  assign(fi,inp); assign(fo,outp);
  reset(fi); rewrite(fo);
  readln(fi,n);
  for i:= 1 to n do read(fi,a[i]);
  for i:= 1 to n do
    begin
      read(fi,head[i]);
      for j:= 1 to head[i] do
        begin
          read(fi,x);
          c[i,x] := true;
        end;
    end;
end;

procedure dfs(u : longint);
var com,v,i : longint;
begin
  com := a[u];
  for v:= 1 to n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      dfs(v);
    end;
  com := a[u] + 1;
  if com > 3 then com := 1;
  for v:= 1 to  n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      inc(kq);
      dfs(v);
    end;
  com := 6 - com - a[u];
  for v := 1 to n do
  if not check[v] and (a[v] = com) and (free[v] = 0) then
    begin
      check[v] := true;
      for i:= 1 to n do if c[i,v] then dec(free[i]);
      kq := kq + 2;
      dfs(v);
    end;
end;

procedure Solve;
var i,j : longint;
begin
  ans := 0;
  for i:= 1 to n do
  if head[i] = 0 then
    begin
      for j:= 1 to n do
        begin
          free[j] := head[j];
          if c[j,i] then dec(free[j]);
        end;
      check[i] := true;
      kq := n;
      dfs(i);
      if kq > ans then ans := kq;
    end;
  writeln(fo,ans);
end;

procedure Output;
begin
  close(fi); close(fo);
end;

begin
  Input;
  Solve;
  Output;
end.

{$R+,O-}
// Aimakov Yeldar, AtyrauKTL, 11 class
Uses Math, SysUtils;
type
	int = longint;
	bool = boolean;
const
	mx = maxint;
var
	was : array [0..201] of bool;
	res, ans, i, j, n, l, x, k, pos, sz, u : int;
	len, len1, a, v, t, f : array [0..201*201] of int;

procedure add(xx, yy : int);
begin
	inc(l);
	v[l] := yy;
	t[l] := f[xx];
	f[xx] := l;
end;

begin
//	assign(input, 'a.in'); reset(input);
//	assign(output, 'a.out'); rewrite(output);
	read(n); l := 0; res := mx;
	for i := 1 to n do read(a[i]);
	for i := 1 to n do begin
		read(len[i]);
		for j := 1 to len[i] do begin
			read(x);
			add(x, i);
		end;
	end;
	for i := 1 to n do
		if (len[i] = 0) then begin
			len1 := len; u := i;
			k := a[i]; sz := 0;
			fillchar(was, sizeof(was), false);
			while (sz <> n) do begin
				if (not was[u]) then begin
					inc(sz);
          pos := f[u];
					was[u] := true;
					while (pos > 0) do begin
						dec(len1[v[pos]]);
						pos := t[pos];
					end;
				end;
				for j := 1 to n do
					if (len1[j] = 0) and (k = a[j]) and (not was[j]) then begin
					    u := j;
						break;
					end;
				if (not was[u]) then continue;
				inc(k); inc(ans);
				if (k = 4) then k := 1;
			end;
			res := min(res, ans);
		end;
	writeln(res+n-1);
end.