Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50509] Re: Inflight magazine puzzle
- From: DrBob <drbob at bigfoot.com>
- Date: Wed, 8 Sep 2004 05:15:29 -0400 (EDT)
- References: <20040908000729.SWBM4710.lakermmtao06.cox.net@boris>
- Reply-to: drbob at bigfoot.com
- Sender: owner-wri-mathgroup at wolfram.com
Here's a solution that's 4 times faster than my previous best (Sept. 5), with no real change in the algorithm. Extract is responsible for most of the improvement, but I'm also storing and reusing more low-level results.
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, row, col, subSquare, legal, step]
subStart = 3Quotient[# - 1, 3] + 1 &;
row[i_] := row[i] = Array[{i, #} &, {9}]
col[i_] := col[i] = Reverse /@ row[i]
subSquare[i_, j_] /; Mod[i, 3] == 1 == Mod[j,
3] := subSquare[i, j] = Flatten[Table[{ii, jj}, {ii, i, i + 2}, {jj,
j, j + 2}], 1]
subSquare[i_, j_] := subSquare[subStart@i, subStart@j]
dependent[{i_, j_}] := dependent[{i, j}] = Complement[Join[
subSquare[i, j], row@i, col@j], {{i, j}}]
legal[p_]@{a_, b_} := Complement[Range@9, Extract[p, dependent@{a, b}]]
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.031 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}}}}
I didn't use it above, but here's a consistency check for partial solutions:
noDups[a_List]:=Module[{e=DeleteCases[Flatten@a,Null]},
Length@Union@e!=Length@e&&Throw[False]
]
consistent[
p_]:=Catch[Scan[noDups,p];Scan[noDups,Transpose@p];
Table[noDups@subSquare[p,i,j],{i,1,7,3},{j,1,7,3}];Throw@True]
consistent@puzzle
True
Bobby
On Tue, 7 Sep 2004 19:07:28 -0500, Hans Michel <hmichel at cox.net> wrote:
> My CompleteLatinSquare code hits a recursion limit but it goes on
> calculating. If you go to MathWorld LatinSquare entry you should find some
> formulas for how many latin squares there are for order 9 it's a big number,
> so unfortunately my code for CompleteLatinSquare takes a long time and has
> recursion limit errors. So this is too slow. If you were to use just the
> LatinSquare code for say order 5 it would generate all 576 legal latin
> squares. I was using this approach to solve the 9X9 case which proves to
> take to long.
>
> Please note that in GraphicLS code we should Reverse the Matrix before we
> Plot it.
>
> Show[DensityGraphics[Reverse[MatrixHere],...]]
>
> Thanks for the compilation I will strive to understand them.
>
> Hans
>
> -----Original Message-----
> From: DrBob [mailto:drbob at bigfoot.com]
To: mathgroup at smc.vnet.net
> Sent: Tuesday, September 07, 2004 6:31 PM
> To: Hans Michel; paul at physics.uwa.edu.au; andrzej at akikoz.net; Ed Pegg
> Cc: David Park
> Subject: [mg50509] Re: Inflight magazine puzzle
>
> Hans,
>
> GraphLS applied to the initial puzzle yields a DensityGraphics plot as
> expected, but applying CompleteLatinSquare to it yields Part::partw,
> Set::partw, and $RecursionLimit::reclim error messages.
>
> The first error message (Part::partw) says that Part 7 of {1,2,4,5,6,7} does
> not exist.
>
> Am I missing something?
>
> I've also thought about attacking the 3x3 matrices separately; I'll be
> curious to see how that goes, if you make it work.
>
> Also... I posted another solution on Sept. 5 that isn't quite so naive; I
> hope you saw it.
>
> Attached is a collection of my solutions, including a "simple animated
> version" and a nice graphing routine by David Park. (He's a genius.) Your
> code, including the error messages, is at the bottom of the notebook.
>
> Bobby
>
> On Tue, 7 Sep 2004 11:30:07 -0500, Hans Michel <hmichel at cox.net> wrote:
>
>> To all:
>>
>> I was initially discouraged by Dr. Bob's quick reply vs my "well this is
>> intersting I'll see what I can do.." reply.
>> He actually solved it, for this case a right anwer is a right answer.
>> However; I was glad that he acknowledged that his answer was in his
>> words,
>> "naive".
>>
>> I did not expect anyone else to give this a try, after all this is
>> recreational math and what good is it. Well I like Latin Square and
>> magic
>> squares because I found them to be a fascinating way to get people
>> interested in mathematics. And they are usefull in the real world such
>> as in
>> electronics, statistics, and cryprography.
>>
>> Andre came up with the circulant method and boom was out the gate.
>>
>> I was struggling with an old LatinSquare algorithm from JS Rohl book
>> recursion via pascal. I modified it but it takes too long for large n.
>> Plus
>> it is in essence iterative not really bactrack.
>>
>> This is a mathematica port I did a few years ago.
>>
>> LatinSquare[n_Integer?Positive] :=
>> Module[{s, ss}, s = Table[j, {i, 1, n}, {j, 1, n}];
>> ss = Table[{}, {i, 1, n}];
>> Choose[ro_, cl_] := Module[{e1, e2, i}, e1 = s[[ro, cl]];
>> For[i = cl, i <= n, i++, e2 = s[[ro, i]];
>> If[! MemberQ[ss[[cl]], e2], s[[ro, cl]] = e2;
>> s[[ro, i]] = e1;
>> AppendTo[ss[[cl]], e2];
>> If[cl != n, Choose[ro, cl + 1],
>> If[ro != n, Choose[ro + 1, 1],
>> Print[MatrixForm[s]]];];(*End If cl not eq n*)s[[ro, i]] =
>> e2;
>> ss[[cl]] = DeleteCases[ss[[cl]], e2];];(*End If Member*)];(*End For*)
>> s[[ro, cl]] = e1;];(*End Choose Module*)
>> Choose[1, 1];];(*End LatinSquare Module*)
>>
>> I modified it for this problem
>>
>> 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}};
>>
>> CompleteLatinSquare[inArr_] :=
>> Module[{n, prules, s, ss}, n = Dimensions[inArr][[1]];
>> prules = DeleteCases[ArrayRules[inArr], ___ -> Null | 0];
>> s = Table[Complement[Range[1, 9], inArr[[i]]], {i, 1, 9}];
>> For[i = 1, i = Length[prules], i++,
>> s = Insert[s, prules[[i]][[2]], prules[[i]][[1]]]];
>> ss = Table[{}, {i, 1, n}];
>> (*Print[MatrixForm[s]];*)Choose[ro_, cl_] :=
>> Module[{e1, e2, i}, e1 = s[[ro, cl]];
>> For[i = cl, i <= n, i++, e2 = s[[ro, i]];
>> If[! MemberQ[ss[[cl]], e2], s[[ro, cl]] = e2;
>> s[[ro, i]] = e1;
>> AppendTo[ss[[cl]], e2];
>>
>> If[cl != n, Choose[ro, cl + 1],
>> If[ro != n, Choose[ro + 1, 1],
>> Print[MatrixForm[
>> s]]];(*End If ro not eq n*)];(*End If cl not eq n*)
>> s[[ro, i]] = e2;
>>
>> ss[[cl]] =
>> DeleteCases[ss[[cl]], e2];];(*End If Member*)];(*End For*)
>> s[[ro, cl]] = e1;];(*End Choose Module*)Choose[1, 1];];
>>
>> The latin square function works well up n = 6, anything after that is
>> asking
>> for trouble.
>> I worked on modifying this so it could be faster and not throw recursion
>> limit errors, I used Update[s] and evaluted some functions to now avail,
>> it
>> runs but takes a long time. No timing numbers available but it I aborted
>> the
>> calculation after 10 mins. But I could clearly see thru a well place
>> print
>> that the algorithm is itterating through the solutions.
>>
>> Andre circulant solution is cool. But the graphing for show should be
>> straight forward if you use for example
>> GraphLS[inArr_] :=
>> Module[{n, prules, comppuzzle, s, ss, $RecursionLimit = Infinity },
>> n = Dimensions[inArr][[1]];
>> prules = DeleteCases[ArrayRules[inArr], ___ -> Null | 0];
>> comppuzzle = Table[Complement[Range[1, 9], inArr[[i]]], {i, 1,
>> 9}];
>> s = comppuzzle;
>> For[i = 1, i <= Length[prules], i++,
>> s = Insert[s, prules[[i]][[2]], prules[[i]][[1]]]];
>> ss = Table[{}, {i, 1, n}];
>> Show[DensityGraphics[s, Frame -> False, ColorFunction -> Hue]]
>> ];
>> GraphLS[puzzle]
>>
>> crucial part Show[DensityGraphics[s, Frame -> False, ColorFunction ->
>> Hue]]
>>
>> yeilds a density graphic. You can use the epilog to place the numbers on
>> the
>> squares.
>>
>> Another approach I will work on is divide and conquer. The 3X3
>> constraint is
>> no more than a 3X3 Magic square. Instead of building up a 9X9 Latin
>> square
>> construct 9 3X3 Magic Squares I don' think there are many of those, such
>> that when you build them to a 9X9 Latin square it meets the original
>> criteria of ArrayRules[puzzle].
>>
>> Hans
>>
>>
>>
>>
>>
>> "Paul Abbott" <paul at physics.uwa.edu.au> wrote in message
>> news:ch3orp$4a$1 at smc.vnet.net...
>>> 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