Application Center - Maplesoft

App Preview:

The Carpet of Baron Munchausen

You can switch back to the summary page by clicking here.

Learn about Maple
Download Application




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]]

(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);

67950

(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);

394

(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);

208

(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)]:

nops(P1);

28

(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]);