之所以没公布标程，是因为个人觉得标程写得比较丑。
既然有人需要就发布一下吧，标程丑总比没有标程好。
Problem 1
program whyleast;
procedure solve(t,a,b:integer);
begin
if t=0 then exit else
begin
solve(t-1,a,b);
writeln(a,' ',2);
solve(t-1,b,a);
writeln(2,' ',b);
solve(t-1,a,b);
end;
end;
{====main====}
var
n,i:integer;
ans:longint=1;
begin
assign(input,'whyleast.in');
reset(input);
assign(output,'whyleast.out');
rewrite(output);
readln(n);
for i:=1 to n do ans:=ans*3;
writeln(ans-1);
solve(n,1,3);
close(input);
close(output);
end.
Problem 2
program height;
const
OutputString:array[boolean]of string=('YES','NO');
type
rec1=record
h,p:longint;
end;
pointer=^rec2;
rec2=record
x,y:longint;
dir:boolean;
next:pointer;
end;
var
orderHeight : array[1..100000]of longint;
SortHeight : array[1..100000]of rec1;
Deg,DegHash : array[0..100000]of longint;
EdgeHash : array[1..100000]of pointer;
n,m,DegCount:longint;
procedure SwapRec(var t1,t2:rec1);
var
t3:rec1;
begin
t3:=t1;
t1:=t2;
t2:=t3;
end;
procedure SwapInt(var t1,t2:longint);
var
t3:longint;
begin
t3:=t1;
t1:=t2;
t2:=t3;
end;
function InsertEdgeHash(x,y:longint):integer;
var
newp:pointer;
begin
new(newp);
newp^.x:=x;
newp^.y:=y;
if orderHeight[x] > orderHeight[y] then
newp^.dir:=( 1.25*OrderHeight[y] <= orderHeight[x] )
else newp^.dir:=( 1.25*OrderHeight[x] > orderHeight[y] );
newp^.dir:=not newp^.dir;
newp^.next:=EdgeHash[x];
EdgeHash[x]:=newp;
exit( ord( newp^.dir ) );
end;
function FindEdgeHash(x,y:longint):integer;
{ -1: Not Found; 0: x-->y 1: x<--y
x Always Smaller than y }
var
now:pointer;
begin
now:=EdgeHash[x];
while now<>nil do
begin
if now^.y=y then
begin
now^.dir:=not now^.dir;
exit( ord( now^.dir ) );
end;
now:=now^.next;
end;
exit(-1);
end;
procedure UpdateDeg(t,c:longint);
begin
if deg[t]<>c then
begin
dec(DegHash[Deg[t]]);
if DegHash[Deg[t]]=0 then dec(DegCount);
inc(DegHash[c]);
if DegHash[c]=1 then inc(DegCount);
Deg[t]:=c;
end;
end;
procedure ReadHeight;
var
i:longint;
begin
readln(n,m);
for i:=1 to n do
begin
readln(OrderHeight[i]);
SortHeight[i].h:=OrderHeight[i];
SortHeight[i].p:=i;
end;
end;
procedure Sort(l,r:longint);
var
i,j,mid:longint;
begin
i:=l;
j:=r;
mid:=SortHeight[(i+j)div 2].h;
repeat
while SortHeight[i].h<mid do inc(i);
while SortHeight[j].h>mid do dec(j);
if i<=j then
begin
SwapRec(SortHeight[i],SortHeight[j]);
inc(i);
dec(j);
end;
until i>j;
if l<j then Sort(l,j);
if i<r then Sort(i,r);
end;
procedure Init;
var
low:longint=1;
high:longint=1;
i:longint;
begin
DegHash[0]:=n;
DegCount:=1;
for i:=1 to n do
begin
while SortHeight[low].h*1.25 < SortHeight[i].h do inc(low);
while ( high<n ) and ( SortHeight[i].h*1.25 >= SortHeight[high+1].h ) do inc(high);
UpdateDeg( SortHeight[i].p, high+low-i );
end;
end;
procedure Solve;
var
i,x,y:longint;
dir:integer;
newp:pointer;
begin
for i:=1 to m do
begin
readln(x,y);
if x>y then SwapInt(x,y);
dir:=FindEdgeHash(x,y);
if dir=-1 then dir:=InsertEdgeHash(x,y);
if dir=0 then SwapInt(x,y);
UpdateDeg(x,Deg[x]+1);
UpdateDeg(y,Deg[y]-1);
writeln( OutputString[DegCount=n] );
end;
end;
{====main====}
begin
assign(input,'height.in');
reset(input);
assign(output,'height.out');
rewrite(output);
ReadHeight;
Sort(1,n);
Init;
Solve;
close(input);
close(output);
end.
Problem 3
program wolf;
type
rec=record
left,right:integer;
end;
const
infinite=maxlongint div 3-100000;
//Make sure no overflows occur
var
k,n,m : integer;
map : array[1..1000,1..1000]of longint;
dist : array[1..1000]of longint;
hash : array[1..1000]of boolean;
father : array[1..1000]of longint;
tree : array[1..1000]of rec;
attk : array[1..1000]of longint;
cost : array[1..1000]of integer;
minf : array[1..1000,0..100]of longint;
procedure readp;
var
i,x,y,d:longint;
begin
readln(k,n,m);
for i:=2 to n do
readln(attk[i],cost[i]);
for i:=1 to m do
begin
readln(x,y,d);
map[x,y]:=d;
map[y,x]:=d;
end;
end;
procedure init;
var
i,j:longint;
begin
for i:=2 to n do dist[i]:=infinite;
for i:=2 to n do hash[i]:=false;
dist[1]:=0;
hash[1]:=true;
for i:=1 to n do
for j:=1 to n do
if map[i,j]=0 then map[i,j]:=infinite;
for i:=1 to n do
for j:=1 to k do
minf[i,j]:=-infinite;
end;
procedure sssp;
var
i,j:longint;
min:longint=0;
minj:longint=1;
begin
for i:=1 to n-1 do
begin
for j:=1 to n do if not hash[j] then
begin
if ( min+map[minj,j] = dist[j] ) and ( father[j] > minj ) then
father[j]:=minj
else if min+map[minj,j] < dist[j] then
begin
dist[j]:=min + map[minj,j];
father[j]:=minj;
end;
end;
min:=infinite;
for j:=1 to n do if not hash[j] and (dist[j]<min) then
begin
minj:=j;
min:=dist[j];
end;
tree[ minj ].right:=tree[ father[minj] ].left;
tree[ father[minj] ].left:=minj;
hash[ minj ]:=true;
end;
end;
function solve(x,y:longint):longint; //(node,cost)
procedure update(var t1:longint;t2:longint);
begin
if t1<t2 then t1:=t2;
end;
var
ans:longint=-infinite;
i,t:longint;
begin
if minf[x,y]<>-infinite then exit(minf[x,y]);
if y>=cost[x] then ans:=attk[x];
if tree[x].left>0 then update(ans,solve(tree[x].left,y)+attk[x]);
if tree[x].right>0 then
begin
update(ans,solve(tree[x].right,y));
if y-cost[x]>0 then
update(ans,solve(tree[x].right,y-cost[x])+attk[x]);
end;
if (tree[x].left>0) and (tree[x].right>0) then
for i:=1 to y-1 do
update(ans,solve(tree[x].left,i)+solve(tree[x].right,y-i)+attk[x]);
minf[x,y]:=ans;
exit(minf[x,y]);
end;
procedure writep;
var
ans:longint=-infinite;
i,j:integer;
begin
for i:=0 to k do
if solve(1,i)>ans then ans:=solve(1,i);
writeln(ans);
{===For Debug===
for i:=1 to n do
begin
for j:=1 to k do write(minf[i,j]:3);
writeln;
end;
for i:=1 to n do writeln(tree[i].left,' ',tree[i].right);
}
end;
{====main====}
begin
assign(input,'wolf.in');
reset(input);
assign(output,'wolf.out');
rewrite(output);
readp;
init;
sssp;
writep;
close(input);
close(output);
end.
Problem 4
program garden;
const
dir:array[1..4,1..2]of integer=
((1,0),(0,1),(-1,0),(0,-1));
type
arr=array[1..10]of integer;
rec=record x,y:integer;end;
var
map:array[0..11,0..11]of boolean;
ans:array[1..100]of rec;
n,m,max:integer;
step:integer=1;
state:arr;
procedure readp;
var
i,j:integer;
ch:char;
begin
readln(m,n);
for i:=1 to n do
begin
for j:=1 to m do
begin
read(ch);
map[i,j]:=(ch='1');
inc(max,ord( map[i,j] ))
end;
readln;
end;
end;
procedure writep;
var
i:integer;
begin
for i:=1 to step do
writeln( '(' , ans[i].x , ',' , ans[i].y , ')' );
end;
procedure solve(x,y:integer);
var
tx,ty,d:integer;
step_cache:integer;
state_cache:arr;
begin
step_cache:=step;
state_cache:=state;
if step=max then
begin
writep;
exit;
end;
for d:=1 to 4 do
begin
tx:=x+dir[d,1];
ty:=y+dir[d,2];
while map[tx,ty] and ( not state[tx] and(1 shl (ty-1) )>0) do
begin
inc(step);
ans[step].x:=tx;
ans[step].y:=ty;
state[tx]:=state[tx] or ( 1 shl (ty-1) );
tx:=tx+dir[d,1];
ty:=ty+dir[d,2];
end;
tx:=tx-dir[d,1];
ty:=ty-dir[d,2];
if (tx<>x) or (ty<>y) then solve(tx,ty);
state:=state_cache;
step:=step_cache;
end;
end;
{====main====}
var
i,j:integer;
begin
assign(input,'garden.in');
reset(input);
assign(output,'garden.out');
rewrite(output);
readp;
for i:=1 to n do
for j:=1 to m do
if map[i,j] then
begin
ans[1].x:=i;
ans[1].y:=j;
state[i]:=1 shl (j-1);
solve(i,j);
state[i]:=0;
end;
close(input);
close(output);
end.
依然欢迎大家来挑错
Matrix67 |
2008-5-11 18:12 | 
