Перейти к содержимому


Теория(алгоритмы)


В теме одно сообщение

#1 yanush

    Пользователь

  • Пользователи
  • PipPip
  • 22 сообщений

Отправлено 04 июня 2013 - 11:41

ФУНКЦИЯ НОД
function nod(x,y:longint):longint;
begin
while (x>0) and (y>0) do
if x>y then x:=x mod y
    	else y:=y mod x;
    	nod:=x+y;
end;

ПРОСТОЕ ЧИСЛО

 function pr(x:longint):boolean;
  var d:longint;
begin
  if x mod 2 =0 then pr:=(x=2)
            	else
				begin
              	d:=3;
              	while (d*d<=x)and(x mod d <>0) do
              	d:=d+2;
              	pr:=(d*d>x)and(x<>1);
				end;
end;


МАССИВ КОНСТАНТ ХОДОВ КОНЯ

 
 
const si:array [1..8] of longint=(1,-1,2,2,1,-1,-2,-2);
  	sj:array [1..8] of longint=(2,2,1,-1,-2,-2,-1,1);



РЕШЕТО ЭРАТОСФЕНА

var b:array[2..100000] of longint;
	i,j,n:longint;
	begin
  	readln(n);
  	i:=2;
  	while i*i<= n do
   	begin
    	if b[i]=0 then begin
                    	j:=i*i;
                    	while j<=n do begin b[j]:=1;j:=j+i; end;
   					end;
    	if i=2 then i:=3 else i:=i+2;
   	end;
	end.

КУЧИ,ПРОСТО КУЧИ

 procedure swap(x,y:longint);
var z:int64;
  begin
   z:=a[x];a[x]:=a[y];a[y]:=z;
  end;
procedure sh_u(v:longint);
begin
  if v=1 then exit;
  if a[v]<a[v div 2] then begin swap(v,v div 2);sh_u(v div 2);end;
end;
procedure sh_d(v:longint);
var j:longint;
  begin
   j:=v;
   if(v*2<=n)and(a[v*2]<a[j])then j:=v*2;
   if(v*2+1<=n)and(a[v*2+1]<a[j])then j:=v*2+1;
   if j=v then exit;
   swap(j,v);sh_d(j);
  end;  
for i:=n downto 1 do sh_d(i);



ДЕЙКСТРА С КУЧЕЙ

var g:array of array of record x,z:int64;end;
	k,p,f,d,a:array[1..100000]of int64;
	n,m,x,y,z,st,fn,nm:int64;i,j:longint;
procedure swap(x,y:longint);
var z:int64;
  begin
   z:=p[a[x]];p[a[x]]:=p[a[y]];p[a[y]]:=z;
   z:=a[x];a[x]:=a[y];a[y]:=z;
  end;
procedure sh_u(x:int64);
  begin
   if x=1 then exit;
   if d[a[x]]>=d[a[x div 2]]then exit;
   swap(x,x div 2);sh_u(x div 2);
  end;
procedure sh_d(x:int64);
var j:int64;
  begin
   j:=x;
   if(x*2<=nm)and(d[a[j]]>d[a[x*2]])then j:=x*2;
   if(x*2+1<=nm)and(d[a[j]]>d[a[x*2+1]])then j:=x*2+1;
   if j=x then exit;
   swap(j,x);
   sh_d(j);
  end;
  begin
  assign(input,'input.txt');reset(input);
  assign(output,'output.txt');rewrite(output);
  readln(n,m);
  setlength(g,n+1);
  for i:=1 to m do
   begin
	readln(x,y,z);
	if x=y then continue;
	inc(k[x]);inc(k[y]);
	setlength(g[x],k[x]+1);
	setlength(g[y],k[y]+1);
	g[x,k[x]].x:=y;g[x,k[x]].z:=z;
	g[y,k[y]].x:=x;g[y,k[y]].z:=z;
   end;
  readln(st,fn);
  for i:=1 to n do d[i]:=maxlongint*1000000000;
  d[st]:=0;
  for i:=1 to n do
   begin
	a[i]:=i;p[i]:=i;sh_u(i);
   end;
  nm:=n;
  for j:=1 to n do
   begin
	x:=a[1];
	a[1]:=a[nm];p[a[1]]:=1;
	dec(nm);
	sh_d(1);f[x]:=1;
	for i:=1 to k[x] do
	if(f[g[x,i].x]=0)and(d[x]+g[x,i].z<d[g[x,i].x])
   	then begin
			d[g[x,i].x]:=d[x]+g[x,i].z;
			sh_u(p[g[x,i].x]);sh_d(p[g[x,i].x]);
        	end;
   end;
  if d[fn]=maxlongint*1000000000 then writeln(-1)
                          	else writeln(d[fn]);
end.


ДЛИНКА

function sum(a,b:string):string;
  var x,y,z:array [1..100] of longint;
  	i,f,nx,ny,nz:longint;c,s:string;
   begin
	nx:=length(a);ny:=length(B)/>/>/>/>/>/>/>/>/>;
	for i:=1 to 100 do begin x[i]:=0;y[i]:=0;z[i]:=0;end;c:='';s:='';
	for i:=1 to nx do val(a[i],x[nx-i+1],f);
	for i:=1 to ny do val(b[i],y[ny-i+1],f);
	if nx>ny then nz:=nx else nz:=ny;
	for i:=1 to nz do
	begin
  	z[i]:=z[i]+y[i]+x[i];
  	if z[i]>9 then begin z[i]:=z[i] mod 10;z[i+1]:=1;end;
	end;
	if z[nz+1]<>0 then nz:=nz+1;
	for i:=nz downto 1 do begin str(z[i],c);s:=s+c;end;
	sum:=s;
end;


УМНОЖЕНИЕ

function pr(a,b:string):string;
  var x:array[0..1000]of longint;
  	n,m,i,f,j,l,lb:longint; s,y:string;
   begin
	for i:=0 to 1000 do x[i]:=0;
	l:=length(a);lb:=length(B)/>/>/>/>/>/>/>/>/>;
	for i:=l downto 1 do
	for j:=lb downto 1 do
  	begin
   	val(a[i],m,f);val(b[j],n,f);
   	x[i+j]:=x[i+j]+(n*m);
   	x[i-1+j]:=x[i+j-1]+(x[i+j]div 10);
   	x[i+j]:=x[i+j] mod 10;
  	end;
   y:='';
   for i:=0 to l+lb do
	begin
	str(x[i],s); y:=y+s;
	end;
   while (y[1]='0')and(length(y)>1) do delete(y,1,1);
   pr:=y;
  end;


СОРТИРОВКА

 procedure qsort(l,r:longint);
  var i,j,x,z:int64;
   begin
	i:=l;j:=r;x:=a[random(r-l)+l];
	repeat
	while a[i]<x do inc(i);
	while a[j]>x do dec(j);
	if i<=j then begin
   				z:=a[i];a[i]:=a[j];a[j]:=z;
   				inc(i);dec(j);
              	end;
	until i>j;
	if i<r then qsort(i,r);
	if j>l then qsort(l,j);
   end;


ПО ДВУМ ПАРАМЕТРАМ

  procedure qsort(l,r:longint);
  var i,j,x,z,y:int64;
   begin
	i:=l;j:=r;z:=random(r-l)+l;x:=a[z];y:=b[z];
	repeat
	while(a[i]<x)or((a[i]=x)and(b[i]<y)) do inc(i);
	while(a[j]>x)or((a[j]=x)and(b[j]>y)) do dec(j);
	if i<=j then begin
   				z:=a[i];a[i]:=a[j];a[j]:=z;
   				z:=b[i];b[i]:=b[j];b[j]:=z;
   				inc(i);dec(j);
              	end;
	until i>j;
	if i<r then qsort(i,r);
	if j>l then qsort(l,j);
   end;


АНТИ СОРТИРОВКА

	a[1]:=1;a[2]:=4;
	a[3]:=2;a[4]:=3;
	for i:=5 to n do
	begin
  	p:=(1 + i) div 2;
  	a[i]:=a[p];
  	a[p]:=i;
	end;
	for i:=1 to n-1 do write(a[i],' ');
	write(a[i]);  


ПЕРЕСТАНОВКИ
 for i:=0 to n do p[i]:=i;
	while p[0]=0 do
	Begin
   	j:=n;while p[j-1]>p[j] do j:=j-1;
   	k:=n;while p[j-1]>p[k] do k:=k-1;
   	d:=p[k];p[k]:=p[j-1];p[j-1]:=d;
   	for i:=j to (n+j-1)div 2 do
    	begin  d:=p[i];p[i]:=p[n-i+j];p[n-i+j]:=d;end;
	end;


МИНИМАЛЬНОЕ ОСТОВНОЕ ДЕРЕВО(КРАСКАЛ С СНМ)

type zap =record x,y,z:longint;end;
 
var a:array[1..100000]of zap;
    p:array[1..100000]of longint;
    n,m,i,j:longint;ans:int64;
procedure qsort (l,r:longint);
var i,j,x:longint;q:zap;
  begin
    i:=l;
    j:=r;
    x:=a[random(r-l)+l].z;
    repeat
      while (a[i].z<x)do inc(i);
      while (a[j].z>x)do dec(j);
      if i<=j then begin
                    q:=a[i];a[i]:=a[j];a[j]:=q;inc(i);dec(j);
   				end;
    until i>j;
    if i<r then qsort(i,r);
    if l<j then qsort(l,j);
  end;
function get(v:longint):longint;
begin
  if p[v]=v then exit(v);
  p[v]:=get(p[v]);
  get:=p[v];
end;
procedure unite(x,y:longint);
begin
  if random(2)=1 then p[x]:=p[y]
				else p[y]:=p[x];
end;
begin
assign (input,'input.txt');reset (input);
assign (output,'output.txt');rewrite (output);
  readln (n,m);
  for i:=1 to m do readln(a[i].x,a[i].y,a[i].z);
  qsort(1,m);
  for i:=1 to n do p[i]:=i;
  j:=1;
  for i:=1 to n-1 do
   begin
    while get(a[j].x)=get(a[j].y)do inc(j);
    unite(get(a[j].x),get(a[j].y));
    ans:=ans+a[j].z;
   end;
  writeln(ans);
end.


#2 yanush

    Пользователь

  • Пользователи
  • PipPip
  • 22 сообщений

Отправлено 12 октября 2013 - 12:48

МОСТЫ В ГРАФЕ
procedure dfs(v:longint);
   var i:longint;
	begin
	f[v]:=1;inc(nm);p[nm]:=v;
	for i:=1 to k[v] do
  	if f[a[v,i]]=0 then begin
                              	dfs(a[v,i]);
                              	a[v,i]:=0;
         						end;
	end;
  procedure dfs1(v:longint);
   var i:longint;
	begin
	f[v]:=1;f1[v]:=nm;
	for i:=1 to k[v] do
  	if(a[v,i]<>0)and(f[a[v,i]]=0)then dfs1(a[v,i]);
	end;
 
//Ввод графа
 
	dfs(1);nm:=0;
	for i:=1 to n do f[i]:=0;
	for i:=1 to n do
	if f[p[i]]=0 then begin
             				inc(nm);
       	  				dfs1(p[i]);
                      	end;
	nm:=0;
	for i:=1 to m do
  	if f1[x[i]]<>f1[y[i]] then inc(nm);



ТОЧКИ СОЧЛЕНЕНИЯ В ГРАФЕ
  procedure dfs(v:longint);
   var i,count:longint;
	begin
	count:=0;inc(time);t[v]:=time;u[v]:=time;
	for i:=1 to k[v] do
  	if t[a[v,i]]=0 then begin
                 				inc(count);
                 				dfs(a[v,i]);
                 				u[v]:=min(u[a[v,i]],u[v]);
                 				if(v<>1)and(u[a[v,i]]=t[v])then f[v]:=1;
                            	end
                   	else u[v]:=min(t[a[v,i]],u[v]);
	if(v=1)and(count>1)then f[v]:=1;
	end;
//Ввод графа
   dfs(1);m:=0;
   for  i:=1 to n do
	if f[i]=1 then inc(m);
   writeln(m);
   for i:=1 to n do
	if f[i]=1 then writeln(i);


LCA Тарьяном

var a:array[1..100000]of array of record x,z:longint;end;
	b:array[1..100000]of array of record x,y:longint;end;
	ans:array[1..2000000]of int64;
	h,p,anc,f,k,k1:array[1..100000]of int64;
	n,m,i,j,x,y,z,zp:longint;
function get(v:longint):longint;
begin
  if p[v]=v then begin get:=v;exit;end;
  p[v]:=get(p[v]);
  get:=p[v];
end;
procedure unite(x,y,v:longint);
begin
  if random(2)=1 then begin anc[y]:=v;p[x]:=y;end
             	else begin anc[x]:=v;p[y]:=x;end;
end;
procedure dfs(v,h1:int64);
var i,x:longint;
begin
  p[v]:=v;f[v]:=1;anc[v]:=v;h[v]:=h1;
  for i:=1 to k[v] do
  if f[a[v,i].x]=0 then
   begin
	dfs(a[v,i].x,h1+a[v,i].z);
	unite(get(v),get(a[v,i].x),v);
   end;
  for i:=1 to k1[v] do
   if(f[b[v,i].x]=1)then
                 	begin
                  	x:=anc[get(b[v,i].x)];
                  	ans[b[v,i].y]:=abs(h[x]-h[b[v,i].x])+abs(h[v]-h[x]);
                 	end;
end;
   	begin
  assign(input,'input.txt'); reset(input);
  assign(output,'output.txt'); rewrite(output);
 	readln(n,zp);
  for i:=1 to n-1 do
	begin
   	readln(x,y,z);
   	inc(k[x]);inc(k[y]);
   	setlength(a[y],k[y]+1);setlength(a[x],k[x]+1);
   	a[x,k[x]].x:=y;a[y,k[y]].x:=x;
   	a[x,k[x]].z:=z;a[y,k[y]].z:=z;
	end;
  for i:=1 to zp do
	begin
   	readln(x,y);
   	inc(k1[x]);inc(k1[y]);
   	setlength(b[y],k1[y]+1);setlength(b[x],k1[x]+1);
   	b[x,k1[x]].y:=i;b[y,k1[y]].y:=i;
   	b[x,k1[x]].x:=y;b[y,k1[y]].x:=x;
	end;
 	dfs(1,0);
 	for i:=1 to zp do writeln(ans[i]);
  end.






Количество пользователей, читающих эту тему: 1

0 пользователей, 1 гостей, 0 анононимных