Cod sursa(job #288559)

Utilizator cristinabCristina Brinza cristinab Data 25 martie 2009 21:57:05
Problema Loto Scor 100
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.56 kb
{loto infoarena/ culegere clasa a 9a}

var a:array[1..100] of longint;
    v:array[1..1000000] of longint;
    s:longint;
    n:byte;
    f,g:text;
    k:longint;
    ok:boolean;

procedure citire;
var i:integer;
begin
assign(f,'loto.in'); reset(f);
readln(f,n,s);
for i:=1 to n do read(f,a[i]);
close(f);
end;


function caut_binar(x:longint):boolean;
var stanga,dreapta,mijloc:longint;
    ok:boolean;
begin
stanga:=1;
dreapta:=k;
ok:=false;

while (stanga<=dreapta) and not ok do
      begin
      mijloc:=(stanga+dreapta) div 2;
      if x<v[mijloc] then dreapta:=mijloc-1
      else if x>v[mijloc] then stanga:=mijloc+1
           else begin
                ok:=true;
                end;
      end;

if ok then caut_binar:=true
      else caut_binar:=false;
end;


procedure qsort(l,r:longint);
var i,j:longint;
    aux:longint;
    x:longint;
begin

i:=l;
j:=r;
x:=v[(l+r) div 2];

repeat
  while v[i]<x do inc(i);
  while v[j]>x 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 j>l then qsort(l,j);
if i<r then qsort(i,r);
end;


procedure qsort1(l,r:longint);
var i,j:longint;
    aux:longint;
    x:longint;
begin

i:=l;
j:=r;
x:=a[(l+r) div 2];

repeat
  while a[i]<x do inc(i);
  while a[j]>x do dec(j);

  if i<=j then
     begin
     aux:=a[i];
     a[i]:=a[j];
     a[j]:=aux;
     inc(i);
     dec(j);
     end
until i>=j;

if j>l then qsort(l,j);
if i<r then qsort(i,r);
end;

procedure rezolvare;
var i,j,l,y,z,t:integer;
begin

k:=0;

for i:=1 to n do
    for j:=1 to n do
        for l:=1 to n do
            begin
            inc(k);
            v[k]:=a[i]+a[j]+a[l];
            end;

qsort(1,k);
qsort1(1,n);
ok:=false;
assign(g,'loto.out'); rewrite(g);

for i:=1 to n do
    for j:=1 to n do
        for l:=1 to n do
            if caut_binar(s-a[i]-a[j]-a[l]) then
               begin
               ok:=true;
               write(g,a[i],' ',a[j],' ',a[l],' ');
               for y:=n downto 1 do
                   for z:=n downto 1 do
                       for t:=n downto 1 do
                           if a[y]+a[z]+a[t]=s-a[i]-a[j]-a[l] then
                              begin
                              writeln(g,a[y],' ',a[z],' ',a[t]);
                              close(g);
                              exit;
                              end;
               end;

if not ok then writeln(g,-1);
close(g);
end;

begin
citire;
rezolvare;
end.