MathGroup Archive 2004

[Date Index] [Thread Index] [Author Index]

Search the Archive

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


  • Prev by Date: Re: Use of large memory
  • Next by Date: expresion with variables from a list
  • Previous by thread: Re: Inflight magazine puzzle
  • Next by thread: Re: Re: Inflight magazine puzzle