基础代码汇总整理 for NOIP 2009 修订版(上)

修订版序言
NOIP2009出乎意料地死掉了。不能说没有没发挥出来的地方，但我确实可能还有很多需要完善的地方。也许是自以为省一已经是囊中之物，有些不知天高地厚了吧！不过既然已经努力过了我也就没什么遗憾了。跟我的学长分析了一下，我这个分数还有一点点省选翻盘的希望……那就试试吧！
这个在OIBH上发过，也很高兴大家能为我提出宝贵的意见和建议。这也是我能继续进步的基础。以后我会在这里发点菜鸟教程，希望能为各位初学者一点点帮助。至少能让你从不会敲代码进步到会敲代码。
这次修订版要一下的改动：
1． 高精度乘法中有一个错误。“>=”打成了“>”。
2． 增加了一个求快速幂。
3． 二路归并排序增加了求逆序对个数计为ans，同时也换了个风格。

十进制转换K进制
function dectok(x,k:longint):string;
const alph='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var st:string;
begin
st:='';
while x<>0 do
begin
st:=alph[x mod k+1]+st;
x:=x div k;
end;
exit(st);
end;

K进制转换十进制
function ktodec(st:string; k:longint):longint;
const alph='012456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var i,j,ans:longint;
begin
ans:=0;
j:=1;
for i:=length(st) downto 1 do
begin
inc(ans,j*(pos(st[i],alph)-1));
j:=j*k;
end;
exit(ans);
end;

欧几里得算法
function gcd(a,b:longint):longint;
begin
if b=0 then exit(a)
else exit(gcd(b,a mod b));
end;

求最小公倍数
function lcm(a,b:longint):longint;
begin
exit(a div gcd(a,b) *b);
end;

判断质数
function judgeprime(x:longint);
var i:longint;
begin
if x=1 then exit(false);
for i:=2 to trunc(sqrt(x)) do
if x mod i=0 then
exit(false);
exit(true);
end;

生成质数表
procedure makeprime;
var i,j:longint;
begin
fillchar(f,sizeof(f),0);
f[1]:=true;
for i:=2 to n do
if (not f[i]) and (i<10000) then
begin
j:=i*i;
while j<=n do
begin
f[j]:=true;
inc(j,i);
end;
end;
end;

快速幂
function calc(x:qword):qword;
begin
if x=0 then exit(1);
if x=1 then exit(2);
if odd(x) then exit(2*sqr(calc((x-1) div 2)) mod p)
else exit(sqr(calc(x div 2)) mod p);
exit(calc(x div 2)*calc(x-x div 2) mod p);
end;

简单高精度运算系列
procedure change(st:string; var x:array of longint);
begin
x[0]:=0;
while length(st)>4 do
begin
inc(x[0]);
val(copy(st,length(st)-3,4),x[x[0]]);
delete(st,length(st)-3,4);
end;
inc(x[0]);
val(st,x[x[0]]);
end;

function compare(a,b:array of longint):boolean;
var i:longint;
begin
if a[0]>b[0] then exit(true);
if a[0]<b[0] then exit(false);
for i:=a[0] downto 1 do
if a[i]>b[i] then exit(true)
else if a[i]<b[i] then exit(false);
exit(true);
end;

procedure highplus(a,b:array of longint; var c:array of longint);
var i:longint;
begin
fillchar(c,sizeof(c),0);
if a[0]>b[0] then c[0]:=a[0]
else c[0]:=b[0];
for i:=1 to c[0] do
inc(c[i],a[i]+b[i]);
for i:=1 to c[0] do
if c[i]>=10000 then
begin
dec(c[i],10000);
inc(c[i+1]);
end;
while c[c[0]+1]>0 do inc(c[0]);
end;

procedure highminus(a,b:array of longint; var c:array of longint);
var i:longint;
begin
fillchar(c,sizeof(c),0); c[0]:=a[0];
for i:=1 to c[0] do
inc(c[i],a[i]-b[i]);
for i:=1 to c[0] do
if c[i]<0 then
begin
inc(c[i],10000);
dec(c[i+1]);
end;
while (c[0]<>1)and(c[c[0]]=0) do dec(c[0]);
end;

procedure highmulti(a,b:array of longint; var c:array of longint);
var i,j:longint;
begin
fillchar(c,sizeof(c),0); c[0]:=a[0]+b[0]-1;
for i:=1 to a[0] do
for j:=1 to b[0] do
inc(c[i+j-1],a[i]*b[j]);
for i:=1 to c[0] do
if c[i]>=10000 then
begin
inc(c[i+1],c[i] div 10000);
c[i]:=c[i] mod 10000;
end;
while c[c[0]+1]>0 do inc(c[0]);
end;

procedure highout(x:array of longint);
var i:longint;
begin
write(x[x[0]]);
for i:=x[0]-1 downto 1 do
begin
if x[i]<1000 then write(0);
if x[i]<100 then write(0);
if x[i]<10 then write(0);
write(x[i]);
end;
writeln;
end;

表达式求值
const num='0123456789';
sym='+-*/()@';
com:array[1..7,1..7] of longint=((1,1,-1,-1,-1,1,1),
(1,1,-1,-1,-1,1,1),
(1,1,1,1,-1,1,1),
(1,1,1,1,-1,1,1),
(-1,-1,-1,-1,-1,0,2),
(1,1,1,1,2,1,1),
(-1,-1,-1,-1,-1,2,0));
function calc(suf:string):double;
var stack:array[1..100] of double;
i,top:longint;
x:double;
ch:char;
begin
i:=1; ch:=suf[1]; top:=0;
while ch<>'@' do
begin
case ch of
'+':
begin
x:=stack[top-1]+stack[top];
dec(top,2);
end;
'-':
begin
x:=stack[top-1]-stack[top];
dec(top,2);
end;
'*':
begin
x:=stack[top-1]*stack[top];
dec(top,2);
end;
'/':
begin
x:=stack[top-1]/stack[top];
dec(top,2);
end;
'0'..'9':
begin
x:=0;
while ch<>' ' do
begin
x:=x*10+pos(ch,num)-1;
inc(i);
ch:=suf[i];
end;
end
end;
inc(top);
stack[top]:=x;
inc(i);
ch:=suf[i];
end;
exit(stack[top]);
end;

procedure turn(var mid,suf:string);
var stack:array[1..100] of longint;
i,top,w:longint;
ch:char;
begin
mid:=mid+' @'; suf:='';
stack[1]:=7;
i:=1; top:=1;
ch:=mid[1];
while ch<>'@' do
begin
if pos(ch,num)<>0 then
begin
while pos(ch,num)<>0 do
begin
suf:=suf+ch;
inc(i);
ch:=mid[i];
end;
suf:=suf+' ';
end;
if pos(ch,sym)<>0then
begin
w:=stack[top];
while com[w,pos(ch,sym)]=1 do
begin
suf:=suf+sym[w];
dec(top);
w:=stack[top];
end;
if com[w,pos(ch,sym)]=-1 then
begin
inc(top);
stack[top]:=pos(ch,sym);
end
else
dec(top);
end;
inc(i);
ch:=mid[i];
end;
w:=stack[top];
while w<>7 do
begin
suf:=suf+sym[w];
dec(top);
w:=stack[top];
end;
suf:=suf+'@';
end;

格拉汉扫除法
function direction(a,b,c:situ):real;
begin
exit((a.x-c.x)*(b.y-c.y)-(a.y-c.y)*(b.y-c.y));
end;
function dist(a,b:situ):real;
begin
exit(sqrt(sqr(a.x-b.x)+sqr(a.y-b.y));
end;
procedure polarangle(s,t:longint);
var l,r:longint;
key,tmp:situ;
begin
l:=s; r:=t; key:=p[random(t-s+1)+s];
while l<=r do
begin
while (direction(p[l],key,p[1])>0)or
((direction(p[l],key,p[1])=0)and(dist(p[l],p[1])<dist(key,p[1]))) do inc(l);
while (direction(p[r],key,p[1])<0)or
((direction(p[r],key,p[1])=0)and(dist(p[r],p[1])>dist(key,p[1]))) do dec(r);
if l<=r then
begin
tmp:=p[l];
p[l]:=p[r];
p[r]:=tmp;
inc(l);
dec(r);
end;
end;
if s<r then qsort(s,r);
if l<t then qsort(l,t);
end;
procedure getvex;
var i:longint;
tmp:situ;
begin
for i:=2 to n do
if (p[i].y<p[1].y)or((p[i].y=p[1].y)and(p[i].x<p[1].x)) then
begin
tmp:=p[1];
p[1]:=p[i];
p[i]:=tmp;
end;
end;
procedure graham;
var i:longint;
begin
getvex;
randomize;
polarangle(2,n);
stack[0]:=2;
stack[1]:=1;
stack[2]:=2;
for i:=3 to n do
begin
while (stack[0]>1)and(direction(p[i],p[stack[stack[0]]],p[stack[stack[0]-1]])>=0) do
dec(stack[0]);
inc(stack[0]);
stack[stack[0]]:=i;
end;
ans:=dist(p[stack[stack[0]]],p[stack[1]]);
for i:=1 to stack[0]-1 do ans:=ans+dist(p[stack[i]],p[stack[i+1]]);
end;

判断线段相交
function segment(a,b,c:situ):boolean;
begin
if (min(a.x,b.x)<=c.x)and(max(a.x,b.x)>=c.x)and
(min(a.y,b.y)<=c.y)and(max(a.y,b.y)>=c.y) then
exit(true);
exit(false);
end;

function intersect(a,b,c,d:situ):boolean;
var da,db,dc,dd:real;
begin
da:=direction(c,d,a); db:=direction(c,d,b);
db:=direction(a,b,c); dd:=direction(a,b,d);
if (da*db<-(1e-16)) and (dc*dd<-(1e-16)) then exit(true);
if (abs(da)<1e-16) and segment(c,d,a) then exit(true);
if (abs(db)<1e-16) and segment(c,d,b) then exit(true);
if (abs(dc)<1e-16) and segment(a,b,c) then exit(true);
if (abs(dd)<1e-16) and segment(a,b,d) then exit(true);
exit(false);
end;

弗洛伊德算法
procedure floyd;
var i,j,k:longint;
begin
for i:=1 to n do
for j:=1 to n do
if g[i,j]<>0 then dist[i,j]:=g[i,j]
else dist[i,j]:=maxlongint;
for k:=1 to n do
for i:=1 to n do
for j:=1 to n do
if (dist[i,k]<>maxlongint)and(dist[k,j]<>maxlongint)and
(dist[i,k]+dist[k,j]<dist[i,j]) then
dist[i,j]:=dist[i,k]+dist[k,j];
end;

SPFA算法
procedure spfa(s:longint);
var vis:array[1..100] of boolean;
que:array[0..99] of longint;
i,u,open,clo:longint;
begin
fillchar(vis,sizeof(vis),0);
for i:=1 to n do dist[i]:=maxlongint;
open:=0; clo:=1;
dist[s]:=0; vis[s]:=true; que[1]:=s;
while open<>clo do
begin
open:=(open+1) mod n;
u:=que[open];
vis[u]:=false;
for i:=1 to n do
if (g[u,i]<>0) and (dist[u]+g[u,i]<dist[i]) then
begin
if not vis[i] then
begin
clo:=(clo+1) mod n;
que[clo]:=u;
vis[clo]:=true;
end;
dist[i]:=dist[u]+g[u,i];
end;
end;
end;

克鲁斯卡尔算法
procedure kruskal;
var father:array[1..100] of longint;
i,get:longint;

function find(i:longint):longint;
begin
if father[i]=i then exit(i)
else father[i]:=find(father[i]);
exit(father[i]);
end;

procedure union(i,j:longint);
var u,v:longint;
begin
v:=find(i);
u:=find(j);
father[v]:=u;
end;

begin
qsort(1,e);
get:=0;
for i:=1 to n do father[i]:=i;
for i:=1 to e do
if find(edge[i].u)<>find(edge[i].v) then
begin
union(edge[i].u,edge[i].v);
inc(ans,edge[i].data);
inc(get);
if get=n-1 then exit;
end;
end;

Kosaraju算法
procedure kosaraju;
var vis:array[1..100] of boolean;
order:array[1..100] of longint;
i,time:longint;

procedure forthdfs(u:longint);
var i:longint;
begin
vis[u]:=true;
for i:=1 to n do
if g[u,i] and (not vis[i]) then
forthdfs(i);
inc(time);
order[time]:=u;
end;

procedure backdfs(u:longint);
var i:longint;
begin
vis[u]:=true;
for i:=1 to n do
if g[i,u] and (not vis[i]) then
backdfs(i);
fill[u]:=color;
end;

begin
fillchar(vis,sizeof(vis),0);
time:=0;
for i:=1 to n do
if not vis[i] then
forthdfs(i);
fillchar(vis,sizeof(vis),0);
color:=0;
for i:=time downto 1 do
if not vis[order[i]] then
begin
inc(color);
backdfs(order[i]);
end;
end;

最短增广路算法
procedure sap(s,t:longint);
var dist,dsum,nowvex,pre,data:array[0..100] of longint;
i,j,delta,mintmp,minvex:longint;
flag:boolean;
begin
fillchar(dist,sizeof(dist),0);
for i:=1 to n do nowvex[i]:=1;
dsum[0]:=n; delta:=maxlongint; i:=s;
while dist[s]<n do
begin
flag:=false; data[i]:=delta;
for j:=nowvex[i] to n do
if (c[i,j]>0) and (dist[j]+1=dist[i]) then
begin
flag:=true;
nowvex[i]:=j;
pre[j]:=i;
if delta>c[i,j] then delta:=c[i,j];
i:=j;
if i=t then
begin
inc(maxflow,delta);
while i<>s do
begin
dec(c[pre[i],i],delta);
inc(c[i,pre[i]],delta);
i:=pre[i];
end;
i:=s; delta:=maxlongint;
end;
break;
end;
if flag then continue;
dec(dsum[dist[i]]);
if dsum[dist[i]]=0 then exit;
mintmp:=n-1;
for j:=1 to n do
if (c[i,j]>0) and (dist[j]<mintmp) then
begin
mintmp:=dist[j];
minvex:=j;
end;
dist[i]:=mintmp+1;
nowvex[i]:=minvex;
inc(dsum[dist[i]]);
if i<>s then i:=pre[i];
delta:=data[i];
end;
end;

匈牙利算法
function hungary(s:longint):boolean;
var i:longint;
begin
for i:=1 to m do
if g[s,i] and (not vis[i]) then
begin
vis[i]:=true;
if link[i]=0 then
begin
link[i]:=s;
exit(true);
end
else if hungary(link[i]) then
begin
link[i]:=s;
exit(true);
end;
end;
exit(false);
end;

KM算法
function find(k:longint):longint;
var i:longint;
begin
x[k]:=true;
for i:=1 to n do
if (not y[i]) and (lx[k]+ly[i]=g[k,i]) then
begin
y[i]:=true;
if link[i]=0 then
begin
link[i]:=k;
exit(true);
end
else if find(link[i]) then
begin
link[i]:=k;
exit(true);
end;
end;
exit(false);
end;
procedure km;
var i,j,k,d:longint;
begin
fillchar(lx,sizeof(lx),0);
fillchar(ly,sizeof(ly),0);
for i:=1 to n do
for j:=1 to n do
if g[i,j]>lx[i] then
lx[i]:=g[i,j];
for k:=1 to n do
repeat
fillchar(x,sizeof(x),0);
fillchar(y,sizeof(y),0);
if find(k) then break;
d:=maxlongint;
for i:=1 to n do
if x[i] then
for j:=1 to n do
if not y[j] then
if lx[i]+ly[j]-g[i,j]<d then
d:=lx[i]+ly[j]-g[i,j];
for i:=1 to n do
begin
if x[i] then dec(lx[i],d);
if y[i] then inc(ly[i],d);
end;
until false;
end;