Furik and Rubik love playing computer games. Furik has recently found a new game that greatly interested Rubik. The game consists of n parts and to complete each part a player may probably need to complete some other ones. We know that the game can be fully completed, that is, its parts do not form cyclic dependencies. Rubik has 3 computers, on which he can play this game. All computers are located in different houses. Besides, it has turned out that each part of the game can be completed only on one of these computers. Let's number the computers with integers from 1 to 3. Rubik can perform the following actions:   Complete some part of the game on some computer. Rubik spends exactly 1 hour on completing any part on any computer.  Move from the 1-st computer to the 2-nd one. Rubik spends exactly 1 hour on that.  Move from the 1-st computer to the 3-rd one. Rubik spends exactly 2 hours on that.  Move from the 2-nd computer to the 1-st one. Rubik spends exactly 2 hours on that.  Move from the 2-nd computer to the 3-rd one. Rubik spends exactly 1 hour on that.  Move from the 3-rd computer to the 1-st one. Rubik spends exactly 1 hour on that.  Move from the 3-rd computer to the 2-nd one. Rubik spends exactly 2 hours on that. Help Rubik to find the minimum number of hours he will need to complete all parts of the game. Initially Rubik can be located at the computer he considers necessary.

The first line contains integer n (1 ≤ n ≤ 200) — the number of game parts. The next line contains n integers, the i-th integer — ci (1 ≤ ci ≤ 3) represents the number of the computer, on which you can complete the game part number i.  Next n lines contain descriptions of game parts. The i-th line first contains integer ki (0 ≤ ki ≤ n - 1), then ki distinct integers ai, j (1 ≤ ai, j ≤ n; ai, j ≠ i) — the numbers of parts to complete before part i. Numbers on all lines are separated by single spaces. You can assume that the parts of the game are numbered from 1 to n in some way. It is guaranteed that there are no cyclic dependencies between the parts of the game.

On a single line print the answer to the problem.

NoteNote to the second sample: before the beginning of the game the best strategy is to stand by the third computer. First we complete part 5. Then we go to the 1-st computer and complete parts 3 and 4. Then we go to the 2-nd computer and complete parts 1 and 2. In total we get 1+1+2+1+2, which equals 7 hours.

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.

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.

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 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.

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.

{$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.

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 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.

{$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.

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.

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.

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.

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;
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.

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.

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.

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.

{$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.

{$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.

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.