# Cod sursa(job #17594)

Utilizator Data 16 februarie 2007 12:19:35 Numarare triunghiuri 0 fpc done Arhiva de probleme 1.82 kb
``````var st:Array[1..3]of longint;
v:array[1..800]of longint;
ap:array[1..maxint]of longint;
n,k,i,j:longint;
as,ev:boolean;
f:text;
procedure citire;
var f:text;
begin
assign(f,'nrtri.in');reset(f);
for i:=1 to n do read(f,v[i]);
end;
procedure sort(s,d:integer);
var aux,i,j,e:integer;
begin
i:=s;
j:=d;
e:=v[(s+d)div 2];
repeat
while v[i]<e do inc(i);
while v[j]>e do dec(j);
if i<=j then begin
aux:=v[i];
v[i]:=v[j];
v[j]:=aux;
inc(i);
dec(j);
end;

until i>j;
if s<j then sort(s,j);
if d>i then sort(i,d);
end;
procedure init;
begin
st[k]:=0;
end;
procedure succesor;
begin
ev:=true;
if st[k]<n then begin
if st[k]<>0 then dec(ap[st[k]]);
as:=true;
inc(st[k]);
if ap[st[k]]<>0 then ev:=false;
inc(ap[st[k]]);
end

else as:=false;
end;
procedure valid;
begin
ev:=true;
i:=1;
while (i<=k-1)and ev do begin if st[k]=st[i] then ev:=false; inc(i); end;
if ev then if k>=2 then if st[k-1]>st[k] then ev:=false;
if ev then if k=3 then if v[st[1]]+v[st[2]]<v[st[3]] then ev:=false;
end;
function solutie:boolean;
begin
solutie:=(k=3);
end;
begin {pp}
citire;
writeln('solutii right');
k:=1;
init;
while k>0 do
begin
repeat succesor;
if as and ev then valid;
until not as or (as and ev);
if as then if solutie then
begin
inc(j);
writeln(v[st[1]],' ',v[st[2]],' ',v[st[3]]);
end
else begin inc(k); init; end
else
begin
dec(ap[st[k]]);
dec(k);
end;
end;
assign(f,'nrtri.out');
rewrite(f);
write(f,j);
close(f);
end.
``````