Listing: REZISTENTE.PAS
{$M 65000,0,655360}
program rezistenta_echivalenta;
const ni='REZ.IN';
no='REZ.OUT';
type sir=array[1..10000] of Integer;
psir=^sir;
vect=array[1..10000] of Real;
pvect=^vect;
var grad,start,fin,a,b,aa,bb,s,v1,v2:psir;
v, vv:pvect;
f:Text;
n,m,nm,i,j,x,y,pz,med,li,ls:Integer;
aux,nod,nnod,ad,capat,inceput:Integer;
sfarsit,p,sursa,dest:Integer;
r,suma,k,auxr:Real;
procedure load;
begin
New(grad); New(start);
New(fin); New(s);
New(a); New(b);
New(v); New(aa);
New(bb); New(vv);
New(v1); New(v2);
Assign(f,ni); Reset(f);
Readln(f,n);
Readln(f,sursa,dest);
m:=0;
while not Seekeof(f) do
begin
Readln(f,i,j,k);
if i>j
then
begin
aux:=i; i:=j; j:=aux
end;
m:=m+1;
a^[m]:=i;
b^[m]:=j;
v^[m]:=k
end;
Close(f);
m:=m+1;
a^[m]:=sursa;
b^[m]:=n+1;
v^[m]:=0;
m:=m+1;
a^[m]:=dest;
b^[m]:=n+2;
v^[m]:=0;
n:=n+2
end;
procedure qsort(li,ls:Integer);
var i,med:Integer;
begin
i:=li;
j:=ls;
med:=a^[(li+ls) shr 1];
repeat
while a^[i]<med do i:=i+1;
while a^[j]>med do j:=j-1;
if i<=j
then
begin
aux:=a^[i]; a^[i]:=a^[j]; a^[j]:=aux;
aux:=b^[i]; b^[i]:=b^[j]; b^[j]:=aux;
auxr:=v^[i]; v^[i]:=v^[j]; v^[j]:=auxr;
i:=i+1;
j:=j-1
end
until i>j;
if li<j
then qsort(li,j);
if i<ls
then qsort(i,ls)
end;
procedure qqsort(li,ls:Integer);
var i,j,med:Integer;
begin
i:=li;
j:=ls;
med:=b^[(li+ls) shr 1];
repeat
while b^[i]<med do i:=i+1;
while b^[j]>med do j:=j-1;
if i<=j
then
begin
aux:=a^[i]; a^[i]:=a^[j]; a^[j]:=aux;
aux:=b^[i]; b^[i]:=b^[j]; b^[j]:=aux;
auxr:=v^[i]; v^[i]:=v^[j]; v^[j]:=auxr;
i:=i+1;
j:=j-1
end
until i>j;
if li<j
then qqsort(li,j);
if i<ls
then qqsort(i,ls)
end;
procedure sort;
begin
qsort(1,m);
x:=1;
while x<=m do
begin
y:=x;
while (a^[y]=a^[x]) and (y<=m) do y:=y+1;
qqsort(x,y-1);
x:=y
end
end;
procedure paralel;
begin
nm:=0;
x:=1;
while x<=m do
begin
y:=x;
while (a^[y]=a^[x]) and (b^[y]=b^[x])
and (y<=m) do
y:=y+1;
if y=x+1
then r:=v^[x]
else
begin
r:=0;
for i:=x to y-1 do r:=r+1/v^[i];
r:=1/r
end;
nm:=nm+1;
aa^[nm]:=a^[x];
bb^[nm]:=b^[x];
vv^[nm]:=r;
x:=y
end;
m:=nm;
for i:=1 to m do
begin
a^[i]:=aa^[i];
b^[i]:=bb^[i];
v^[i]:=vv^[i]
end
end;
procedure det;
begin
for i:=1 to n do
begin
start^[i]:=0;
fin^[i]:=0
end;
x:=1;
while x<=m do
begin
y:=x;
while (a^[y]=a^[x]) and (y<=m) do
y:=y+1;
nod:=a^[x];
start^[nod]:=x;
fin^[nod]:=y-1;
x:=y
end;
for i:=1 to n do
grad^[i]:=0;
for i:=1 to m do
begin
nod:=a^[i];
nnod:=b^[i];
grad^[nod]:=grad^[nod]+1;
grad^[nnod]:=grad^[nnod]+1
end
end;
procedure cauta(li,ls:Integer);
begin
if li<=ls
then
begin
med:=(li+ls) shr 1;
if nnod=b^[med]
then pz:=med
else
if nnod<b^[med]
then cauta(li,med-1)
else cauta(med+1,ls)
end
end;
procedure tr_stea;
begin
for i:=1 to m do s^[i]:=0;
ad:=0;
nm:=0;
for i:=1 to n do
if grad^[i]>2
then
if not((start^[i]=0) and (fin^[i]=0))
then
for x:=start^[i] to fin^[i]-1 do
if s^[x]=0
then
for y:=x+1 to fin^[i] do
if s^[y]=0
then
begin
nod:=b^[x];
nnod:=b^[y];
if (grad^[nod]>2) and
(grad^[nnod]>2)
then
if not((start^[nod]=0) and
(fin^[nnod]=0))
then
begin
li:=start^[nod];
ls:=fin^[nod];
pz:=0;
cauta(li,ls);
if pz<>0
then
if s^[pz]=0
then
begin
suma:=v^[x]+v^[y]+v^[pz];
ad:=ad+1;
nm:=nm+1;
aa^[nm]:=i;
bb^[nm]:=n+ad;
vv^[nm]:=(v^[x]*v^[y])/suma;
nm:=nm+1;
aa^[nm]:=nod;
bb^[nm]:=n+ad;
vv^[nm]:=(v^[x]*v^[pz])/suma;
nm:=nm+1;
aa^[nm]:=nnod;
bb^[nm]:=n+ad;
vv^[nm]:=(v^[y]*v^[pz])/suma;
s^[x]:=1;
s^[y]:=1;
s^[pz]:=1;
y:=fin^[i]
end
end
end;
n:=n+ad;
for i:=1 to m do
if s^[i]=0
then
begin
nm:=nm+1;
aa^[nm]:=a^[i];
bb^[nm]:=b^[i];
vv^[nm]:=v^[i]
end;
for i:=1 to m do
begin
a^[i]:=aa^[i];
b^[i]:=bb^[i];
v^[i]:=vv^[i]
end
end;
procedure rec(nod,tata:Integer);
var ch:Boolean;
begin
nnod:=tata;
ch:=false;
if nod>nnod
then
begin
aux:=nod; nod:=nnod; nnod:=aux;
ch:=true
end;
li:=start^[nod];
ls:=fin^[nod];
cauta(li,ls);
s^[pz]:=1;
suma:=suma+v^[pz];
if ch
then
begin
aux:=nod; nod:=nnod; nnod:=aux
end;
if grad^[nod]=2
then
if v1^[nod]=tata
then rec(v2^[nod],nod)
else rec(v1^[nod],nod)
else capat:=nod
end;
procedure
serie;
begin
for i:=1 to n do
begin v1^[i]:=0; v2^[i]:=0 end;
for i:=1 to m do
begin
nod:=a^[i]; nnod:=b^[i];
if grad^[nod]=2
then
if v1^[nod]=0
then v1^[nod]:=nnod
else v2^[nod]:=nnod;
if grad^[nnod]=2
then
if v1^[nnod]=0 then v1^[nnod]:=nod
else v2^[nnod]:=nod
end;
for i:=1 to m do
s^[i]:=0;
nm:=0;
for i:=1 to m do
if s^[i]=0
then
begin
nod:=a^[i]; nnod:=b^[i]; p:=0;
if grad^[nod]=2 then p:=nod;
if grad^[nnod]=2 then p:=nnod;
if p<>0
then
begin
suma:=0;
rec(v1^[p],p);
inceput:=capat;
rec(v2^[p],p);
sfarsit:=capat;
nm:=nm+1;
if inceput>sfarsit
then
begin
aux:=inceput;
inceput:=sfarsit;
sfarsit:=aux
end;
aa^[nm]:=inceput; bb^[nm]:=sfarsit;
vv^[nm]:=suma
end
end;
for i:=1 to m do
if s^[i]=0
then
begin
nm:=nm+1;
aa^[nm]:=a^[i]; bb^[nm]:=b^[i];
vv^[nm]:=v^[i]
end;
m:=nm;
for i:=1 to m do
begin
a^[i]:=aa^[i]; b^[i]:=bb^[i];
v^[i]:=vv^[i]
end
end;
procedure scrie;
begin
Assign(f,no); Rewrite(f);
Writeln(f,Trunc(v^[1]*1000)/1000:0:3);
Close(f)
end;
Begin
load;
while m>1 do
begin
sort;
paralel;
det;
tr_stea;
sort;
det;
serie
end;
scrie
End.