Cod sursa(job #176593)

Utilizator chelaru_t_achelaru traian andrei chelaru_t_a Data 11 aprilie 2008 14:43:28
Problema Loto Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.6 kb
var v,s:array [1..1000000] of longint;
  n,sum,l:longint;
  f,t:text;

 procedure citire;
  var i:longint;
  begin
   readln(f,n,sum);
   for i:=1 to n do read(f,v[i]);
  end;

 procedure suma3;
  var i,j,k:longint;
  begin
   l:=0;
   for i:=1 to n do
     for j:=1 to n do
       for k:=1 to n do
         begin
         l:=l+1;
         s[l]:=v[i]+v[j]+v[k];
         end;
  end;

{ procedure heapsort;
  var s1,d:integer;
    x:longint;
   procedure deplasare(s1,d:integer);
    var i,j:integer;
      ret:boolean;
    begin
     i:=s1;
     j:=2*i;
     x:=s[i];
     ret:=false;
     while (j<=d) and (not ret) do
       begin
       if j<d then
         if s[j]<s[j+1] then j:=j+1;
       if x<s[j] then
         begin
         s[i]:=s[j];
         i:=j;
         j:=2*i;
         end
       else ret:=true;
     end;
     s[i]:=x;
    end;
  begin
   s1:=(l div 2)+1;
   d:=l;
   while s1>1 do
     begin
     s1:=s1-1;
     deplasare(s1,l);
     end;
   while d>1 do
     begin
     x:=s[1];
     s[1]:=s[d];
     s[d]:=x;
     d:=d-1;
     deplasare(1,d);
     end;
  end;}

 procedure qsort(s1,d:longint);
  var i,j,x,y:longint;
  begin
   i:=s1;
   j:=d;
   x:=s[(s1+d)div 2];
   repeat
   while s[i]<x do i:=i+1;
   while s[j]>x do j:=j-1;
   if i<=j then
     begin
     y:=s[i];
     s[i]:=s[j];
     s[j]:=y;
     i:=i+1;
     j:=j-1;
     end;
   until i>j;
   if s1<j then qsort(s1,j);
   if d>i then qsort(i,d);
  end;

 procedure afisare(p:longint);
  var i,j,k,e:longint;
     ok:boolean;
  begin
   ok:=false;
   i:=0;
   while (i<>n) and (not ok) do
     begin
     i:=i+1;
     j:=0;
     while (j<>n) and (not ok) do
       begin
       j:=j+1;
       k:=0;
       while (k<>n) and (not ok) do
         begin
         k:=k+1;
         if v[i]+v[j]+v[k]=s[p] then
           begin
           write(f,v[i],' ',v[j],' ',v[k]);
           ok:=true;
           end;
         end;
       end;
     end;
  end;

 procedure suma;
  var p,u:longint;
    ok:boolean;
  begin
   ok:=false;
   p:=1;
   u:=l;
   while p<=u do
     begin
     if s[p]+s[u]=sum then
       begin
       ok:=true;
       afisare(p);
       afisare(u);
       p:=u+1;
       end
     else begin
          while (s[p]+s[u]>sum) and (u>=1) do p:=p+1;
          while (s[p]+s[u]<sum) and (p<=l) do u:=u-1;
          end;
     end;
   if not ok then write(t,'-1');
  end;

begin
  assign(f,'loto.in');
  assign(t,'loto.out');
  reset(f);
  rewrite(t);
  citire;
  suma3;
  qsort(1,l);
  suma;
  close(f);
  close(t);
end.