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>

**References**:**Inflight magazine puzzle***From:*Paul Abbott <paul@physics.uwa.edu.au>

**Re: Use of large memory**

**expresion with variables from a list**

**Re: Inflight magazine puzzle**

**Re: Re: Inflight magazine puzzle**