ứng dụng mảng đánh dấu Archives

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.

ứng dụng mảng đánh dấu

Giải đề thi Lập trình hướng đối tượng UIT – Đề HK2 2016-2017

[C++ Quay lui] Liệt kê hoán vị các số từ 1 đến n

[UpCoder] LOGIN_UP2 – Xác nhận Upcoder 2

Complete The Word – Codeforces 716B (Div. 2)

Kinh nghiệm khi thi HSG môn tin học bằng pascal

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

MESSAGE Spoj – Truyền tin

BANHCHUNG NTU – Nấu bánh chưng

VBGRASS spoj – Bãi cỏ ngon nhất

NKINV spoj – Dãy nghịch thế (cây IT)