Cod sursa(job #973669)

Utilizator crysstyanIacob Paul Cristian crysstyan Data 15 iulie 2013 00:07:13
Problema Loto Scor 0
Compilator fpc Status done
Runda Arhiva de probleme Marime 2.32 kb
program loto;
var v,aux,su:array[1..100] of longint;
        n,s,i,j,k,c,l,ii,jj,kk:longint;
        f,g:text;

        procedure schimb(p,q:longint);
        var x,y,mij,i:longint;
        begin
        mij:=(p+q) div 2;
        x:=p; y:=mij+1;
        k:=p-1;
        while (x<=mij) and (y<=q) do
        begin
        if su[x]<=su[y] then
        begin
        aux[k+1]:=su[x];
        x:=x+1;
        end
        else
        begin
        aux[k+1]:=su[y];
        y:=y+1;
        end;
        end;
        while x<=mij do
        begin
        aux[k+1]:=su[x];
        x:=x+1;
        end;
        while y<=q do
        begin
        aux[k+1]:=su[y];
        y:=y+1;
        end;
        for i:=p to q do
        su[i]:=aux[i];
        end;

        procedure merge(st,dr:integer);
        var mij:longint;
        begin
        if st=dr then
        exit;
        mij:=(st+dr) div 2;
        merge(st,mij);
        merge(mij+1,dr);
        schimb(st,dr);
        end;

        function cb(val:longint):integer;

        var st,dr,med,last:longint;
        begin
        st:=1; dr:=n; last:=-1;
        while st<=dr do
        begin
        med:=(st+dr) div 2;
        if val>=su[med] then
        begin
        last:=med;
        st:=med+1;
        end
        else
        dr:=med-1;
        end;
        cb:=last;
        end;


         begin
         assign(f,'loto.in');
         reset(f);
         read(f,n,s);
         for i:=1 to n do
         read(f,v[i]);
         close(f);
         assign(g,'loto.out');
         rewrite(g);
         c:=0;
         for i:=1 to n do
         for j:=i+1 to n do
         for l:=j+1 to n do
         begin
         c:=c+1;
         su[c]:=v[i]+v[j]+v[l];
         end;


          merge(1,n*n*n);
          for i:=1 to n do
          for j:=i+1 to n do
          for l:=j+1 to n do
          begin
          if cb(s-v[i]-v[j]-v[k])>0 then
          begin
          write(g,v[i],' ',v[j],' ',v[l],' ');
           for ii:=1 to n do
           for jj:=ii+1 to n do
           for kk:=jj+1 to n do
           if v[ii]+v[jj]+v[kk]=s-v[i]-v[j]-v[k] then
           begin
           write(g,v[ii],' ',v[jj],' ',v[kk]);
           exit;
           end;
           end;
           end;
           close(g);
           end.