Services & ResourcesWolfram ForumsMathGroup Archive

[Date Index] [Thread Index] [Author Index]

Re: Inflight magazine puzzle

• To: mathgroup at smc.vnet.net
• Subject: [mg50407] Re: [mg50393] Inflight magazine puzzle
• From: DrBob <drbob at bigfoot.com>
• Date: Thu, 2 Sep 2004 04:34:35 -0400 (EDT)
• References: <200409010549.BAA29899@smc.vnet.net>
• Reply-to: drbob at bigfoot.com
• Sender: owner-wri-mathgroup at wolfram.com

Here's a naive solution that depends on there being (at each stage), at least one cell that is fully determined, and it doesn't check for contradictions. That works for the problem you present, as one would expect from an inflight magazine!!

If someone has already copied and evaluated your original Cell, start by replacing the Nulls with empty lists:

puzzle = puzzle /. Null -> {}

{{{},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,{}}}

Here's a function that finds the 3x3 subtable for any element:

subStart=3Quotient[#-1, 3]+1&;
subSquare[p_List,i_,j_]:=Module[{row=subStart@i,col=
     subStart@j},p[[Range[row,row+2],Range[col,col+2]]]]
subSquare[puzzle,4,5]

{{3,{},{}},{{},7,{}},{{},{},{}}}

This determines what values CANNOT be entered in a cell, for cells that aren't yet known:

excluded[p_List,i_,j_]:=If[p[[i,j]]//ListQ,
     Union@Flatten@{subSquare[p,i,j],p[[All,j]],p[[i,All]]},
     0]
excluded[puzzle,5,2]

{1,2,3,4,5,6,7,9}

oneChoice, applied to any table position, returns the existing value (if any), the only choice if eight digits have been excluded, or {} if the choice isn't determined.

oneChoice[p_List, i_, j_] := Module[{e = excluded[p, i, j]},
     Switch[Length@e,
       0, p[[i, j]],
       8, First@Complement[Range@9, e],
       _, {}]
     ]
MatrixForm[Array[oneChoice[puzzle, ##] &, {9, 9}]]

Finally, here's the iteration step and a solution:

iterate[p_] := Array[oneChoice[p, ##] &, {9, 9}]
FixedPoint[iterate, puzzle] // 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}}

This could be made far more efficient, I'm sure, but FixedPoint took just 0.046 seconds on my machine.

A plot of some kind could be added to "iterate" or the FixedPoint statement fairly easily, I think.

Bobby

On Wed, 1 Sep 2004 01:49:43 -0400 (EDT), Paul Abbott <paul at physics.uwa.edu.au> wrote:

> 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}
>     }
>   ]
>



-- 
DrBob at bigfoot.com
www.eclecticdreams.net

• References:
  • Inflight magazine puzzle
    • From: Paul Abbott <paul@physics.uwa.edu.au>