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.