Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50461] Re: [mg50393] Inflight magazine puzzle
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Sat, 4 Sep 2004 01:44:07 -0400 (EDT)
- References: <200409010549.BAA29899@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Here is, I think, a complete solution.
In[1]:=
puzzle = {{Null, 3, Null, 9, Null, Null, Null, 8, Null},
{Null, Null, 6, 2, Null, 3, 7, 9, Null},
{Null, Null, Null, 1, Null, Null, Null, Null, Null},
{Null, 2, Null, 3, Null, Null, Null, 7, Null},
{Null, Null, Null, Null, 7, Null, Null, 6, 4},
{1, Null, Null, Null, Null, Null, Null, Null, Null},
{Null, 5, Null, Null, Null, 4, 9, Null, Null},
{Null, 7, 2, Null, Null, Null, Null, Null, Null},
{Null, 9, Null, Null, 5, Null, 8, 3, Null}};
In[2]:=
f[0][(puzzle_)?MatrixQ, i_] := {{}};
f[j_][(puzzle_)?MatrixQ, i_] := f[j][puzzle, i] =
Module[{ls = f[j - 1][puzzle, i], p},
If[ !FreeQ[puzzle[[j,All]], i],
ls = (Append[#1, Null] & ) /@ ls,
Do[If[puzzle[[j,k]] === Null &&
FreeQ[puzzle[[All,k]], i],
p[k] = (Append[#1, k] & ) /@ Select[ls,
FreeQ[#1, k] & ], p[k] = Sequence[]],
{k, 1, 9}]; Flatten[Table[p[k], {k, 1, 9}], 1]]]
In[4]:=
g[(puzzle_)?MatrixQ, l_List, m_Integer] :=
ReplacePart[puzzle, m, DeleteCases[
Transpose[{Range[9], l}], {_, Null}]]
In[5]:=
TestPuzzle[puzzle_] :=
And @@ (Length[Union[#1]] == Length[#1] & ) /@
(Select[#1, NumericQ] & ) /@ Flatten /@
Flatten[Partition[puzzle, {3, 3}], 1]
In[6]:=
GG[l_List, i_] := Select[Flatten[
Apply[Function[x, g[#1, x, i]] /@ #2 & ,
Transpose[{l, (f[9][#1, i] & ) /@ l}], {1}], 1],
TestPuzzle]
In[7]:=
MatrixForm /@ (sols = Fold[GG, {puzzle}, Range[9]])
Out[7]=
{MatrixForm[{{2, 3, 5, 9, 6, 7, 4, 8, 1},
{8, 1, 6, 2, 4, 3, 7, 9, 5}, {7, 4, 9, 1, 8, 5, 6, 2,
3}, {5, 2, 4, 3, 9, 6, 1, 7, 8},
{9, 8, 3, 5, 7, 1, 2, 6, 4}, {1, 6, 7, 4, 2, 8, 3, 5,
9}, {6, 5, 8, 7, 3, 4, 9, 1, 2},
{3, 7, 2, 8, 1, 9, 5, 4, 6}, {4, 9, 1, 6, 5, 2, 8, 3,
7}}]}
It will solve any puzzle of this kind, that is with any partially
filled Latin square as a starting point. I don't think I can spend the
time on constructing an animation, but instead here is a brief
explanation of the code.
The function
f[j][puzzle, i] =
does the main work, that is essentially backtracking. Here puzzle
represents the starting matrix and i the number we are inserting into
puzzle. So the output of this will consists of all lists of j-elements
(l1,l2,...,lj) meaning that the number i should be inserted into
positions (1,l1), (2,l2) .... in the matrix as part of building of a
latin square, except when li is Null, which means that the number i is
not inserted into the row i, because it is already there in the
original matrix.
At this stage I ignore the "sub-squares" condition, although it might
be more efficient to use it already at the backtracking stage. However,
I preferred to to apply it later (the function TestPuzzle). The
function f is used only with the first parameter 9, that is f[9][..],
this parameter only plays a role during backtracking.
The function
g[(puzzle, l, m]
takes as an argument a starting matrix, a list of the kind returned
above and and integer m, and it inserts the integer m into all the
positions in the matrix puzzle encoded in the list l.
the function TestPuzzle tests a solution for the "sub-squares
condition".
The function GG combines all the above into a single function. The
answer is found by running
Fold[GG, {puzzle}, Range[9]]
Note also that if we remove the TestPuzzle condition we will find a
much larger set of all LatinSquares which extend the starting matrix.
I am sure the program can be improved in various ways and in particular
written in a more elegant form, but I think I have already spent as
much time on this as I can afford.
It was another interesting exercise in backtracking. This time I
decided not to use the backtrack function from the Combinatorica
package although I am pretty sure a solution that uses this function
can be written, though probably would be slower.
Andrzej Kozlowski
Chiba, Japan
http://www.mimuw.edu.pl/~akoz/
On 1 Sep 2004, at 14:49, Paul Abbott wrote:
> *This message was transferred with a trial version of CommuniGate(tm)
> Pro*
> The following puzzle appeared in an AirCanada inflight magazine. It's
> not too hard to solve by hand, but I'd be interested to hear about
> clever solutions using Mathematica. What would be particularly nice
> would be to see an animation showing the steps (and possible
> back-tracking) towards the unique solution. I'd like to include the
> best
> solution(s) in an issue of The Mathematica Journal.
>
> Cheers,
> Paul
>
> _______________________________________________________________________
> _
> In the diagram below (copy the Cell[...] below and paste into a
> Notebook, answering yes when it asks you if you want Mathematica to
> interpret it), place the numbers 1 through 9 so that each row, column,
> and 3 x 3 subsquare (separated by thick black lines) contains each
> number exactly once.
>
> Cell[BoxData[FormBox[RowBox[{RowBox[{"puzzle", "=",
> GridBox[{
> {" ", "3", " ", "9", " ", " ", " ", "8", " "},
> {" ", " ", "6", "2", " ", "3", "7", "9", " "},
> {" ", " ", " ", "1", " ", " ", " ", " ", " "},
> {" ", "2", " ", "3", " ", " ", " ", "7", " "},
> {" ", " ", " ", " ", "7", " ", " ", "6", "4"},
> {"1", " ", " ", " ", " ", " ", " ", " ", " "},
> {" ", "5", " ", " ", " ", "4", "9", " ", " "},
> {" ", "7", "2", " ", " ", " ", " ", " ", " "},
> {" ", "9", " ", " ", "5", " ", "8", "3", " "}}]}], ";"}],
> StandardForm]], "Input",
> GridBoxOptions->{
> GridFrame->True,
> RowLines->{0.25, 0.25, True, 0.25, 0.25, True, 0.25},
> ColumnLines->{0.25, 0.25, True, 0.25, 0.25, True, 0.25}
> }
> ]
>
> --
> Paul Abbott Phone: +61 8 9380 2734
> School of Physics, M013 Fax: +61 8 9380 1014
> The University of Western Australia (CRICOS Provider No 00126G)
> 35 Stirling Highway
> Crawley WA 6009 mailto:paul at physics.uwa.edu.au
> AUSTRALIA http://physics.uwa.edu.au/~paul
>
>
- Follow-Ups:
- Re: Re: Inflight magazine puzzle
- From: DrBob <drbob@bigfoot.com>
- Re: Re: Inflight magazine puzzle
- References:
- Inflight magazine puzzle
- From: Paul Abbott <paul@physics.uwa.edu.au>
- Inflight magazine puzzle