Re: Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50475] Re: [mg50461] Re: [mg50393] Inflight magazine puzzle
- From: Andrzej Kozlowski <andrzej at akikoz.net>
- Date: Sun, 5 Sep 2004 03:53:52 -0400 (EDT)
- References: <200409010549.BAA29899@smc.vnet.net> <200409040544.BAA28087@smc.vnet.net> <opsdt7umu4iz9bcq@monster.cox-internet.com>
- Reply-to: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Sender: owner-wri-mathgroup at wolfram.com
Bobby,
My algorithm is basically this: I begin by finding, by backtracking,
all ways of "legally" inserting 1 into the original puzzle. "Legally"
at this point means just respecting the "Latin Square" condition,
disregarding the "sub-squares" one. I then form all matrices that can
be obtained form the original matrix by inserting 1 s. Only at this
point I test for the sub-squares condition and select only those
matrices that satisfy it. I then proceed to apply the above procedure
to all these matrices, but with 2 instead of 1.
Clearly the most obvious source of inefficiency is that the sub-squares
condition is not tested immediately but only after the matrices
satisfying only the "Latin square" condition have been constructed. I
suspect a substantial speed up would be achieved by changing this.
However, there were two reasons why I decided not to do it. First, I
could not find an elegant way to test for the sub-squares condition
during the backtracking stage, an secondly I wanted t be able to
construct easily Latin squares without the rather artificial
"sub-squares" condition. I think my program should be a pretty
efficient Latin square constructor, or Latin Square completer.
I have been tempted to try to re-write my program to test for the
"sub-squares" condition during the backtracking stage, to see if doing
that will make it much faster (looking at the large number of
completions one gets without the "sub-squares" condition I think the
difference would be very substantial), but I really should be spending
my time doing something else so I will leave it at that. But if someone
else decided to re-write this algorithm along these lines I would be
very interested to know how it performed.
Andrzej
On 5 Sep 2004, at 13:53, DrBob wrote:
> 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