Re: Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50476] Re: [mg50461] Re: [mg50393] Inflight magazine puzzle
- From: DrBob <drbob at bigfoot.com>
- Date: Sun, 5 Sep 2004 03:53:54 -0400 (EDT)
- References: <200409010549.BAA29899@smc.vnet.net> <200409040544.BAA28087@smc.vnet.net> <opsdt7umu4iz9bcq@monster.cox-internet.com> <6E2C6EC6-FF07-11D8-88CE-000A95B4967A@akikoz.net>
- Reply-to: drbob at bigfoot.com
- Sender: owner-wri-mathgroup at wolfram.com
I do get the gist of the algorithm, but the code isn't divided up into easily understood pieces as much as one might like.
Nonetheless, I want to look at it more closely, eventually. At that point, I'll probably move the sub-squares condition up front to see what difference it makes, as you've suggested.
Bobby
On Sun, 5 Sep 2004 15:47:18 +0900, Andrzej Kozlowski <andrzej at akikoz.net> wrote:
> *This message was transferred with a trial version of CommuniGate(tm) Pro*
> 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
>>
>
>
>
--
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