program hexa; // Packing coloring in hexagonal grid. 
// It confirms that D_6 is acyclic.
{$APPTYPE CONSOLE}

uses
  SysUtils;

const n = 4; m = 6;  // H_1 represented with 4 rows and 6 coloumns
      range = 6;     //  max. number of colors
      n_ver = 26660; // number of vertices in D_6

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 in H_1
     // 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 in H_2
     // the other values in adjacency2[v,d] are vertices at distance d from v
     ad_mat = array[1..n*m,1..n*m] of byte;   //adjacency matrix of H_1
     ad_mat2 = array[1..2*n*m,1..2*n*m] of byte; //adjacency matrix of H_2
     colors = array[1..n*m] of byte; //colors of H_1

var snxm: adjacency;
    snx2m: adjacency2;
    d: ad_mat;
    dd: ad_mat2;
    x: colors;
    all_c: array[1..n_ver] of colors; // vertices of D_k
    sezP2: array[1..n_ver,0..60] of word;  // lists of neighbours in D_k
    s: array[1..n_ver] of byte; // marked vertices in DFS
    p: array[1..n_ver] of word; // parents in DFS tree
    v: word;

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

procedure HexagonalPatern;
//hexagonal patern of dimension n*m: H_1 if n=4 and m=6
var i,j,k: word;
begin
 fillchar(d,sizeof(d),127);   // adjaceny matrix of dimension n*m
 for i := 1 to n*m do d[i,i] := 0;

 for i := 1 to n do // horizontal edges
  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 // vertical edges
  for i := 1 to n - 1 do
   if (i+j) mod 2 = 1 then  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     // distance matrix 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(dd,sizeof(dd),127);   // adjaceny matrix of dimension n*(2m)
 for i := 1 to n*m*2 do dd[i,i] := 0;

 for i := 1 to n do // horizontal edges left
  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 // vertical edges left
  for i := 1 to n - 1 do
  if (i+j) mod 2 = 1 then  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 // horizontal left
  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 // horizontal right
  for i := 1 to n - 1 do
   if (i+j) mod 2 = 1 then 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 // edges between two copies of H_1
  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     // distance matrix of dimension n*(2m)
   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); // adjaceny in n*m grid
 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;

 fillchar(snx2m,sizeof(snx2m),0); // adjaceny in  n*(2m) grid
 for i := 1 to n*m do     //
   for j := 1 to n*m do
    if dd[n*m+i,j] <= range then begin
     inc(snx2m[i,dd[n*m+i,j],0]); snx2m[i,dd[n*m+i,j],snx2m[i,dd[n*m+i,j],0]] := j;
    end;
end;

function good_color(k: word): boolean;
// Returns true if x[k] is a proper color in H_1
var i,j: word;
begin
 for i := 1 to x[k] do
  for j := 1 to snxm[k,i,0] do
   if x[snxm[k,i,j]] = x[k] then begin good_color := false; exit; end;
 good_color := true;
end;

function good_color2(p,d: longword): boolean;
// Returns true if x[k] is a proper color in H_2
var i,j,k: word;
begin
 for i := 1 to n*m do
  for j := 1 to all_c[d][i] do
   for k := 1 to snx2m[i,j,0] do
   if all_c[p][snx2m[i,j,k]] = all_c[d][i] then begin good_color2 := false; exit; end;
 good_color2 := true;
end;

procedure back_track;   // back track for all colorings of H_1
var k: integer;
    st_res: longword;   //count vertices

procedure write_to_array; // fill array with vertices of D_k
begin  inc(st_res);   all_c[st_res] := x; end;

begin
  st_res := 0;
  fillchar(x,sizeof(x),0);
  k := 1; //
  while k > 0 do begin
   x[k] := x[k] + 1;
   while (x[k] <= range) and not good_color(k) do
    x[k] := x[k] + 1;
   if x[k] <= range then begin
    if k = n*m then write_to_array else
     begin k := k + 1; x[k] := 0; end
    end
   else begin
   x[k] := 0; k := k - 1; end;
 end;   { while }
end;

procedure make_graph;    // Make D_6
var i,j: longword;
    st: longword;
begin
 st := 0;
 for i := 1 to n_ver do begin
  for j := 1 to n_ver do if good_color2(i,j) then
   begin inc(sezP2[i,0]); sezP2[i,sezP2[i,0]] := j; end;
  if st < sezP2[i,0] then st := sezP2[i,0];
 end;
 writeln('max edges: ',st);
 readln;
end;

procedure DFS(u: longword);
// DFS search in D_6 from the vertex u. If a cycle is detected, the program stops.
var j: word;
begin // DFS
 s[u] := 1;   // u is marked
 for j := 1 to sezP2[u,0] do
  if (s[sezP2[u,j]] = 1) and (p[u]<> sezP2[u,j]) then begin writeln('Cycle'); readln; end
  else begin
     p[sezP2[u,j]] := u;
     DFS(sezP2[u,j]); end;
 s[u] := 2;
end; // DFS


begin
  HexagonalPatern;
  back_track;              // all colorings of H_1
  Make_graph;              // make D_6
  FillChar(s,sizeof(s),0); // all vertices are unexplored
  for v := 1 to n_ver do
    if s[v]=0 then DFS(v);  // if a vertex is unexplored, perform a DFS
  writeln('End.');
  readln;
end.