poj 2762 tarjan缩点+拓扑序

2013-09-08 10:00

var
    m, n                :longint;
    t                   :longint;
    f, last             :array[0..20100] of longint;
    pre, other          :array[0..160100] of longint;
    l, time             :longint;
    dfn, low            :array[0..20100] of longint;
    tot                 :longint;
    stack               :array[0..20100] of longint;
    flag, fs            :array[0..20100] of boolean;
    i                   :longint;
    key                 :array[0..20100] of longint;
    kk                  :longint;
    que                 :array[0..20100] of longint;
    count               :longint;
 
function min(a,b:longint):longint;
begin
    if a>b then min:=b else min:=a;
end;
 
procedure connect(x,y:longint);
begin
    inc(l);
    pre[l]:=last[x];
    last[x]:=l;
    other[l]:=y;
    f[y]:=x;
end;
 
procedure init;
var
    i                   :longint;
    x, y                :longint;
begin
    read(n,m);
    for i:=1 to m do
    begin
        read(x,y);
        connect(x,y);
    end;
end;
 
procedure dfs(x:longint);
var
    p, q, cur           :longint;
begin
    inc(time);
    dfn[x]:=time;
    low[x]:=time;
    inc(tot);
    stack[tot]:=x;
    fs[x]:=true;
    flag[x]:=true;
    q:=last[x];
    while q<>0 do
    begin
        p:=other[q];
        if p<>x then
        begin
            if not flag[p] then
            begin
                dfs(p);
                low[x]:=min(low[x],low[p]);
            end else
            if fs[p] then
            begin
                low[x]:=min(low[x],dfn[p]);
            end;
        end;
        q:=pre[q];
    end;
    p:=-1;
    if low[x]=dfn[x] then
    begin
        inc(kk);
        while p<>x do
        begin
            p:=stack[tot];
            fs[p]:=false;
            key[p]:=kk;
            dec(tot);
            inc(count);
        end;
    end;
 
end;
 
function bfs(x:longint):boolean;
var
    i                   :longint;
    t, h, p, q          :longint;
    cur                 :longint;
    d                   :array[0..2020] of longint;
 
begin
        fillchar(flag,sizeof(flag),0);
        fillchar(d,sizeof(d),0);
        h:=0; t:=1;
        que[1]:=x;
        d[x]:=1;
        while h<t do
        begin
            inc(h);
            cur:=que[h];
            q:=last[cur];
            while q<>0 do
            begin
                p:=other[q];
                inc(t);
                que[t]:=p;
                d[p]:=d[cur]+1;
                q:=pre[q];
            end;
        end;
        if d[que[t]]=kk-n then exit(true) else exit(false);
end;
 
procedure main;
var
    i                   :longint;
    x                   :longint;
    q, p                :longint;
begin
    l:=1;
    fillchar(last,sizeof(last),0);
    time:=0;
    fillchar(f,sizeof(f),0);
    fillchar(low,sizeof(low),0);
    fillchar(dfn,sizeof(dfn),0);
    fillchar(flag,sizeof(flag),false);
    fillchar(stack,sizeof(stack),0);
    tot:=0;
    fillchar(fs,sizeof(fs),false);
    fillchar(key,sizeof(key),0);
    count:=0;
    init;
    x:=0;
    kk:=n;
    for i:=1 to n do
        if (f[i]=0) then
        begin
            if x<>0 then
            begin
                writeln('No');
                exit;
            end;
            x:=i;
        end;
    if x=0 then x:=1;
    dfs(x);
 
    if count<>n then
    begin
        writeln('No');
        exit;
    end;
 
    for i:=1 to n do
    begin
        q:=last[i];
        while q<>0 do
        begin
            p:=other[q];
            if key[i]<>key[p] then connect(key[i],key[p]);
            q:=pre[q];
        end;
    end;
    x:=0;
    for i:=n+1 to kk do
    begin
        if f[i]=0 then
        begin
            if x<>0 then
            begin
                writeln('No');
                exit;
            end;
            x:=i;
        end;
    end;
 
    if x=0 then x:=1;
    if bfs(x) then writeln('Yes') else writeln('No');
end;
 
begin
    read(t);
    for i:=1 to t do main;
end.