program packingrid_CxC; 
//backtracking in the Cartesian products of a path and a cycle, a path and a path
// a cycle and a cycle, as well as P_2 x P_n x P_m
{$APPTYPE CONSOLE}

uses
  SysUtils;

const n = 8;   n = 11;   // number of rows and columns in Cart. product
      range = 10;      // max. number of colours used
      vert_count=n*m;  // number of vertices in Cartesian product

type adjacency = array[1..n*m,1..range,0..2*range] of word;
    // adjacency[v,d,0]: number of vertices at distance d from v
    // the other values in adjacency[v,d] are vertices at distance d from v
     adjacency2 = array[1..n*m,1..range,0..2*range] of word;
  // adjacency2[v,d,0]: number of vertices at distance d from v
  // the other values in adjacency2[v,d] are vertices at distance d from v
     admat = array[1..n*m,1..n*m] of word;  //adjacency matrix
     admat2 = array[1..2*n*m,1..2*n*m] of word;  //adjacency matrix
     colours = array[1..n*m] of integer;  //colours of all nodes in product


var snxm: adjacency;
    snx2m: adjacency2;
    i,j,k: word;
    d: admat;
    dd: admat2;
    x: colours;
    indexes: array[1..2000] of word;      // indexes of uncoloured nodes
    indk:word; // total number of uncoloured nodes


function min(a,b: word): word;
begin
 if a < b then min := a else min := b;
end;


Procedure CycleCycle; // Makes Cartesian product of two cycles of lenght >= 5
var i,j,k: word;
begin
 fillchar(d,sizeof(d),127);   // adjacency matrix of dimension n*m
 for i := 1 to n*m do d[i,i] := 0;

 for i := 0 to n-1 do
  for j := 0 to m-1 do begin
   d[i*m+j+1,i*m + ((j+m-1) mod m) + 1] := 1;
   d[i*m+j+1,i*m + ((j+1) mod m) + 1] := 1;
   d[i*m+j+1,((i+n-1) mod n)*m + j + 1] := 1;
   d[i*m+j+1,((i+1) mod n)*m + j + 1] := 1;
  end;

  for k := 1 to n*m do     // matrix of distances fo dimension n*m
   for i := 1 to n*m do
    for j := 1 to n*m do d[i,j] := min(d[i,k]+d[k,j],d[i,j]);

 fillchar(snxm,sizeof(snxm),0); // neighbourhood in n*m

  for i := 1 to n*m do
    for j := 1 to n*m do
     if (d[i,j] <= range) and (d[i,j] <>0)  then begin
      inc(snxm[i,d[i,j],0]);
      snxm[i,d[i,j],snxm[i,d[i,j],0]] := j;
    end;

end;



Procedure PathCycle; // Makes Cartesian product of path and cycle of length >= 5
var i,j,k: word;
begin
 fillchar(d,sizeof(d),127);   // adjacency matrix of dimension n*m
 for i := 1 to n*m do d[i,i] := 0;

 for i := 0 to n-1 do
  for j := 0 to m-1 do
   begin
    d[i*m+j+1,i*m + ((j+m-1) mod m) + 1] := 1;
    d[i*m+j+1,i*m + ((j+1) mod m) + 1] := 1;
    d[i*m+j+1,((i+n-1) mod n)*m + j + 1] := 1;
    d[i*m+j+1,((i+1) mod n)*m + j + 1] := 1;
   end;

 for j := 0 to m-1 do
  begin                         // correcting the connections on edges
   d[j+1, (n-1)*m + j+1] := 127;
   d[(n-1)*m + j+1, j+1] := 127;
  end;

  for k := 1 to n*m do     // matrix of distances of dimension n*m
   for i := 1 to n*m do
    for j := 1 to n*m do d[i,j] := min(d[i,k]+d[k,j],d[i,j]);

 fillchar(snxm,sizeof(snxm),0); // neighbourhood of dimension n*m

  for i := 1 to n*m do
    for j := 1 to n*m do
     if (d[i,j] <= range) and (d[i,j] <>0)  then
      begin
       inc(snxm[i,d[i,j],0]);
       snxm[i,d[i,j],snxm[i,d[i,j],0]] := j;
      end;

end;



procedure PathPath; // Makes Cartesian product of two paths of lengths n and m
var i,j,k: word;
begin

 fillchar(d,sizeof(d),127);   // adjacency matrix of dimension n*m
 for i := 1 to n*m do d[i,i] := 0;

 for i := 1 to n do
  for j := 1 to m - 1 do begin
   d[(i-1)*m+j,(i-1)*m+j+1] := 1;   d[(i-1)*m+j + 1,(i-1)*m+j] := 1; end;

 for j := 1 to m do
  for i := 1 to n - 1 do begin
   d[(i-1)*m+j,(i)*m+j] := 1;   d[(i)*m+j,(i-1)*m+j] := 1; end;

  for k := 1 to n*m do     // matrix of distances n*m
   for i := 1 to n*m do
    for j := 1 to n*m do d[i,j] := min(d[i,k]+d[k,j],d[i,j]);

 fillchar(dd,sizeof(dd),127);   // neighbourhood in n*(2m)
 for i := 1 to n*m do dd[i,i] := 0;

 for i := 1 to n do
  for j := 1 to m - 1 do begin
   dd[(i-1)*m+j,(i-1)*m+j+1] := 1;   dd[(i-1)*m+j + 1,(i-1)*m+j] := 1; end;

 for j := 1 to m do
  for i := 1 to n - 1 do begin
   dd[(i-1)*m+j,(i)*m+j] := 1;   dd[(i)*m+j,(i-1)*m+j] := 1; end;

 for i := 1 to n do
  for j := 1 to m - 1 do begin
   dd[n*m+(i-1)*m+j,n*m+(i-1)*m+j+1] := 1;
   dd[n*m+(i-1)*m+j + 1,n*m+(i-1)*m+j] := 1; end;

 for j := 1 to m do
  for i := 1 to n - 1 do begin
   dd[n*m+(i-1)*m+j,n*m+(i)*m+j] := 1;
   dd[n*m+(i)*m+j,n*m+(i-1)*m+j] := 1; end;

 for i := 1 to n do begin
  dd[i*m,n*m+(i-1)*m+1] := 1; dd[n*m+(i-1)*m+1,i*m] := 1; end;

  for k := 1 to n*2*m do
   for i := 1 to n*2*m do
    for j := 1 to n*2*m do dd[i,j] := min(dd[i,k]+dd[k,j],dd[i,j]);

 fillchar(snxm,sizeof(snxm),0);
 for i := 2 to n*m do
   for j := 1 to i-1 do
    if d[i,j] <= range then begin
     inc(snxm[i,d[i,j],0]); snxm[i,d[i,j],snxm[i,d[i,j],0]] := j;
    end;

end;


Procedure ThreePaths; // Makes Cartesian product of P_2 x P_{n/2} x P_m
// n has to be even in this case
var i,j,k: word;
begin

  fillchar(d,sizeof(d),127);   // adjacency matrix n*m
  for i := 1 to n*m do d[i,i] := 0;

  for i := 0 to n-1 do
   for j := 0 to m-1 do begin
    d[i*m+j+1,i*m + ((j+m-1) mod m) + 1] := 1;
    d[i*m+j+1,i*m + ((j+1) mod m) + 1] := 1;
    d[i*m+j+1,((i+n-1) mod n)*m + j + 1] := 1;
    d[i*m+j+1,((i+1) mod n)*m + j + 1] := 1;
   end;

  if m > 2 then
   for j := 1 to n do begin
      d[(j-1)*m+1, j*m] := 127;
      d[ j*m, (j-1)*m+1] := 127;
   end;

  for i := 1 to (n div 2) - 2 do
   for j := 0 to m-1 do begin
     d[i*m+j+1,(n-i-1)*m + j + 1] := 1;
     d[(n-i-1)*m+j+1,i*m+j+1] := 1;
   end;

   for k := 1 to n*m do     // matrix of distances n*m
    for i := 1 to n*m do
     for j := 1 to n*m do d[i,j] := min(d[i,k]+d[k,j],d[i,j]);

  fillchar(snxm,sizeof(snxm),0); // neighbourhood in n*m

   for i := 1 to n*m do
     for j := 1 to n*m do
      if (d[i,j] <= range) and (d[i,j] <>0)  then begin
       inc(snxm[i,d[i,j],0]);
       snxm[i,d[i,j],snxm[i,d[i,j],0]] := j;
     end;

end;



function good_colour(k: word): boolean;
// Checking, if the colour for node k is OK
var i: word;
begin
  for i := 1 to indk-1 do    // checking for all coloured nodes till now
   if (x[indexes[i]] = x[k]) and (d[indexes[i],k]<=x[k]) then
       begin
        good_colour := false;
        exit;
       end;  // between coloured nodes we don't want neigbours of k on distance <= x[k] // with the same colour
 good_colour := true;
end;



procedure display_result(v_dat:boolean);
var i,j:integer;
    pom:boolean;
    a:text;
begin
 assign(a,'rezultati.dat');
 append(a);
 writeln('N: ',n,' M: ',m,' Range: ',range);
 writeln;
 if v_dat then writeln(a,'N: ',n,' M: ',m,' Range: ',range);
 if v_dat then writeln(a);
   for i:=1 to n do
    begin
     for j:=1 to m do
      begin
       write(x[(i-1)*m+j]:3);
       if v_dat then write(a,x[(i-1)*m+j]:3);
      end;
     writeln;
     if v_dat then writeln(a);
    end;
   writeln;
   if v_dat then writeln(a);
  close(a);
  readln;
end;



procedure fixing1;
// Precoloring with colour 1 all possible nodes
var
 i,j:word;
begin
  for i:=1 to n do
   for j:=1 to m do
    begin
     if (odd(i) and odd(j)) then x[(i-1)*m+j]:=1;
     if (not odd(i)) and (not odd(j)) then x[(i-1)*m+j]:=1;
    end;
end;



procedure back_track2;
// Backtracking procedure to colour all nodes with given set of colours, if possible
var k: integer;
    i: integer;
    minsest:word;
    maksind:word;
begin
  fillchar(x,sizeof(x),0);
  fixing1;
  indk:=0;
  for i:= 1 to vert_count do
   if x[i]=0 then      // counting the number of uncoloured nodes
    begin
      inc(indk);
      indexes[indk]:=i;  // and remembering their indices
    end;
  maksind:=indk;  // maximal number of uncoloured vertices (excluding color 1)
  display_result(false);
  minsest:=60;
  indk:=1;
  k := indexes[indk];           // we start with the first uncoloured node
  while indk > 0 do
   begin
    if x[k]=0 then x[k]:=2 // start colour (if colour 1 is prefilled 2, else set to 1)
    else x[k] := x[k] + 1;        // else next available colour
    while (x[k] <= range) and not good_colour(k) do
     x[k] := x[k] + 1;
    if x[k] <= range then
    begin
     if indk = maksind then display_result(true) else
      begin
       indk:=indk+1;
       k := indexes[indk];
       x[k] := 0;
      end;
    end
    else
    begin
     x[k] := 0;  // not successful, so backtract to the previous node
     indk:=indk-1;
     if indk > 0 then k := indexes[indk];
     if indk<minsest then
      begin
       writeln(DateToStr(Date),'  ',TimeToStr(Time),' Backtracking to node: ',indk);
       minsest:=indk;  // remembering the deepest backtracked node till now
//       display_result(false);  // partial coloring
      end;
    end;
   end;
end;


begin
  randomize;

 // CycleCycle;     // making cartesian product of two cycles

 // ThreePaths;     // or cartesian product of P_2 x P_(m/2) x P_n

 // PathCycle;     // or cartesian product of path and cycle

  PathPath;        // or cartesian product of two paths

  back_track2;   // colouring using backtracking algorithm


  writeln('End of procedure.');

  readln;

end.