求割点入门题！

……死调一下午+晚上才发现把‘node'打成’nodes'了……

Program P1523;
const
   maxedge=999000;
   maxn=10000;
var
   edge,tail:array[1..maxedge] of longint;
   size:longint;
   head:array[1..maxn] of longint;

   n,i,j,ans,k:longint;
   b,cut:array[1..maxn] of boolean;


   time,root:longint;
   a,d,ancestor,c:array[1..maxn] of longint;


procedure addedge(u,v:longint);
begin
   inc(size);
   edge[size]:=v;
   tail[size]:=head[u];
   head[u]:=size;
end;
function min(a,b:longint):longint;
begin
   if a<b then exit(a) else exit(b);
end;
function max(a,b:longint):longint;
begin
   if a>b then exit(a) else exit(b);
end;

procedure Dfs(k,father,deep:longint);
var
   i,j,p,tot:longint;
begin
   tot:=0;
   c[k]:=1;
   d[k]:=deep;
   ancestor[k]:=deep;

   p:=head[k];

   while (p>0) do
   begin
      i:=edge[p];

      if (i<>father) and (c[i]=1) then ancestor[k]:=min(ancestor[k],d[i]);

      if (c[i]=0) then
      begin
         dfs(i,k,deep+1);
         inc(tot);
         ancestor[k]:=min(ancestor[k],ancestor[i]);
         if (k=root) and (tot>=2) then cut[k]:=true;
         if (k<>root) and (ancestor[i]>=d[k]) then cut[k]:=true;

      end;



      p:=tail[p];
   end;

   c[k]:=2;
   inc(time);
   a[k]:=time;

end;
procedure Dfs2(k:longint);
var
   i,p:longint;
begin
   b[k]:=true;

   p:=head[k];

   while (p>0) do
   begin
      i:=edge[p];


      if not(b[i]) then
      begin
         dfs2(i);

      end;



      p:=tail[p];
   end;

end;

function main:boolean;
var
   i,j,p,ans:longint;
begin
   time:=0;
   main:=false;
   for i:=1 to maxn do
      if (head[i]>0) and (c[i]=0) then
      begin
        root:=i;
        dfs(root,0,1);
      end;



   for i:=1 to maxn do
      if cut[i] then
      begin
         main:=true;
         ans:=0;
         fillchar(b,sizeof(b),false);
         b[i]:=true;
         p:=head[i];
         while (p>0) do
         begin
            if not(b[edge[p]]) then
            begin
               dfs2(edge[p]);
               inc(ans);
            end;
            p:=tail[p];
         end;

         writeln('  SPF node ',i,' leaves ',ans,' subnets');

      end;






end;

begin
 {  assign(input,'p1523.in');
   reset(input);
    }
   k:=1;
   while not seekeof do
   begin
      size:=0;
      fillchar(head,sizeof(head),0);
      fillchar(edge,sizeof(edge),0);
      fillchar(tail,sizeof(tail),0);
      fillchar(cut,sizeof(cut),false);
      fillchar(c,sizeof(c),0);
      fillchar(d,sizeof(d),0);
      fillchar(ancestor,sizeof(ancestor),0);




      read(i);
      if i=0 then break;
      read(j);
      while (i>0) do
      begin
         addedge(i,j);
         addedge(j,i);
         read(i);
         if i=0 then break;
         read(j);
      end;
      ans:=0;
      writeln('Network #',k);

      if not(main) then writeln('  No SPF nodes');





      writeln;
      inc(k);
   end;
end.

Bellman_ford

Program P1860;
var
   n,m,i,j,s:longint;
   v:double;
   flag:boolean;
   d:array[1..100] of double;
   x,y:array[1..100] of longint;
   map:array[1..100,1..4] of double;
procedure relax(i:longint);
begin
   if (d[y[i]]<(d[x[i]]-map[i,2])*map[i,1]) then
   begin
      d[y[i]]:=(d[x[i]]-map[i,2])*map[i,1];
      flag:=false;
   end;
   if (d[x[i]]<(d[y[i]]-map[i,4])*map[i,3]) then
   begin
      d[x[i]]:=(d[y[i]]-map[i,4])*map[i,3];
      flag:=false;
   end;

end;
procedure bell_ford;
var
   i,j:longint;
begin
   for i:=1 to n do
   begin
      flag:=true;
      for j:=1 to m do relax(j);
      if flag then break;
   end;
   if flag then writeln('NO')
   else writeln('YES');
end;
begin
   while not seekeof do
   begin
      readln(n,m,s,v);
      fillchar(d,sizeof(d),0);
      d[s]:=v;
      for i:=1 to m do
      begin
         readln(x[i],y[i],map[i,1],map[i,2],map[i,3],map[i,4]);
      end;
      bell_ford;
   end;
end.

拓排+各种判……

Program P1094;
type
   map3=record
        indegree:array['A'..'Z'] of longint;
        map:array['A'..'Z',1..26] of char;
        outdegree:array['A'..'Z'] of longint;
        end;
var
   n,m,i,j,num,value,topvalue:longint;
   s:string;
   topout:string;
   map,map2:map3;
   mark:array['A'..'Z'] of boolean;
   tag:boolean;
Function topsort:longint;
var
   j,k,h,s,zero:longint;
   flag:boolean;
   i:char;
begin
   topsort:=3;
   topout:='';
   flag:=false;
   h:=1;
   s:=0;
   zero:=0;
   for i:='A' to 'Z' do if mark[i] then if map2.indegree[i]=0 then begin inc(zero); topout:=topout+i; end;
   if zero=0 then exit(2);
   s:=length(topout);
   while (h<=s) do
   begin
      if (h<s) then flag:=true;
      for j:=h to s do
      begin
         for k:=1 to map2.outdegree[topout[j]] do
         begin
            dec(map2.indegree[map2.map[topout[j],k]]);
            if map2.indegree[map2.map[topout[j],k]]=0 then
            begin
               topout:=topout+map2.map[topout[j],k];
            end;
         end;
         if length(topout)>num then exit(2);
      end;
      h:=s+1;
      s:=length(topout);
   end;
   if s<num then exit(2);
   if (s=num) and (num<n) then exit(3);

   if flag or (num<n) then exit(3) else exit(1);

end;
Procedure ski(step:longint);
var
   i:longint;
   s:string;
begin
   for i:=step+1 to m do readln(s);
end;
Procedure pri(value,step:longint);
begin
   if value=1 then writeln('Sorted sequence determined after ',step,' relations: ',topout,'.');
   if value=3 then writeln('Sorted sequence cannot be determined.');
   if value=2 then
   begin
      writeln('Inconsistency found after ',step,' relations.');
      ski(step);
   end;
   if value=1 then ski(step);
end;

begin
 {  assign(input,'P1094.in');
   assign(output,'p1094.out');
   reset(input);
   rewrite(output);    }
   readln(n,m);
   while (n+m>0) do
   begin
      topout:='';
      fillchar(map,sizeof(map),0);
      fillchar(mark,sizeof(mark),false);
      num:=0;
      value:=3;
      for i:=1 to m do
      begin
         readln(s);
         if (ord('A')-1+n<ord(s[1])) or (ord('A')-1+n<ord(s[3])) or (s[1]=s[3]) then
         begin
            value:=2;
            break;
         end;

         if not(mark[s[1]]) then begin mark[s[1]]:=true; inc(num); end;
         if not(mark[s[3]]) then begin mark[s[3]]:=true; inc(num); end;
         tag:=false;
         for j:=1 to map.outdegree[s[1]] do
            if map.map[s[1],j]=s[3] then begin tag:=true; break; end;
         if tag then continue;
         inc(map.indegree[s[3]]);
         inc(map.outdegree[s[1]]);
         map.map[s[1],map.outdegree[s[1]]]:=s[3];

         map2:=map;
         topvalue:=topsort;
         if topvalue<=2 then begin value:=topvalue; break; end;
      end;
      pri(value,i);
      readln(n,m);
   end;
{   close(input);
   close(output);  }
end.

给定一个有向图，问这是不是树？

各种判……

出现2条相同的边不是树，自己指向自己不是树，除根节点入度为0外其它点入度必须为1，森林，环都不是树……

program P1308;
const
   maxn=15;
Var
   i,j:longint;
   b:array[1..maxn,1..maxn] of boolean;
   indegree:array[1..maxn] of longint;
   bo:array[1..maxn] of boolean;
   queue:array[1..maxn+10] of longint;
procedure skip;
var
   x,y:longint;
begin
   repeat
      read(x,y);
   until (x=0) and (y=0);
end;
function main:longint;
var
   i,j,k,x,y,root,node:longint;
begin
   read(x,y);
   if (x=-1) and (y=-1) then exit(-1);
   if (x=0) and (y=0) then exit(1);
   while (x>0) and (y>0) do
   begin
      if b[x,y] or b[y,x] or (x=y) or (indegree[y]=1) then
      begin
         skip;
         exit(0);
      end;
      b[x,y]:=true;
      bo[x]:=true;bo[y]:=true;
      inc(indegree[y]);
      read(x,y);
   end;
   root:=0;
   node:=0;
   for i:=1 to maxn do
   begin
      if bo[i] then inc(node);
      if (indegree[i]=0) and bo[i] then
      begin
         if root=0 then root:=i else exit(0);
      end;
   end;
   if (root=0) then exit(0);
   i:=1;j:=1;
   queue[1]:=root;
   bo[root]:=false;
   while i<=j do
   begin
      for k:=1 to maxn do
         if b[queue[i],k] then
         begin
            if not(bo[k]) then exit(0);
            bo[k]:=false;
            inc(j);
            queue[j]:=k;
         end;
      inc(i);
   end;
   if (j<>node) then exit(0);
   exit(1);
end;
begin
   i:=1;
   while (true) do
   begin
      fillchar(indegree,sizeof(indegree),0);
      fillchar(b,sizeof(b),0);
      fillchar(bo,sizeof(bo),0);
      j:=main;
      if j=1 then writeln('Case ',i,' is a tree.')
      else if j=0 then writeln('Case ',i,' is not a tree.')
      else break;
      inc(i);
   end;
end.