Re: Inflight magazine puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg50502] Re: Inflight magazine puzzle
- From: "Hans Michel" <hmichel at sdc.cox.net>
- Date: Wed, 8 Sep 2004 05:15:05 -0400 (EDT)
- References: <ch3orp$4a$1@smc.vnet.net>
- Reply-to: "Hans Michel" <hmichel at sdc.cox.net>
- Sender: owner-wri-mathgroup at wolfram.com
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
>