The Carpet of Baron Munchausen
Dr. Yury Zavarovsky
This puzzle was one of the tasks given in the 2001 Russian Mathematical Olympiad.
The floor in the drawing room of Baron Munchausen is paved with identical square stones. The Baron claims that his new carpet (made of a single piece of a material ) covers exactly 24 stones and at the same time, each vertical and each horizontal row of stones in the living room contains exactly 4 stones covered with carpet. The Baron is lying, isn't he?
At first glance this seems impossible, but in fact the Baron is right. Several examples can be obtained simply by hand, for example
or
.
In this article, we show how to find all solutions.
>
|
restart;
R:=combinat:-permute([0,0,1,1,1,1]); # All lists of two zeros and four units
|
![[[0, 0, 1, 1, 1, 1], [0, 1, 0, 1, 1, 1], [0, 1, 1, 0, 1, 1], [0, 1, 1, 1, 0, 1], [0, 1, 1, 1, 1, 0], [1, 0, 0, 1, 1, 1], [1, 0, 1, 0, 1, 1], [1, 0, 1, 1, 0, 1], [1, 0, 1, 1, 1, 0], [1, 1, 0, 0, 1, 1], [1, 1, 0, 1, 0, 1], [1, 1, 0, 1, 1, 0], [1, 1, 1, 0, 0, 1], [1, 1, 1, 0, 1, 0], [1, 1, 1, 1, 0, 0]]](/view.aspx?SI=154349/10f72c9ba16c4e3b6e2e86cecc28e046.gif)
| (1) |
>
|
# In the procedure OneStep, the matrices are presented as lists of lists. The procedure adds one row to each matrix so that in each column there are no more than 2 zeros and not more than 4 ones
OneStep:=proc(L::listlist)
local m, k, l, r, a, L1;
m:=nops(L[1]); k:=0;
for l in L do
for r in R do
a:=[op(l),r];
if `and`(seq(add(a[..,j])<=4, j=1..6)) and `and`(seq(m-add(a[..,j])<=2, j=1..6)) then k:=k+1; L1[k]:=a fi;
od; od;
convert(L1, list);
end proc:
# M is a list of all matrices, each of which has exactly 2 zeros and 4 units in each row and column
L:=map(t->[t], R):
M:=(OneStep@@5)(L):
nops(M);
|
| (2) |
>
|
M2:='M2':
M1:=map(Matrix, M):
# From the list of M1 we delete those matrices that contain <1,0;0,1> and <0,1;1,0> submatrices. This means that the boundaries of the corresponding carpets will be simple self-intersecting curves
k:=0:
for m in M1 do
s:=1;
for i from 2 to 6 do
for j from 2 to 6 do
if (m[i,j]=0 and m[i-1,j-1]=0 and m[i,j-1]=1 and m[i-1,j]=1) or (m[i,j]=1 and m[i-1,j-1]=1 and m[i,j-1]=0 and m[i-1,j]=0) then s:=0; break fi;
od: if s=0 then break fi; od:
if s=1 then k:=k+1; M2[k]:=m fi;
od:
M2:=convert(M2, list):
nops(M2);
|
| (3) |
>
|
# We find the list T of all segments from which the boundary consists
T:='T':
n:=0:
for m in M2 do
k:=0: S:='S':
for i from 1 to 6 do
for j from 1 to 6 do
if m[i,j]=1 then
if j=1 or (j>1 and m[i,j-1]=0) then k:=k+1; S[k]:={[j-1/2,7-i-1/2],[j-1/2,7-i+1/2]} fi;
if i=1 or (i>1 and m[i-1,j]=0) then k:=k+1; S[k]:={[j-1/2,7-i+1/2],[j+1/2,7-i+1/2]} fi;
if j=6 or (j<6 and m[i,j+1]=0) then k:=k+1; S[k]:={[j+1/2,7-i+1/2],[j+1/2,7-i-1/2]} fi;
if i=6 or (i<6 and m[i+1,j]=0) then k:=k+1; S[k]:={[j+1/2,7-i-1/2],[j-1/2,7-i-1/2]} fi;
fi;
od: od:
n:=n+1; T[n]:=[m,convert(S,set)];
od:
T:=convert(T, list):
|
>
|
# Choose carpets with a connected border
C:='C': k:=0:
for t in T do
a:=t[2]; v:=op~(a);
G:=GraphTheory:-Graph([$1..nops(v)], subs([seq(v[i]=i,i=1..nops(v))],a));
if GraphTheory:-IsConnected(G) then k:=k+1; C[k]:=t fi;
od:
C:=convert(C,list):
nops(C);
|
| (4) |
>
|
# Sort the list of border segments so that they go one by one and form a polygon
k:=0: P:='P':
for c in C do
a:=c[2]: v:=op~(a);
G1:=GraphTheory:-Graph([$1..nops(v)], subs([seq(v[i]=i,i=1..nops(v))],a));
GraphTheory:-IsEulerian(G1,'U');
U; s:=[op(U)];
k:=k+1; P[k]:=[seq(v[i],i=s[1..-2])];
od:
P:=convert(P, list):
|
>
|
AreIsometric:=proc(Set1::{set,list}, Set2::{set,list})
local n1, n2, n3, n4,s1, S, s, l1, l2, S11, f, x0, y0, phi, Sol, x, y, M1, M2, A1, A2, A3, A4, B1, B2, B3, B4, line1, line2, line3, line4, u, v, Sign, g, M, Line1, Line2, Line3, A, B, C, h, AB, CD, Eq, Eq1, T1, T2, i, S1, S2, T11;
global T;
uses combinat;
S1:={}; S2:={}; T1:={}; T2:={};
for i in Set1 do
if i[1]::realcons then S1:={op(S1),i} else
S1:={op(i), op(S1)}; T1:={op(T1), seq({i[k],i[k+1]}, k=1..nops(i)-1)} fi;
od;
for i in Set2 do
if i[1]::realcons then S2:={op(S2),i} else
S2:={op(i), op(S2)}; T2:={op(T2), seq({i[k],i[k+1]}, k=1..nops(i)-1)} fi;
od;
n1:=nops(S1); n2:=nops(S2); n3:=nops(T1); n4:=nops(T2);
if is(S1=S2) and is(T1=T2) then T:=identity; return true fi;
if n1<>n2 or n3<>n4 then return false fi;
if n1=1 then T:=[translation, <S2[1,1]-S1[1,1], S2[1,2]-S1[1,2]>]; return true fi;
f:=(x,y,phi)->[(x-x0)*cos(phi)-(y-y0)*sin(phi)+x0, (x-x0)*sin(phi)+(y-y0)*cos(phi)+y0]; g:=(x,y)->[(B^2*x-A^2*x-2*A*B*y-2*A*C)/(A^2+B^2), (A^2*y-B^2*y-2*A*B*x-2*B*C)/(A^2+B^2)];
_Envsignum0 := 1;
s1:=[S1[1], S1[2]]; S:=select(s->is((s1[2,1]-s1[1,1])^2+(s1[2,2]-s1[1,2])^2=(s[2,1]-s[1,1])^2+(s[2,2]-s[1,2])^2),permute(S2, 2));
for s in S do
# Checking for translation
l1:=s[1]-s1[1]; l2:=s[2]-s1[2];
if is(l1=l2) then S11:=map(x->x+l1, S1);
if n3<>0 then T11:={seq(map(x->x+l1, T1[i]), i=1..nops(T1))}; fi;
if n3=0 then if is(S11=S2) then T:=[translation, convert(l1, Vector)]; return true fi; else
if is(S11=S2) and is(T11=T2) then T:=[translation, convert(l1, Vector)]; return true fi; fi;
fi;
# Checking for rotation
x0:='x0'; y0:='y0'; phi:='phi'; u:='u'; v:='v'; Sign:='Sign';
if is(s1[1]-s[1]<>s1[2]-s[2]) then
M1:=[(s1[1,1]+s[1,1])/2, (s1[1,2]+s[1,2])/2]; M2:=[(s1[2,1]+s[2,1])/2, (s1[2,2]+s[2,2])/2]; A1:=s1[1,1]-s[1,1]; B1:=s1[1,2]-s[1,2]; A2:=s1[2,1]-s[2,1]; B2:=s1[2,2]-s[2,2]; line1:=A1*(x-M1[1])+B1*(y-M1[2])=0; line2:=A2*(x-M2[1])+B2*(y-M2[2])=0;
if is(A1*B2-A2*B1<>0) then Sol:=solve({line1, line2}); x0:=simplify(rhs(Sol[1])); y0:=simplify(rhs(Sol[2])); u:=[s1[1,1]-x0,s1[1,2]-y0]; v:=[s[1,1]-x0,s[1,2]-y0]; else
if is(s[2]-s1[1]=s[1]-s1[2]) then x0:=(s1[1,1]+s[1,1])/2; y0:=(s1[1,2]+s[1,2])/2;
if is([x0,y0]<>s1[1]) then u:=[s1[1,1]-x0,s1[1,2]-y0]; v:=[s[1,1]-x0,s[1,2]-y0]; else
u:=[s1[2,1]-x0,s1[2,2]-y0]; v:=[s[2,1]-x0,s[2,2]-y0]; fi;
else A3:=s1[2,1]-s1[1,1]; B3:=s1[2,2]-s1[1,2]; A4:=s[2,1]-s[1,1]; B4:=s[2,2]-s[1,2]; line3:=B3*(x-s1[1,1])-A3*(y-s1[1,2])=0; line4:=B4*(x-s[1,1])-A4*(y-s[1,2])=0;Sol:=solve({line3, line4}); x0:=simplify(rhs(Sol[1])); y0:=simplify(rhs(Sol[2]));
if is(s1[1]=s[1]) then u:=s1[2]-[x0,y0]; v:=s[2]-[x0,y0]; else
u:=s1[1]-[x0,y0]; v:=s[1]-[x0,y0]; fi; fi; fi;
Sign:=signum(u[1]*v[2]-u[2]*v[1]); phi:=Sign*arccos(expand(rationalize(simplify((u[1]*v[1]+u[2]*v[2])/sqrt(u[1]^2+u[2]^2)/sqrt(v[1]^2+v[2]^2))))); S11:=expand(rationalize(simplify(map(x->f(op(x), phi), S1))));
if n3<>0 then T11:={seq(expand(rationalize(simplify(map(x->f(op(x), phi), T1[i])))), i=1..nops(T1))}; fi;
if n3=0 then if is(S11=expand(rationalize(simplify(S2)))) then T:=[rotation, [x0,y0], phi]; return true fi; else
if is(S11=expand(rationalize(simplify(S2)))) and is(T11=expand(rationalize(simplify(T2)))) then
T:=[rotation, [x0,y0], phi]; return true fi; fi;
fi;
od;
# Checking for reflection or glide reflection
for s in S do
AB:=s1[2]-s1[1]; CD:=s[2]-s[1];
if is(AB[1]*CD[2]-AB[2]*CD[1]=0) then M:=(s1[2]+s[1])/2;
if is(AB[1]*CD[1]+ AB[2]*CD[2]>0) then A:=AB[2]; B:=-AB[1]; Line1:=A*(x-M[1])+B*(y-M[2])=0; else
A:=AB[1]; B:=AB[2]; Line2:=A*(x-M[1])+B*(y-M[2])=0; fi;
else u:=[AB[1]+CD[1], AB[2]+CD[2]]; A:=u[2]; B:=-u[1]; M:=[(s1[1,1]+s[1,1])/2, (s1[1,2]+s[1,2])/2]; Line3:=A*(x-M[1])+B*(y-M[2])=0; fi; C:=-A*M[1]-B*M[2]; h:= simplify(expand(rationalize(s[1]-g(op(s1[1]))))); S11:=expand(rationalize(simplify(map(x->g(op(x))+h, S1))));
if n3<>0 then T11:={seq(expand(rationalize(simplify(map(x->g(op(x))+h, T1[i])))), i=1..nops(T1))}; fi;
if n3=0 then if is(S11=expand(rationalize(S2))) then
Eq:=A*x+B*y+C=0; Eq1:=`if`(is(coeff(lhs(Eq), y)<>0), y=solve(Eq, y), x=solve(Eq, x));
if h=[0,0] then T:=[reflection, Eq1] else T:=[glide_reflection,Eq1,convert(h, Vector)] fi; return true fi; else
if is(S11=expand(rationalize(S2))) and is(T11=expand(rationalize(T2))) then
Eq:=A*x+B*y+C=0; Eq1:=`if`(is(coeff(lhs(Eq), y)<>0), y=solve(Eq, y), x=solve(Eq, x));
if h=[0,0] then T:=[reflection, Eq1] else
T:=[glide_reflection,Eq1,convert(h, Vector)] fi; return true fi; fi;
od;
T:='T'; false;
end proc:
|
>
|
# Divide the list all the solutions P into the classes of isometric figures
P1:=[ListTools:-Categorize( AreIsometric, P)]:
|
| (5) |
>
|
# Visualization of all 28 unique solutions received
interface(rtablesize=100):
E1:=seq(plottools:-line([1/2,i],[13/2,i], color=red),i=1/2..13/2,1):
E2:=seq(plottools:-line([i,1/2],[i,13/2], color=red),i=1/2..13/2,1):
F:=plottools:-polygon([[1/2,1/2],[1/2,13/2],[13/2,13/2],[13/2,1/2]], color=yellow):
plots:-display(Matrix(4,7,[seq(plots:-display(plottools:-polygon(p,color=red),F, E1,E2), p=[seq(i[1],i=P1)])]), scaling=constrained, axes=none, size=[800,700]);
|
|