COLLECT - VOI05 Bộ sưu tập

Tác giả: flashmt

Ngôn ngữ: Pascal

const fi='';
      fo='';
      maxn=16000;
var n,x,y,z,x0,y0,z0,kk,res,num:longint;
    re:array[1..maxn,0..3] of longint;
    a:array[1..maxn,1..6] of longint;
    q:array[1..maxn,1..3] of longint;
    d:array[0..4,0..4,0..4] of longint;
    dau:array[0..4,0..4,0..4,0..4,0..4,0..4] of byte;

procedure rf;
var i,j,k:longint;
begin
     assign(input,fi);
     reset(input);
     read(kk,x,y,z,x0,y0,z0);
     n:=0;
     for i:=0 to 4 do 
         for j:=0 to 4 do
             for k:=0 to 4 do
                 dau[i,j,k,i,j,k]:=1;
     while not eof do
     begin
          inc(n);
          for i:=1 to 6 do read(a[n,i]);
          if dau[a[n,1],a[n,2],a[n,3],a[n,4],a[n,5],a[n,6]]=0 then
             dau[a[n,1],a[n,2],a[n,3],a[n,4],a[n,5],a[n,6]]:=1
          else dec(n);
          readln;
     end;
     close(input);
end;

function check(r,s,t,x,y,z:longint):boolean;
begin
     check:=(r>=0) and (s>=0) and (t>=0) and (x<5) and (y<5) and (z<5);
end;

procedure pr;
var i,j,r,s,t,rr,ss,tt:longint;
begin
     fillchar(d,sizeof(d),0);
     d[x,y,z]:=1; i:=1; num:=1; q[1,1]:=x; q[1,2]:=y; q[1,3]:=z;
     repeat
           if (q[i,1]>=x0) and (q[i,2]>=y0) and (q[i,3]>=z0) then 
           begin
                inc(i); continue;
           end;
           for j:=1 to n do
           begin
                r:=q[i,1]-a[j,1]; s:=q[i,2]-a[j,2]; t:=q[i,3]-a[j,3];
                rr:=r+a[j,4]; ss:=s+a[j,5]; tt:=t+a[j,6];
                if check(r,s,t,rr,ss,tt) then
                begin
                     if (d[rr,ss,tt]=0) then
                     begin
                          inc(num);
                          q[num,1]:=rr; q[num,2]:=ss; q[num,3]:=tt;
                          d[rr,ss,tt]:=d[q[i,1],q[i,2],q[i,3]]+1;
                     end
                     else
                     begin
                          if d[rr,ss,tt]>d[q[i,1],q[i,2],q[i,3]]+1 then
                             d[rr,ss,tt]:=d[q[i,1],q[i,2],q[i,3]]+1;
                     end;
                end;
           end;
           inc(i);
     until i>num;
end;

procedure wf;
var i,j,k:longint;
begin
     assign(output,fo);
     rewrite(output);
     res:=0;
     for i:=x0 to 4 do
         for j:=y0 to 4 do
             for k:=z0 to 4 do
                 if (d[i,j,k]>1) and (d[i,j,k]-1<=kk) then
                 begin
                      inc(res);
                      re[res,0]:=i; re[res,1]:=j; re[res,2]:=k;
                      re[res,3]:=d[i,j,k]-1;
                 end;
     if res=0 then write(-1)
     else
     begin
          writeln(res);
          for i:=1 to res do
          begin
               for j:=0 to 2 do write(re[i,j],' ');
               writeln(re[i,3]);
          end;
     end;
     close(output);
end;

begin
     rf;
     pr;
     wf;
end.

Download