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 >

**Re: Parallel Toolkit Example**

**Re: Inflight magazine puzzle**

**Re: Inflight magazine puzzle**

**Re: Inflight magazine puzzle**