Cod sursa(job #63120)

Utilizator FreeYourMindAndrei FreeYourMind Data 26 mai 2007 20:04:48
Problema Loto Scor 5
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.48 kb
program loto;

const fin = 'loto.in';
     fout = 'loto.out';

var n: byte;
    s: longint;
    a: array[1..100] of longint;
   sm: array[1..1100000] of longint;
  nsm: longint;
first3: longint;
    x: array[1..6] of longint;

procedure load;
 var f: text; i: byte;
begin
 assign(f, fin); reset(f);
  readln(f,n,s);
  for i:=1 to n do
   read(f, a[i]);
 close(f);
end;

procedure sort;
 var i,j: byte; temp: longint;
begin
 for i:=1 to n-1 do
  for j:=i+1 to n do
      if a[i]>a[j]
         then begin
                temp:=a[i];
                a[i]:=a[j];
                a[j]:=temp;
              end;
end;

procedure getsm;
 var i,j,k: byte;
begin
 nsm:=0;
 for i:=1 to n do
     for j:=i to n do
         for k:=j to n do
             begin
              inc(nsm);
              sm[nsm]:=a[i]+a[j]+a[k];
             end;
end;

function search(value, left, right:longint): boolean;
 var mid: longint;
begin
 if left>=right then begin if value=sm[left] then search:=true else search:=false; exit; end;

 mid:=(left+right) div 2;
 if value<sm[mid] then search:=search(value, left, mid)
                  else search:=search(value, mid+1, right);
end;

procedure search6;
 var i: longint;
begin
 for i:=1 to nsm do
     begin
          if search(s-sm[i],1,nsm)
             then begin
                   first3:=sm[i];
                   exit;
                  end;
     end;
 first3:=-1;
end;

procedure findnumbers;
 var i,j,k: byte;
begin
 for i:=1 to n do
     for j:=i to n do
         for k:=j to n do
             if first3=a[i]+a[j]+a[k] then
                begin
                 x[1]:=a[i]; x[2]:=a[j]; x[3]:=a[k];
                 break;
                end;
 for i:=1 to n do
     for j:=i to n do
         for k:=j to n do
             if s-first3=a[i]+a[j]+a[k] then
                begin
                 x[4]:=a[i]; x[5]:=a[j]; x[6]:=a[k];
                 exit;
                end;
end;

procedure sortx;
 var i,j: byte; temp: longint;
begin
 for i:=1 to 5 do
     for j:=i+1 to 6 do
         if x[i]>x[j] then begin temp:=x[i]; x[i]:=x[j]; x[j]:=temp; end;
end;

procedure save;
 var f: text; i: byte;
begin
 assign(f, fout); rewrite(f);
 if first3=-1 then begin write(f, -1); close(f); exit; end;
 write(f,x[1]);
 for i:=2 to 6 do
     write(f,' ',x[i]);
 close(f);
end;

var h,m,se,ss: word;

begin
 load;
 sort;
 getsm;
 search6;
 if first3 <>-1 then begin findnumbers; sortx; end;
 save;
end.