Cây khung Archives - Kiến Thức 24h

Code QBMST được viết bằng thuật toán Kruskal Pascal Mình đã bỏ một số phần thừa trong sách TLGK Chuyên tin Thuật toán kruskal dưới đây được biểu diễn đồ thị bằng danh sách cạnh trong lí thuyết đồ thị:

const   fi='';
        nmax=15500;
type
        data=longint;

var     f:text;
        u,v,c:array[1..nmax] of data;
        root:array[1..nmax] of data;
        n,m:data;

procedure docfile;
var     i:data;
begin
        assign(f,fi); reset(f);
        readln(f,n,m);
        for i:=1 to m do
                readln(f,u[i],v[i],c[i]);
        close(f);
end;

procedure swap(var a,b:data);
var     z:data;
begin
        z:=a;
        a:=b;
        b:=z;
end;

procedure quicksort(l,r:data);
var i,j,mid:data;
        begin
                i:=l;
                j:=r;
                mid:=c[(l+r) div 2];
                repeat
                        while c[i] < mid do i:=i+1;
                        while c[j] > mid do j:=j-1;
                        if i<= j then
                                begin
                                        swap(u[i],u[j]);
                                        swap(c[i],c[j]);
                                        swap(v[i],v[j]);
                                        i:=i+1;
                                        j:=j-1;
                                end;
                until i>j;
                if i<r then quicksort(i,r);
                if j>l then quicksort(l,j);
        end;

function findroot(x:data):data;
begin
        if root[x]<>x then
                root[x]:=findroot(root[x]);
        exit(root[x]);
end;

procedure union(x,y:data);
begin
        root[x]:=y;
end;

procedure kruskal;
var     i,ur,uv:data;
        t:longint;
begin
        for i:=1 to n do root[i]:=i;
        t:=0;
        for i:=1 to m do
                begin
                        ur:=findroot(u[i]);
                        uv:=findroot(v[i]);
                        if ur<>uv then
                                begin
                                        union(ur,uv);
                                        t:=t+c[i];
                                end;
                end;
        writeln(t);
end;

begin
        docfile;
        Quicksort(1,m);
        kruskal;
end.

const fi='';

nmax=15500;

type

data=longint;

var f:text;

u,v,c:array[1..nmax] of data;

root:array[1..nmax] of data;

n,m:data;

procedure docfile;

var i:data;

begin

assign(f,fi); reset(f);

readln(f,n,m);

for i:=1 to m do

readln(f,u[i],v[i],c[i]);

close(f);

end;

procedure swap(var a,b:data);

var z:data;

begin

z:=a;

a:=b;

b:=z;

end;

procedure quicksort(l,r:data);

var i,j,mid:data;

begin

i:=l;

j:=r;

mid:=c[(l+r) div 2];

repeat

while c[i] < mid do i:=i+1;

while c[j] > mid do j:=j-1;

if i<= j then

begin

swap(u[i],u[j]);

swap(c[i],c[j]);

swap(v[i],v[j]);

i:=i+1;

j:=j-1;

end;

until i>j;

if i<r then quicksort(i,r);

if j>l then quicksort(l,j);

end;

function findroot(x:data):data;

begin

if root[x]<>x then

root[x]:=findroot(root[x]);

exit(root[x]);

end;

procedure union(x,y:data);

begin

root[x]:=y;

end;

procedure kruskal;

var i,ur,uv:data;

t:longint;

begin

for i:=1 to n do root[i]:=i;

t:=0;

for i:=1 to m do

begin

ur:=findroot(u[i]);

uv:=findroot(v[i]);

if ur<>uv then

begin

union(ur,uv);

t:=t+c[i];

end;

writeln(t);

end;

begin

docfile;

Quicksort(1,m);

kruskal;

end.

Code QBMST được viết bằng Prim Heap Pascal

const   fi='';
        nmax=11000;
        mmax=30000;
        maxc=50000;
type    data=longint;
var
        f:text;
        adj,adc:array[0..2*mmax+2] of data;
        tmp,tmpc,head,u,v,C,heap,pos,d:array[0..mmax+1] of data;
        dd:array[0..nmax+1] of boolean;
        n,m,k,s,t,nheap:data;

procedure swaps(u,v:data);
var     k,i,j:data;
begin
        k:=0;
        for i:=u to v do
                begin
                        inc(k);
                        tmp[k]:=adj[i];
                        tmpc[k]:=adc[i];
                end;
        for i:=u to v do
                begin
                        adj[i]:=tmp[k];
                        adc[i]:=tmpc[k];
                        dec(K);
                end;
end;

procedure swap(var a,b:data);
var     z:data;
begin
        z:=a;
        a:=b;
        b:=z;
end;

procedure upheap(i:data);
begin
        if (i div 2=0) or (d[heap[i]]>d[heap[i div 2]]) then exit;
        swap(heap[i],heap[i div 2]);
        swap(pos[heap[i]],pos[heap[i div 2]]);
        upheap(i div 2);
end;


procedure downheap(i:data);
var     j:data;
begin
        j:=i*2;
        if j>nHeap then exit;
        if (j<nHeap) and (d[heap[j]]>d[heap[j+1]]) then inc(j);
        if d[heap[i]]<=d[heap[j]] then exit;
        swap(heap[i],heap[j]);
        swap(pos[heap[i]],pos[heap[j]]);
        downheap(j);
end;

procedure push(x:data);
begin
        inc(nHeap);
        heap[nHeap]:=x;
        upheap(Nheap);
end;

function pop:data;
begin
        pop:=Heap[1];
        heap[1]:=heap[nheap];
        dec(nheap);
        downheap(1);
end;


Procedure update(i:longint);
Begin
        if (i=1) or (d[heap[i]]>d[heap[i div 2]]) then exit;
        swap(heap[i],heap[i div 2]);
        swap(pos[heap[i]],pos[heap[i div 2]]);
        update(i div 2);
End;

procedure docfile;
var     i,j:data;
begin
        assign(f,fi); reset(f);
        read(f,n,m);
        fillchar(head,sizeof(head),0);
        for i:=1 to m do
                begin
                        read(f,u[i],v[i],c[i]);
                        inc(head[u[i]]);
                        inc(head[v[i]]);
                end;
        for i:=1 to n+1 do
                head[i]:=head[i-1]+head[i];
        for i:=1 to m do
                begin
                        adj[head[u[i]]]:=v[i];
                        adc[head[u[i]]]:=c[i];
                        dec(head[u[i]]);

                        adj[head[v[i]]]:=u[i];
                        adc[head[v[i]]]:=c[i];
                        dec(head[v[i]]);
                end;
        close(f);
        for i:=1 to n do
        	swaps(head[i]+1,head[i+1]);
end;


procedure prim;
var     i,j,u,v,res:data;
begin
        for i:=1 to n do
                begin
                        heap[i]:=i;
                        pos[i]:=i;
                        d[i]:=maxc;
                end;
        d[1]:=0;
        fillchar(dd,sizeof(dd),false);
        nHeap:=n;
        Update(1);
        repeat
                u:=pop;
                dd[u]:=true;
                for v:=head[u]+1 to head[u+1] do
                        if (not dd[adj[v]]) and (d[adj[v]]>adc[v]) then
                                begin
                                        d[adj[v]]:=adc[v];
                                        upheap(pos[adj[v]]);
                                end;
        until nheap=0;
        res:=0;
        for i:=1 to n do
                res:=res+d[i];
        writeln(res);
end;

begin
        docfile;
        prim;
end.

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

const fi='';

nmax=11000;

mmax=30000;

maxc=50000;

type data=longint;

var

f:text;

adj,adc:array[0..2*mmax+2] of data;

tmp,tmpc,head,u,v,C,heap,pos,d:array[0..mmax+1] of data;

dd:array[0..nmax+1] of boolean;

n,m,k,s,t,nheap:data;

procedure swaps(u,v:data);

var k,i,j:data;

begin

k:=0;

for i:=u to v do

begin

inc(k);

tmp[k]:=adj[i];

tmpc[k]:=adc[i];

end;

for i:=u to v do

begin

adj[i]:=tmp[k];

adc[i]:=tmpc[k];

dec(K);

end;

procedure swap(var a,b:data);

var z:data;

begin

z:=a;

a:=b;

b:=z;

end;

procedure upheap(i:data);

begin

if (i div 2=0) or (d[heap[i]]>d[heap[i div 2]]) then exit;

swap(heap[i],heap[i div 2]);

swap(pos[heap[i]],pos[heap[i div 2]]);

upheap(i div 2);

end;

procedure downheap(i:data);

var j:data;

begin

j:=i*2;

if j>nHeap then exit;

if (j<nHeap) and (d[heap[j]]>d[heap[j+1]]) then inc(j);

if d[heap[i]]<=d[heap[j]] then exit;

swap(heap[i],heap[j]);

swap(pos[heap[i]],pos[heap[j]]);

downheap(j);

end;

procedure push(x:data);

begin

inc(nHeap);

heap[nHeap]:=x;

upheap(Nheap);

end;

function pop:data;

begin

pop:=Heap[1];

heap[1]:=heap[nheap];

dec(nheap);

downheap(1);

end;

Procedure update(i:longint);

Begin

if (i=1) or (d[heap[i]]>d[heap[i div 2]]) then exit;

swap(heap[i],heap[i div 2]);

swap(pos[heap[i]],pos[heap[i div 2]]);

update(i div 2);

End;

procedure docfile;

var i,j:data;

begin

assign(f,fi); reset(f);

read(f,n,m);

fillchar(head,sizeof(head),0);

for i:=1 to m do

begin

read(f,u[i],v[i],c[i]);

inc(head[u[i]]);

inc(head[v[i]]);

end;

for i:=1 to n+1 do

head[i]:=head[i-1]+head[i];

for i:=1 to m do

begin

adj[head[u[i]]]:=v[i];

adc[head[u[i]]]:=c[i];

dec(head[u[i]]);

adj[head[v[i]]]:=u[i];

adc[head[v[i]]]:=c[i];

dec(head[v[i]]);

end;

close(f);

for i:=1 to n do

swaps(head[i]+1,head[i+1]);

end;

procedure prim;

var i,j,u,v,res:data;

begin

for i:=1 to n do

begin

heap[i]:=i;

pos[i]:=i;

d[i]:=maxc;

end;

d[1]:=0;

fillchar(dd,sizeof(dd),false);

nHeap:=n;

Update(1);

repeat

u:=pop;

dd[u]:=true;

for v:=head[u]+1 to head[u+1] do

if (not dd[adj[v]]) and (d[adj[v]]>adc[v]) then

begin

d[adj[v]]:=adc[v];

upheap(pos[adj[v]]);

end;

until nheap=0;

res:=0;

for i:=1 to n do

res:=res+d[i];

writeln(res);

end;

begin

docfile;

prim;

end.

Cây khung

Cây khung nhỏ nhất QBMST spoj: Kruskal, Prim heap

UPGRANET spoj – VOI 2011 Nâng cấp mạng

BCDAISY spoj PTIT – Chú bò hư hỏng

BCBIN spoj PTIT – Các thùng nước

Cấu trúc dữ liệu Disjoint Sets

FWATER spoj – Tưới nước đồng cỏ

bài giải NKRACING spoj – Vòng đua F1