28
$\begingroup$

Recently I've implemented Minesweeper in Mathematica.

Clear["Global`*"]
path = "http://i.stack.imgur.com//" <> # &;
filenames1 = {"P22Go.jpg", "Zh27M.jpg", "vKZZr.jpg", "2CYDF.png"};
{TL, BR, clock, mine} = Import /@ path /@ filenames1;
{topleft, bottomright} = ImageData /@ {TL, BR};
filenames2 = {"VngIV.jpg", "WeIqo.jpg", "fvub6.jpg", "rb5P7.jpg", 
   "fl5W2.jpg", "NowyY.jpg", "5Pp3F.jpg", "9pNCj.jpg", "vMIXr.jpg"};
numberpictures[n_] := 
  numberpictures[n] = Import[path@filenames2[[n + 1]]];

backgroundcolor = RGBColor[0.698, 0.757, 0.831];
spacecolor = RGBColor[0.839, 0.890, 0.953];
numbercolor = 
  RGBColor @@@ {{0.247, 0.314, 0.737}, {0.122, 0.408, 0.004}, {0.682, 0.008, 0.020},   
       {0.027, 0.004, 0.502}, {0.49, 0, 0}, {0, 0.49, 0.495}, {0, 0, 0}, {0, 0, 0}};

back[i_, j_] := back[i, j] = 
   With[{ii = Rescale[i, {1, 16}], jj = Rescale[j, {1, 30}]}, 
    Image[(1 - (ii + jj)/2) topleft + (ii + jj)/2 bottomright]];
block[{i_, j_, type1_, type2_}] := block[i, j, type1, type2] = 
   Switch[type1,
    0, back[i, j],
    1, Switch[type2,
     0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8, numberpictures[type2],
     9, ImageCompose[back[i, j], mine]
     ]
    ];

ini := Module[{mat1, mat2, modify},
   modify[mat_, {i_, j_}] := 
    If[mat[[i, j]] != 9, 
     ReplacePart[mat, {i, j} -> 
       Count[mat[[Max[1, i - 1] ;; Min[16, i + 1], 
         Max[1, j - 1] ;; Min[30, j + 1]]], 9, 2]], mat];
   mat1 = Table[{i, j, 0}, {i, 16}, {j, 30}];
   mat2 = Partition[RandomSample[
      Flatten@{9 & /@ Range[99], 0 & /@ Range[16*30 - 99]}], 30];
   mat2 = Map[List, Fold[modify[#1, #2] &, mat2, 
      Flatten[Array[{#1, #2} &, {16, 30}], 1]], {2}];
   Join[mat1, mat2, 3]];
CreateDialog[
 DynamicModule[{board = ini}, 
  Dynamic@Column@{Spacer[30], 
     GraphicsGrid[Map[block, board, {2}], ImageSize -> 1200, 
      Spacings -> {0, 0}, Frame -> All, 
      FrameStyle -> Directive[Black, Thick]], 
     Row[{Spacer[60], clock, Spacer[700], mine, Spacer[30]}]}, 
  Initialization :> (
    getpos[] := 
     With[{pos = MousePosition["Graphics"]}, 
      If[pos === None, 
       None, {-1, 1}*Quotient[Reverse@pos, 360] + {0, 1}]];
    click[board_, "Left"] := 
     With[{coor = getpos[]}, 
      If[coor === None, board, 
       ReplacePart[board, Flatten[{coor, 3}] -> 1]]]; 
    SetOptions[EvaluationNotebook[], 
     NotebookEventActions -> {{"MouseUp", 
         1} :> (board = click[board, "Left"]), {"MouseUp", 
         2} :> {"Right ", Print@getpos[]}}])], 
 Background -> backgroundcolor, WindowTitle -> "Minesweeper By apple",
  WindowMargins -> {{0, Automatic}, {Automatic, 0}}]

There are 16*30 = 480 blocks in the final interface. If I write that Dynamic[...(*480 blocks*)], when I click any cell, it will redraw all the interface (480 blocks or more) and will respond after 2 seconds. I don't know how to just dynamic small part of the final interface. How to make it response with high-speed?

Update 1

Since it is not a good idea to put Dynamic over the whole application, I rewrote my code in ugly way:

DynamicModule[{board = ini}, 
 GraphicsGrid[
   {{Dynamic@block@var[1, 1], Dynamic@block@var[1, 2], Dynamic@block@var[1, 3],and so on}, 
    {Dynamic@block@var[2, 1], Dynamic@block@var[2, 2], Dynamic@block@var[2, 3],and so on},
     and so on}}}], 
 Initialization :> (
   getpos[] := some code;
   click["Left"] := somecode; 
   SetOptions[EvaluationNotebook[], NotebookEventActions -> somecode])]

var[1, 1] maybe equal to {1,1,0,3}, {1,1} means this block is in row 1, column 1, 0 means this block was not clicked yet, 3 means there are 3 mines around this block.

Now click will be:

click["Left"]:= With[{coor=getpos[]},board[Sequence@@coor][[3]]=1]

But this is not allowed.

Block[{x}, x[1] = {0, 0, 0}; x[1][[2]] = 11; x[1]]

Set::setps: "x[1] in the part assignment is not a symbol."

We only can do something like this:

Block[{x1}, x1 = {0, 0, 0}; x1[[2]] = 11; x1]

{0, 11, 0}

Then I rewrote my code again..

vars = Table[ToExpression["boardR" <> ToString[i] <> "C" <> ToString[j]], {i, 16}, {j, 30}];
Evaluate@vars = ini;

DynamicModule[{}, 
 GraphicsGrid[
   {{Dynamic@block@boardR1C1, Dynamic@block@boardR1C2, Dynamic@block@boardR1C3,and so on}, 
    {Dynamic@block@boardR2C1, Dynamic@block@boardR2C2, Dynamic@block@boardR2C3,and so on},
     and so on}}}], 
 Initialization :> (
   getpos[] := some code;
   click["Left"] := somecode; 
   SetOptions[EvaluationNotebook[], NotebookEventActions -> somecode])]

now click will be more complex:

click["Left"]:=With[{coor=getpos[]},Set[(ToExpression[
"boardR" <> ToString[coor[[1]]] <> "C" <> ToString[coor[[2]]]])[[3]], 1]]

But this will also cause other problems, since:

a=3;
Set[ToExpression["a"],2]

Set::write: Tag ToExpression in ToExpression[a] is Protected.

So currently all the efforts I did have failed.

Update 2

1:

x[1] = {1, 2, 3};
Module[{temp},
 temp = x[1];
 temp[[2]] = 4;
 x[1] = temp;
 ]
x[1]

{1, 4, 3}

2:

a=3;
ToExpression["a"<>"=2"]
a

2

Now maybe I can finish my code.

Update 3

This game is not finished (now 2014.11.24). There are a lot of features not included.

NotebookPut@
 ImportString[
  Uncompress@FromCharacterCode@Drop[#, -Last@#] &@
   Flatten@ImageData[
     Import["http://i.stack.imgur.com/3wGyI.png"], "Byte"], 
  "NB"]
$\endgroup$
  • 2
    $\begingroup$ I don't think Mathematica is really meant for this kind of applications... $\endgroup$ – Sjoerd C. de Vries Nov 20 '14 at 10:29
  • 1
    $\begingroup$ Don't have more time, but meanwhile: (# = 3) &@ToExpression["a", InputForm, Unevaluated] $\endgroup$ – Kuba Nov 20 '14 at 14:05
  • 1
    $\begingroup$ Or ToExpression["a=" <> ToString[3]] $\endgroup$ – Simon Woods Nov 20 '14 at 14:09
  • 2
    $\begingroup$ Use another language for games :) $\endgroup$ – user5601 Nov 20 '14 at 15:49
  • 19
    $\begingroup$ "People who say it cannot be done should not interrupt those who are doing it." - George Bernard Shaw. ;) $\endgroup$ – C. E. Nov 20 '14 at 21:36
19
$\begingroup$

The issue with such multicontroller dynamic interfaces is that one usually wants to store the state of all controllers in one variable for convenience (e.g. store status of position {i, j} as state[{i, j}] := "flagged" or state = <|{1, 1} -> 2, {1, 2} -> "flagged", ...|>). On one hand, this makes assignments easy during updating, but on the other hand, any change to state triggers an interface update of all cells as they all track the single variable state. And in this case, it involves the visual updating of 480 cells. Using Graphic-s or Image-s makes updating even slower.

Unfortunately, there is no mechanism (yet) to dynamically track parts of expressions without updating the whole expression (parts of a symbol, without updating the whole symbol), something like:

(* hypothetic construct, won't work *)
Dynamic[display[state[{1, 2}]], TrackedSymbols :> {state[{1, 2}]}

One possible solution is to introduce 480 independent symbols as variables, one for each cell, but this requires metaprogramming methods to generate and set the symbols.

Here is a proof-of-principle for this approach that uses the excellent method of programmatic symbol assignment from Kuba & John Fultz. I've replaced the imported graphics with domestic frame-and-style ones, as those are much faster printed. One can make code even faster by fine-tuning recursive reveal to only visit every relevant cell once. Now it is quite redundant, but the fact is that this extra traversal is marginal compared to the time needed for visual updating of the interface. A large part of the code is to detect simultaneous L-R clicks.

Note: m1 and m2 is invisibly displayed so that they are correctly tracked.

enter image description here

ClearAll[toString, set, reveal, neighbors, reset, end, lr];

{m, n, k} = {9, 9, 10}; (* Beginner *)
{m, n, k} = {16, 16, 40};(* Intermediate *)
{m, n, k} = {16, 30, 99};(* Expert *)
seed = 1;

pos = Flatten[Table[{i, j}, {i, m}, {j, n}], 1];
st = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "N", "F"};
bg = {"N" | "F" -> GrayLevel@.7, _ -> GrayLevel@.9};
fg = {
   1 -> RGBColor[0.247, 0.314, 0.737], 
   2 -> RGBColor[0.122, 0.408, 0.004], 
   3 -> RGBColor[0.682, 0.008, 0.02], 
   4 -> RGBColor[0.027, 0.004, 0.502],
   5 -> RGBColor[0.49, 0, 0], 
   6 -> RGBColor[0, 0.49, 0.495], 
   "F" -> RGBColor[1, 0, 0], _ -> GrayLevel[0]};
lbl = {9 -> "\[MathematicaIcon]", 0 -> "", "F" -> "\[SpadeSuit]", x_Integer :> x, _ -> ""};
pics = AssociationMap[
   Framed[Style[# /. lbl, Bold, # /. fg], Background -> (# /. bg), 
     ImageSize -> {20, 20}, Alignment -> {Center, Baseline}, 
     FrameMargins -> 0, ImageMargins -> 0, FrameStyle -> None] &, st];

(* Convert position to symbol name *)
toString[{i_, j_}] := StringJoin["s", ToString@i, "x", ToString@j];
(* Assign `val` to symbol of name `str` *)
set[str_, val_] := ToExpression@MakeBoxes[RawBoxes@str = val];
(* Reveal cell at position `p` and update symbol `s` (string) *)
reveal[p_, s_] := Module[{c}, If[ToExpression@s === "N", c = counts@p; 
    If[c == 9, end@False, set[s, c];
     If[c == 0, reveal[#, toString@#] & /@ neighbors@p]]]];
(* Return 3x3 submatrix centered at position `{i, j}` *)
neighbors[{i_, j_}] := Flatten[Outer[List, Range[Max[1, i - 1], Min[m, i + 1]], 
    Range[Max[1, j - 1], Min[n, j + 1]]], 1];
(* Reset game *)
reset[s_: Automatic] := Module[{mines},
   {msg, f, m1, m2} = {"", 0, 0, 0};
   seed = If[s === Automatic, RandomInteger@999999, s];
   SeedRandom@seed;
   mines = AssociationThread[pos -> RandomSample@PadRight[Table[1, {k}], m n]];
   counts = AssociationMap[If[mines@# > 0, 9, Total@Lookup[mines, neighbors@#]] &, pos];
   str = toString /@ pos; (* generate a symbol name for each cell *)
   ClearAll /@ str; (* clear these symbols in case they exist *)
   set[#, "N"] & /@ str; (* set all symbols to "N" (not clicked) *)
   ];
(* Terminate game *)
end[win_] := (MapThread[set[#1, counts@#2] &, {str, pos}]; 
   msg = Style[If[win, "\[HappySmiley]", "\[SadSmiley]"], 16]);
(* Event for simultaneous L-R click *)
lr[p_, s_] := (If[ToExpression@s =!= "N" && ToExpression@s =!= "F", 
    m1 = m2 = 0; Module[{c = counts@p, nb = neighbors@p, v},
     v = ToExpression@*toString /@ nb;
     If[c === 0 || Count[v, "F"] === c, 
      reveal[#, toString@#] & /@ Pick[nb, v, "N"]]]]);

reset@seed;
Deploy@Grid[{
   {Button["New", reset[]], Button["Reset", reset@seed], 
    InputField[Dynamic[seed, (seed = #; reset@#) &], Number, 
     FieldSize -> 5]},
   {Dynamic@(k - f), Dynamic@msg, Invisible@Dynamic@{m1, m2}},
   {Deploy@Grid[Partition[MapThread[
        EventHandler[Dynamic@pics@ToExpression@#2, {
           {"MouseClicked", 1} :> (m1 = SessionTime[]; 
             If[0 < m1 - m2 < .2, lr[#1, #2], reveal[#1, #2]]; 
             If[(Count[ToExpression /@ str, "N"] + f) === k, 
              end@True]),
           {"MouseClicked", 2} :> (m2 = SessionTime[]; 
             If[0 < m2 - m1 < .2, lr[#1, #2];,
              Switch[ToExpression@#2, "N", f++; set[#2, "F"], "F", f--;
                set[#2, "N"], _, Null]])
           }] &, {pos, str}], n], Spacings -> {.1, .1}, 
      Background -> Black], SpanFromLeft}
   }, Spacings -> {.1, .1}, Alignment -> Left]
$\endgroup$
  • $\begingroup$ Finally, +1 :) Thanks for not abandoning us :) $\endgroup$ – Kuba Oct 29 '18 at 14:21
  • 1
    $\begingroup$ For future readers, here are few topic related to the core problem: 174792, 128344, 64312 $\endgroup$ – Kuba Oct 29 '18 at 14:29
  • $\begingroup$ I just edited tags to add performance-tuning, and I deleted symbols. Only after did I realize you had just added the latter. If you feel strongly that it should be there could you explain why? Oh, and +1 of course! :-) $\endgroup$ – Mr.Wizard Oct 29 '18 at 15:27
  • $\begingroup$ @Kuba thank you for the warm welcome :) I never intended to abandon SE, but I had other obligations (work, familiy, and a baby) and I gained a considerable amount of extra time giving up certain hobbies. You all know how a simple checking of Mathematica.SE could lead to a week long research and optimization and bug-hunting-fest. I got out before my superiors (boss, wife, baby, you name it) recognized a performance drop in my output. $\endgroup$ – István Zachar Oct 29 '18 at 15:52
  • $\begingroup$ @Mr.Wizard You are right, [symbols] is not really fitting here. I've only included it because of the algorithmic generation of unique symbols, but that is not the main point here, and there are better posts for that. I'm fine with your edit, thank you. $\endgroup$ – István Zachar Oct 29 '18 at 15:54

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.