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