Listing: APM.PAS
{$M 65000,0,655360} 
 program graf_apm; 
 const fin='apm.in'; 
 fout='apm.out'; 
 max=100; 
 type muchie=
record  
 i,j:Byte; 
 c:Integer 
 end; 
 sir=array[1..max*max div 2] of Integer; 
 var a:array[1..3*max] of muchie; 
 sel:array[1..max] of Boolean; 
 inceput,sfarsit:array[0..max] of Integer; 
 b:array[1..max*max div 2] of muchie; 
 v:^sir; 
 n,m,pz:Integer; 
 
 procedure citire; 
 var f:Text; 
 i:Integer; 
 
begin  
 Assign(f,fin); Reset(f); 
 Readln(f,n); 
 for i:=1 to n-1 
do  
  
begin  
 Readln(f,a[i].i,a[i].j,a[i].c); 
 a[i+n-1].i:=a[i].j; 
 a[i+n-1].j:=a[i].i; 
 a[i+n-1].c:=a[i].c; 
 a[i+2*n-2]:=a[i] 
 end; 
 m:=0; 
 New(v); 
 while not Seekeof(f) 
do  
 begin 
 Inc(m); 
 Read(f,v^[m]) 
 end; 
 Close(f) 
 end; 
 
 procedure sort1(l,r:Integer); 
 var i,j,x:Byte; 
 y:muchie; 
 
begin  
 i:=l; j:=r; 
 x:=a[(l+r) div 2].i; 
 
repeat  
 while a[i].i<x do Inc(i); 
 while x<a[j].i do Dec(j); 
 if i<=j 
 
then  
  
begin  
 y:=a[i]; 
 a[i]:=a[j]; a[j]:= y; 
 Inc(i); Dec(j) 
 
end  
 until i>j; 
 if l<j then sort1(l,j); 
 if i<r then sort1(i,r) 
 end; 
 procedure recurs(nivel,st,op:Byte; 
 val:Integer); 
 var i:Integer; 
 
begin  
 if (st<op) and (nivel>2) 
 
then  
 begin 
 Inc(pz); b[pz].i:=st; 
 b[pz].j:=op; b[pz].c:=val 
 end; 
 for i:=inceput[op] to sfarsit[op] 
do  
 if not(sel[a[i].j]) 
 
then  
  
begin  
 sel[a[i].j]:=true; 
 if val<a[i].c 
 then recurs(nivel+1,st,a[i].j,a[i].c) 
 else recurs(nivel+1,st,a[i].j,val); 
 sel[a[i].j]:=false 
 
end  
 end; 
 
  procedure calcul_muchii; 
 var i,j:Integer; 
 
begin  
 j:=0; 
 for i:=1 to 2*n-2 
do  
 if a[i].i<>j 
 
then  
  
begin  
 inceput[a[i].i]:=i; 
 sfarsit[j]:=i-1; j:=a[i].i 
 end; 
 sfarsit[j]:=2*n-2; 
 pz:=0; 
 Fillchar(sel,Sizeof(sel),false); 
 for i:=1 to n 
do  
 begin 
 sel[i]:=true; recurs(1,i,i,0); 
 sel[i]:=false 
 
end  
 end; 
 
  procedure sort2(l,r:Integer); 
 var i,j,x:Integer; 
 y:muchie; 
 
begin  
 i:=l; j:=r; 
 x:=b[(l+r) div 2].c; 
 
repeat  
 while b[i].c<x do Inc(i); 
 while x<b[j].c do Dec(j); 
 if i<=j 
 
then  
  
begin  
 y:=b[i]; b[i]:=b[j]; b[j]:=y; 
 Inc(i); Dec(j) 
 
end  
 until i>j; 
 if l<j then sort2(l,j); 
 if i<r then sort2(i,r) 
 end; 
 procedure sort3(l,r:Integer); 
 var i,j,x,y:Integer; 
 
begin  
 i:=l; j:=r; 
 x:=v^[(l+r) div 2]; 
 
repeat  
 while v^[i]<x do Inc(i); 
 while x<v^[j] do Dec(j); 
 if i<=j 
 
then  
  
begin  
 y:=v^[i]; v^[i]:=v^[j]; 
 v^[j]:=y; Inc(i); Dec(j) 
 end 
 until i>j; 
 if l<j then sort3(l,j); 
 if i<r then sort3(i,r) 
 end; 
 
 procedure solutie; 
 var f:Text; k,i:Integer; 
 
begin  
 Assign(f,fout); Rewrite(f); 
 k:=m; 
 for i:=pz downto 1 
do  
 if b[i].c<=v^[k] 
 
then  
  
begin  
 Writeln(f,b[i].i,' ',b[i].j,' ',v^[k]); 
 Dec(k); 
 if k<1 then begin Close(f); Halt 
end  
 end; 
 Close(f) 
 end; 
 
 
Begin  
 citire; 
 sort1(1,2*n-2); 
 calcul_muchii; 
 sort2(1,pz); 
 sort3(1,m); 
 solutie 
 End. 

[cuprins]