A checkered figure is a connected flat figure consisting of unit squares. The problem is to cut this figure into several equal parts (in area and shape). Cuts can only be made on the sides of the cells. In mathematics, such figures are called polyominoes, and the problem is called the tiling of a certain polyomino with copies of a single polyomino. See https://en.wikipedia.org/wiki/Polyomino

Below are 3 examples of such figures:

We will define such figures by the coordinates of the centers of the squares of which it consists. These points must lie in the first quarter, and points of this figure must lie on each of the coordinate axes.

Below are the codes for two procedures named  CutEqualParts  and  Picture . Required formal parameters of the first procedure: set  S  specifies the initial figure, r is the initial cell for generating subfigures, m is the number of parts into which the original figure needs to be divided. The optional parameter  s  equals (by default onesolution) or allsolutions. The starting cell  r  should be the corner cell of the figure. Then the set of possible subshapes for partitioning will be smaller. If there are no solutions, then the empty set will be returned. The second procedure  Picture  returns a picture of the obtained result as one partition (for a single solution) or in the form of a matrix if there are several solutions. In the second case, the optional parameter  d  specifies the number of rows and columns of this matrix.

restart;
CutEqualParts:=proc(S::set(list),r::list,m::posint, s:=onesolution)
local OneStep, n, i1, i2, j1, j2, R, v0, Tran, Rot, Ref, OneStep1, M, MM, MM1, T, T0, h, N, L;
n:=nops(S)/m;
if irem(nops(S), m)<>0 then error "Should be (nops(S)/m)::integer" fi;
if not (r in S) then error "Should be r in S" fi;
if m=1 then return {S} fi;
if m=nops(S) then return map(t->{t}, S) fi;
i1:=min(map(t->t[1],select(t->t[2]=0,S)));
i2:=max(map(t->t[1],select(t->t[2]=0,S)));
j1:=min(map(t->t[2],select(t->t[1]=0,S)));
j2:=max(map(t->t[2],select(t->t[1]=0,S)));
OneStep:=proc(R)
local n1, R1, P, NoHoles;
R1:=R;
n1:=nops(R1);
R1:={seq(seq(seq(`if`(r1 in S and not (r1 in R1[i]) , subsop(i={R1[i][],r1}, R1)[],NULL),r1=[[R1[i,j][1],R1[i,j][2]-1],[R1[i,j][1]+1,R1[i,j][2]],[R1[i,j][1],R1[i,j][2]+1],[R1[i,j][1]-1,R1[i,j][2]]]), j=1..nops(R1[i])), i=1..n1)};
NoHoles:=proc(s)
local m1, m2, M1, M2, M;
m1:=map(t->t[1],s)[1]; M1:=map(t->t[1],s)[-1];
m2:=map(t->t[2],s)[1]; M2:=map(t->t[2],s)[-1];
M:={seq(seq([i,j],i=m1..M1),j=m2..M2)}; 
if ormap(s1->not (s1 in s) and `and`(seq(s1+t in s, t=[[1,0],[-1,0],[0,1],[0,-1]])), M) then return false fi;
true;
end proc:
P:=proc(t)
if `and`(seq(seq(seq(([i,0] in t) and ([j,0] in t) and not ([k,0] in t) implies not ([k,0] in S), k=i+1..j-1), j=i+2..i2-1), i=i1..i2-2)) and `and`(seq(seq(seq(([0,i] in t) and ([0,j] in t) and not ([0,k] in t) implies not ([0,k] in S), k=i+1..j-1), j=i+2..j2-1), i=j1..j2-2))  then true else false fi;
end proc:
select(t->nops(t)=nops(R[1])+1 and NoHoles(t) and P(t) , R1);
end proc:
R:={{r}}:
R:=(OneStep@@(n-1))(R):
v0:=[floor(max(map(t->t[1], S))/2),floor(max(map(t->t[2], S))/2)]:
h:=max(v0);
Tran:=proc(L,v) L+v; end proc:
Rot:=proc(L, alpha,v0) <cos(alpha),-sin(alpha); sin(alpha),cos(alpha)>.convert(L-v0,Vector)+convert(v0,Vector); convert(%,list); end proc:
Ref:=proc(T) map(t->[t[2],t[1]], T); end proc:
OneStep1:=proc(T)
local T1, n2, R1;
T1:=T; n2:=nops(T1);
T1:={seq(seq(`if`(r1 intersect `union`(T1[i][])={}, subsop(i={T1[i][],r1}, T1), NULL)[], r1=MM1 minus T1[i]), i=1..n2)};
end proc:
N:=0; 
for M in R do
MM:={seq(seq(seq(map(t->Tran(Rot(t,Pi*k/2,v0),[i,j]),M),i=-h-1..h+1),j=-h-1..h+1),k=0..3),seq(seq(seq(map(t->Tran(Rot(t,Pi*k/2,v0),[i,j]),Ref(M)),i=-h-1..h+1),j=-h-1..h+1), k=0..3)}:
MM1:=select(t->(t intersect S)=t, MM):
T:={{M}}:
T:=(OneStep1@@(m-1))(T):
T0:=select(t->nops(t)=m, T):
if T0<>{} then if s=onesolution then return T0[1] else N:=N+1;
 L[N]:=T0[] fi; fi; 
od:
L:=convert(L,list);
if L[]::symbol then return {} else L fi;
end proc:
Picture:=proc(L::{list,set},Colors::list,d:=NULL)
local r;
uses plots, plottools;
if L::set or (L::list and nops(L)=1) or d=NULL then return
display( seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]] ,`if`(L::set,L[j],L[1][j])), color=Colors[j]),j=1..nops(Colors)) , scaling=constrained, size=[800,600]) fi;
if d::list then r:=irem(nops(L),d[2]);
if r=0 then return
display(Matrix(d[],[seq(display(seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]]  ,L[i,j]), color=Colors[j]),j=1..nops(Colors)), scaling=constrained, size=[400,300], axes=none), i=1..nops(L))])) else
display(Matrix(d[],[seq(display(seq(polygon~(map(t->[[t[1]-1/2,t[2]-1/2],[t[1]+1/2,t[2]-1/2],[t[1]+1/2,t[2]+1/2],[t[1]-1/2,t[2]+1/2]]  ,L[i,j]), color=Colors[j]),j=1..nops(Colors)), scaling=constrained, size=[400,300], axes=none), i=1..nops(L)), seq(plot([[0,0]], axes=none, size=[10,10]),k=1..d[2]-r)]))  fi; fi; 
end proc:

Examples of use for figures 1, 2, 3
In the first example for Fig.1 we get 4 solutions for m=4:

S:=({seq(seq([i,j], i=0..4), j=0..2)} union {[2,3],[3,3],[3,4]}) minus {[0,0],[0,1]}:
L:=CutEqualParts(S,[0,2],4,allsolutions);
C:=["Cyan","Red","Yellow","Green"]:
nops(L);
Picture(L,C,[2,2]);

In the second example for Fig.2 for m=2, we get 60 solutions (the first 16 are shown in the figure):

S:={seq(seq([i,j], i=0..4), j=0..4)} minus {[2,2]}:
L:=CutEqualParts(S,[0,0],2,allsolutions):
nops(L);
 C:=["Cyan","Red"]:
Picture(L[1..16],C,[4,4]);


In the third example for Fig.3 and  m=2  there will be a unique solution:

S:={seq(seq([i,j], i=0..5), j=0..3)}  minus {[5,0],[4,2]} union {[1,4],[2,4]}:
L:=CutEqualParts(S,[0,0],2):
 C:=["Cyan","Red"]:
Picture(L,C);


Addition. It is proven that the problem of tiling a certain polyomino with several copies of a single polyomino is NP-complete. Therefore, it is recommended to use the CutEqualParts procedure when the numbers  nops(S)  and  nops(S)/m  are relatively small (nops(S)<=24  and nops(S)/m<=12), otherwise the execution time may be unacceptably long.

Cutting_equal_parts.mw


Please Wait...