Re: Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50474] Re: [mg50461] Re: [mg50393] Inflight magazine puzzle
- From: DrBob <drbob at bigfoot.com>
- Date: Sun, 5 Sep 2004 03:53:51 -0400 (EDT)
- References: <200409010549.BAA29899@smc.vnet.net> <200409040544.BAA28087@smc.vnet.net>
- Reply-to: drbob at bigfoot.com
- Sender: owner-wri-mathgroup at wolfram.com
Andrzej,
That's interesting, but very hard to fathom! (For me, anyway.)
On my machine, that method takes 0.359 seconds.
I have a variation on my earlier "naive" solution that solves the problem in 0.016 seconds, but it can find only one solution at most and depends on some cell being fully determined at each stage.
The following recursive solution has neither of those flaws and solves the original problem in 0.141 seconds.
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}}
Clear[dependent, legal, step]
subStart = 3Quotient[# - 1, 3] + 1 &;
"dependent" computes (and saves) a list of the cells that cell {i,j} depends on--the matrix positions (not values) in the same row, column, or 3x3 subcell as {i,j}.
dependent[{i_, j_}] := dependent[{i, j}] = Module[{row = subStart@i,
col = subStart@j},
DeleteCases[Union@Join[Flatten[Table[{ii, jj}, {ii, row,
row + 2}, {jj, col, col + 2}], 1], Distribute[{{i}, Range@9}, List],
Distribute[{Range@9, {j}}, List]], {i, j}]
]
"legal[p]" computes the values that currently are conceivable for a cell. It will be used only for Null cells.
legal[p_]@{a_, b_} :=
Complement[Range@9, Flatten[p[[Sequence @@ #]] & /@ dependent@{a, b}]]
"step" chooses a Null cell with the fewest legal choices, then calls itself for each choice. When it finds a solution, it uses Sow to give it to an enclosing Reap.
step[p_?MatrixQ] := Module[{nulls = Position[p, Null,
2], legals, o, first, v},
If[nulls == {}, Sow@p,
legals = legal[p]@# & /@ nulls;
o = First@Ordering[Length /@ legals, 1];
first = nulls[[o]]; v = legals[[o]];
Scan[step@ReplacePart[p, #, first] &, v]
]
]
Timing[result = First@Last@Reap[step@puzzle]]
{0.141 Second, {{{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}}}}
For the original problem, there's only one choice at each call, but step will call itself 56 levels deep, nonetheless. Another solver could step in to save a lot of time when "legals" in the step function is a list of single choices (or contains several singletons).
If I change 3 and 9 in the first row of the original problem to Nulls, here is the result (14 solutions):
{3.719 Second, {{{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}}, {{2, 1, 3, 5, 9, 7, 4, 8, 6}, {5, 8, 6, 2, 4,
3, 7, 9, 1}, {7, 4, 9, 1, 8, 6, 5, 2, 3}, {8, 2, 4, 3, 6,
5, 1, 7, 9}, {9, 3, 5, 8, 7, 1, 2, 6, 4}, {1, 6, 7, 4, 2,
9, 3, 5, 8}, {6, 5, 8, 7, 3, 4, 9, 1, 2}, {3, 7, 2, 9, 1,
8, 6, 4, 5}, {4, 9, 1, 6, 5, 2, 8, 3, 7}}, {{2, 1, 3, 5, 9,
7, 4, 8, 6}, {5, 8, 6, 2, 4, 3, 7, 9, 1}, {7, 4, 9, 1, 8,
6, 5, 2, 3}, {9, 2, 4, 3, 6, 5, 1, 7, 8}, {8, 3, 5, 9, 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, 6, 4, 5}, {4, 9, 1, 6, 5,
2, 8, 3, 7}}, {{2, 1, 9, 5, 4, 7, 6, 8, 3}, {5, 4, 6, 2, 8,
3, 7, 9, 1}, {7, 3, 8, 1, 9, 6, 5, 4, 2}, {9, 2, 4, 3, 6,
5, 1, 7, 8}, {3, 8, 5, 9, 7, 1, 2, 6, 4}, {1, 6, 7, 4,
2, 8, 3, 5, 9}, {6, 5, 3, 8, 1, 4, 9, 2, 7}, {8, 7, 2, 6,
3, 9, 4, 1, 5}, {4, 9, 1, 7,
5, 2, 8, 3, 6}}, {{2, 1, 9, 5, 4, 7, 6, 8, 3}, {5, 4, 6, 2,
8, 3, 7, 9, 1}, {7, 3, 8, 1, 9, 6, 5, 4, 2}, {9, 2, 4, 3, 6,
5, 1, 7, 8}, {3, 8, 5, 9, 7, 1, 2, 6, 4}, {1, 6, 7, 4, 2,
8, 3, 5, 9}, {8, 5, 3, 6, 1, 4, 9, 2, 7}, {6, 7, 2, 8, 3,
9, 4, 1, 5}, {4, 9, 1, 7, 5, 2, 8, 3, 6}}, {{2, 1, 9, 5,
4, 7, 6, 8, 3}, {5, 4, 6, 2, 8, 3, 7, 9, 1}, {7, 3, 8, 1,
9, 6, 5, 4, 2}, {9, 2, 4, 3, 6, 5, 1, 7, 8}, {3, 8, 5, 9,
7, 1, 2, 6, 4}, {1, 6, 7, 4, 2, 8, 3, 5, 9}, {8, 5, 3, 7,
1, 4, 9, 2, 6}, {6, 7, 2, 8, 3, 9, 4, 1, 5}, {4, 9, 1, 6,
5, 2, 8, 3, 7}}, {{2, 1, 3, 5, 9, 7, 4, 8, 6}, {5, 4, 6, 2,
8, 3, 7, 9, 1}, {7, 8, 9, 1, 4, 6, 5, 2, 3}, {9, 2, 4, 3, 6,
5, 1, 7, 8}, {8, 3, 5, 9, 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, 6, 4, 5}, {4, 9, 1, 6, 5, 2, 8, 3, 7}}, {{2, 1, 9, 5,
4, 7, 6, 8, 3}, {5, 4, 6, 2, 8, 3, 7, 9, 1}, {7, 8, 3, 1,
9, 6, 4, 2, 5}, {9, 2, 4, 3, 6, 5, 1, 7, 8}, {8, 3, 5, 9,
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}}, {{2, 1, 9,
5, 4, 7, 6, 8, 3}, {5, 4, 6, 2, 8, 3, 7, 9, 1}, {7, 8, 3, 1,
9, 6, 5, 4, 2}, {9, 2, 4, 3, 6, 5, 1, 7, 8}, {8, 3, 5, 9, 7,
1, 2, 6, 4}, {1, 6, 7, 4, 2, 8, 3, 5, 9}, {3, 5, 8, 6, 1,
4, 9, 2, 7}, {6, 7, 2, 8, 3, 9, 4, 1, 5}, {4, 9, 1, 7, 5,
2, 8, 3, 6}}, {{2, 1, 9, 5, 4, 7, 6, 8, 3}, {5, 4, 6, 2,
8, 3, 7, 9, 1}, {7, 8, 3, 1, 9, 6, 5, 4, 2}, {9, 2, 4, 3,
6, 5, 1, 7, 8}, {8, 3, 5, 9, 7, 1, 2, 6, 4}, {1, 6, 7, 4,
2, 8, 3, 5, 9}, {3, 5, 8, 7, 1, 4, 9, 2, 6}, {6, 7, 2, 8,
3, 9, 4, 1, 5}, {4, 9, 1, 6, 5, 2, 8, 3, 7}}, {{2, 1, 3,
5, 9, 7, 4, 8, 6}, {5, 4, 6, 2, 8, 3, 7, 9, 1}, {7, 8, 9, 1,
4, 6, 5, 2, 3}, {8, 2, 4, 3, 6, 5, 1, 7, 9}, {9, 3, 5,
8, 7, 1, 2, 6, 4}, {1, 6, 7, 4, 2, 9, 3, 5, 8}, {6, 5, 8, 7,
3, 4, 9, 1, 2}, {3, 7, 2, 9, 1, 8, 6, 4, 5}, {4, 9, 1, 6,
5, 2, 8, 3, 7}}, {{2, 1, 9, 5, 4, 7, 6, 8, 3}, {5, 4, 6,
2, 8, 3, 7, 9, 1}, {7, 8, 3, 1, 9, 6, 4, 2, 5}, {8, 2, 4,
3, 6, 5, 1, 7, 9}, {9, 3, 5, 8, 7, 1, 2, 6, 4}, {1, 6, 7,
4, 2, 9, 3, 5, 8}, {6, 5, 8, 7,
3, 4, 9, 1, 2}, {3, 7, 2, 9, 1, 8, 5, 4, 6}, {4, 9, 1, 6,
5, 2, 8, 3, 7}}, {{2, 1, 9, 5, 4, 7, 6, 8, 3}, {5, 4, 6,
2, 8, 3, 7, 9, 1}, {7, 8, 3, 1, 9, 6, 5, 4, 2}, {8, 2, 4, 3,
6, 5, 1, 7, 9}, {9, 3, 5, 8, 7, 1, 2, 6, 4}, {1, 6, 7, 4,
2, 9, 3, 5, 8}, {3, 5, 8, 6, 1, 4, 9, 2, 7}, {6, 7, 2, 9,
3, 8, 4, 1, 5}, {4, 9, 1, 7, 5, 2, 8, 3, 6}}, {{2, 1, 9, 5,
4, 7, 6, 8, 3}, {5, 4, 6, 2, 8, 3, 7, 9, 1}, {7, 8, 3, 1,
9, 6, 5, 4, 2}, {8, 2, 4, 3, 6, 5, 1, 7, 9}, {9, 3, 5, 8,
7, 1, 2, 6, 4}, {1, 6, 7, 4, 2, 9, 3, 5, 8}, {3, 5, 8, 7,
1, 4, 9, 2, 6}, {6, 7, 2, 9, 3, 8, 4, 1, 5}, {4, 9, 1, 6,
5, 2, 8, 3, 7}}}}
Bobby
On Sat, 4 Sep 2004 01:44:07 -0400 (EDT), Andrzej Kozlowski <akoz at mimuw.edu.pl> wrote:
> 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
>>
>>
>
>
>
--
DrBob at bigfoot.com
www.eclecticdreams.net
- References:
- Inflight magazine puzzle
- From: Paul Abbott <paul@physics.uwa.edu.au>
- Re: Inflight magazine puzzle
- From: Andrzej Kozlowski <akoz@mimuw.edu.pl>
- Inflight magazine puzzle