您所在位置：主题：我关于复赛的试题的解答（帮我看看）
shisutianxia
[专家分：630] 发布于 2007-11-22 13:56:00
提高组最后一题--树网的核
可惜的是我调不到使N>100 以上，希望大家能修改修改，帮忙
program core;
type ss=array[0..100]of 0..100;
var a:array[1..100,1..100]of integer;
v:array[1..100]of 0..1;
rec,daan:ss;
prec:array[1..100]of ss;
m,o,b,c,d,kw,t,n,s,i,j:integer;zhi,p,q:longint;
procedure search(k:longint);
var l,i,j:integer;
begin
for i:=1 to n do
if (v[i]=0)and(a[i,rec[t]]<>0) then begin
v[i]:=1;inc(t);rec[t]:=i;k:=k+a[i,rec[t-1]];
if k>kw then begin
for j:=1 to t do
daan[j]:=rec[j];
daan[0]:=t;kw:=k;
end;
search(k);
end;
v[t]:=0;
t:=t-1;
end;
function count(d,b:integer):longint;
var k,i:integer;
begin
k:=0;
for i:=d+1 to b do
k:=k+a[prec[o][i-1],prec[o][i]];
count:=k;
end;
begin
readln(n,s);
for i:=1 to 30 do
for j:=1 to 30 do
begin
a[i,j]:=0;
prec[i][j]:=0;;
end;
for i:=1 to n-1 do
begin
readln(b,c,d);
a[b,c]:=d;a[c,b]:=d;
end;
fillchar(v,sizeof(v),0);
fillchar(rec,sizeof(rec),0);
fillchar(daan,sizeof(daan),0);
p:=0;o:=0;
for i:=1 to n do
begin
v[i]:=1;t:=1;
rec[t]:=i;
kw:=0;
search(kw);
if kw>p then begin
p:=kw;o:=1;
for j:=0 to daan[0] do
prec[o][j]:=daan[j];
end;
if kw=p then begin
inc(o);
for j:=0 to daan[0] do
prec[o][j]:=daan[j];
end;
v[i]:=0;
end;
for i:=1 to o do
begin
for j:=1 to prec[o][0] do
write(prec[o][j]);
writeln;
end;
q:=maxint;
for i:=1 to o do
for j:=1 to prec[i][0] do
for m:=j to prec[i][0] do
begin
if count(j,m)>s then break;
if count(1,j)>count(m,prec[i][0]) then
zhi:=count(1,j)
else zhi:=count(m,prec[i][0]);
if zhi<q then q:=zhi;
end;
writeln(q);
end.
可惜的是我调不到使N>100 以上，希望大家能修改修改，帮忙
program core;
type ss=array[0..100]of 0..100;
var a:array[1..100,1..100]of integer;
v:array[1..100]of 0..1;
rec,daan:ss;
prec:array[1..100]of ss;
m,o,b,c,d,kw,t,n,s,i,j:integer;zhi,p,q:longint;
procedure search(k:longint);
var l,i,j:integer;
begin
for i:=1 to n do
if (v[i]=0)and(a[i,rec[t]]<>0) then begin
v[i]:=1;inc(t);rec[t]:=i;k:=k+a[i,rec[t-1]];
if k>kw then begin
for j:=1 to t do
daan[j]:=rec[j];
daan[0]:=t;kw:=k;
end;
search(k);
end;
v[t]:=0;
t:=t-1;
end;
function count(d,b:integer):longint;
var k,i:integer;
begin
k:=0;
for i:=d+1 to b do
k:=k+a[prec[o][i-1],prec[o][i]];
count:=k;
end;
begin
readln(n,s);
for i:=1 to 30 do
for j:=1 to 30 do
begin
a[i,j]:=0;
prec[i][j]:=0;;
end;
for i:=1 to n-1 do
begin
readln(b,c,d);
a[b,c]:=d;a[c,b]:=d;
end;
fillchar(v,sizeof(v),0);
fillchar(rec,sizeof(rec),0);
fillchar(daan,sizeof(daan),0);
p:=0;o:=0;
for i:=1 to n do
begin
v[i]:=1;t:=1;
rec[t]:=i;
kw:=0;
search(kw);
if kw>p then begin
p:=kw;o:=1;
for j:=0 to daan[0] do
prec[o][j]:=daan[j];
end;
if kw=p then begin
inc(o);
for j:=0 to daan[0] do
prec[o][j]:=daan[j];
end;
v[i]:=0;
end;
for i:=1 to o do
begin
for j:=1 to prec[o][0] do
write(prec[o][j]);
writeln;
end;
q:=maxint;
for i:=1 to o do
for j:=1 to prec[i][0] do
for m:=j to prec[i][0] do
begin
if count(j,m)>s then break;
if count(1,j)>count(m,prec[i][0]) then
zhi:=count(1,j)
else zhi:=count(m,prec[i][0]);
if zhi<q then q:=zhi;
end;
writeln(q);
end.
