Message Boards Message Boards

2048 game - suggestions?

Hey all, I'm a student and am just starting to get the hang of Mathematica. I tried to make a Mathematica version of the game 2048. My program works now, so I thought I'd share. I'd love to hear if there are any better ways to do it, or any suggestions you have to make it better. 

I originally wanted to see the distribution of how many moves a random game would last. So, now you can use all the normal Mathematica tools to discover cool patterns in 2048.

Thanks, hope you enjoy!


 Shift[list_]:=PadRight[Cases[list,Except[0]],4];
 Merge[list_]:=Flatten[list//.{x___,c_,c_,y___}->{x,{2*c},y}];
 SlideRow[list_]:=Shift[Merge[Shift[list]]];
 Slide[list_,l]:=Table[SlideRow[list[[j]]],{j,1,4}];
 Slide[list_,r]:=Table[Reverse[SlideRow[Reverse[list[[j]]]]],{j,1,4}];
 Slide[list_,u]:=Transpose[Table[SlideRow[Transpose[list][[j]]],{j,1,4}]];
 Slide[list_,d]:=Transpose[Table[Reverse[SlideRow[Reverse[Transpose[list][[j]]]]],{j,1,4}]];
 RandInsert[list_]:=ReplacePart[list,RandomChoice[Position[list,0]]->RandomChoice[{2,4}]]
  (*these functions slide each row in the given direction,combine like terms,and add one random number to an empty tile*)

Col[n_]:=Graphics[{Blend[{Yellow,Cyan,Purple,Red},((Log[n+1]/Log[2]))/11],Rectangle[]}];
Visual[list_]:=ImageCompose[GraphicsGrid[Table[Table[Col[list[[j,i]]],{i,1,4}],{j,1,4}]],GraphicsGrid[list,Frame->All]]
(*the tiles,with colors and numbers*)

Nex[list_,move_]:=If[FreeQ[list,0],ConstantArray[Infinity,{4,4}],RandInsert[Slide[list,move]]]
(*the update rule*)

(*the game itself.input from {u,d,l,r} to move*)
game=ConstantArray[0,{4,4}];Print[Dynamic[Visual[game]]];While[game!=ConstantArray[Infinity,{4,4}],game=Nex[game,Input[]]]



Edit: When I compared my results with the excellent artent article below, I noticed two important bugs. A random tile was added even after moves that didn't change anything. And the game ended after the board was full, even if further moves were possible. To fix this, I changed the Nex update rule. It's a little clunky, but should work. Uh, right now for the sake of analysis I have the final state be the total score instead of the grid, but you can change it easily enough. Thanks everyone for the comments!
Nex[list_, move_] := Piecewise[{{RandInsert[list], Total[Flatten[list]] == 0}, {Total[Flatten[list]], Slide[list, u] == Slide[list, d] == Slide[list, l] == Slide[list, r] == list}, {list, Slide[list, move] == list}}, RandInsert[Slide[list, move]]]
POSTED BY: Brady Pelkey
5 Replies
Very nice! I like the use of CreateDialog as well. I recently made a similar one myself, with some different stylings: one where I scraped the CSS from the original, and one where I used spikeys instead of numbers! You can download the spikey images here (the code looks for the images at ~/Downloads/Spikeys/, but you can change it).

Also a notebook is attached to this post which you can simply run and the game will start - all images are already inside.

Spikey images look like this once imported:



Here's the code (the bulk of it is styling stuff, and I put everything inside of the Initialization of the DynamicModule):

  start2048[] := With[{size = 4},
    CreateDialog[
     DynamicModule[
      {board = Table[$empty, {size}, {size}], tile, score = 0, s, oldBoard, gameover = False, won = False},
      Dynamic[
       Column[{
        Row[{
         "Styling: ",
         Button["Default", ($emptyColor = RGBColor[0.75436, 0.701427, 0.642634];
            $backgroundColor = RGBColor[0.676677, 0.616403, 0.559747];
            drawTile = drawTileDefault;)],
        Button["Wolfram", ($backgroundColor = LightGray; $emptyColor = Lighter[$backgroundColor, .6];
            drawTile = drawTileWolfram;)],
        Spacer[220],
        Button["Reset", (board = Table[$empty, {size}, {size}]; score = 0; gameover = False; won = False;
            Do[tile = newTile[board]; board[[Sequence @@ tile[[2]]]] = tile[[1]], {2}];)]
       }],
       Row[{
        Which[
            gameover,
            Overlay[{#, Text[Style["Gameover", Red, Bold, FontFamily -> "Helvetica",
               FontSize -> Scaled[0.1]]]}, Alignment -> Center] &,
            won,
            Overlay[{#, Text[Style["You win!", Yellow, Bold, FontFamily -> "Helvetica",
               FontSize -> Scaled[0.1]]]}, Alignment -> Center] &,
            True,
            Identity
        ] @ drawGrid[board],
        Spacer[50],
        Column[{
         Style[score, Bold, colorForNumber[2, "Color"], FontFamily -> "Helvetica", FontSize -> 70],
         Show[drawTile[Max[board /. $empty -> 0]], ImageSize -> Small]},
         Alignment -> Center, Spacings -> 5]
       }]
      }]
     ],
     Initialization :> (
       SetOptions[EvaluationNotebook[], NotebookEventActions ->
         {"KeyDown" :>
           With[{key = ToCharacterCode[CurrentValue["EventKey"]][[1]]},
             If[MemberQ[keymap[[All, 1]], key],
               If[!gameover && !won,
                 oldBoard = board;
                 {board, s} = Reap[shift[board, key /. keymap]];
                 If[board =!= oldBoard,
                   tile = newTile[board];
                   board[[Sequence @@ tile[[2]]]] = tile[[1]]
                 ];
                 If[s =!= {}, score += Total[s[[1]]]];
                 Which[Max[board /. $empty -> 0] >= 2048, won = True,
                   !movesAvailable[board], gameover = True];
               ]
             ]
           ]
       }];
       $empty = "";
       keymap = {28 -> "Left", 29 -> "Right", 30 -> "Up", 31 -> "Down"};
       newTile[board : {{__} ..}] := With[{pos = Position[board, $empty]},
         If[pos === {}, {}, {RandomChoice[{.9, .1} -> {2, 4}], RandomChoice[pos]}]];
       combineLeft[l_List] := Flatten[Split[
           Cases[l, Except[$empty]]] //. {a___, x_Integer, x_Integer, b___} :> (Sow[x + x]; {a, {x + x}, b})];
       combineRight[l_List] := Reverse[combineLeft[Reverse[l]]];
       shift[board : {{__} ..}, "Left"] := PadRight[combineLeft[#], Length[board], $empty] & /@ board;
       shift[board : {{__} ..}, "Right"] := PadLeft[combineRight[#], Length[board], $empty] & /@ board;
       shift[board : {{__} ..}, "Up"] := Transpose[shift[Transpose[board], "Left"]];
       shift[board : {{__} ..}, "Down"] := Transpose[shift[Transpose[board], "Right"]];
       matchesAvailable[board : {{__} ..}] :=
           Or @@ (Cases[#, {___, x_Integer, x_Integer, ___}, {1}] =!= {} &) /@ {board, Transpose[board]};
       movesAvailable[board : {{__} ..}] := !FreeQ[board, $empty] || matchesAvailable[board];
       logos = Import[FileNameJoin[{$HomeDirectory, "Downloads", "Spikeys", # <> ".png"}]] &
           /@ {"1", "1b", "2", "3", "4", "5", "6", "7", "8", "9", "alpha"};
       roundedLogos = SetAlphaChannel[#, ColorNegate@Graphics@Rectangle[{0, 0}, ImageDimensions[#],
           RoundingRadius -> 20]] & /@ logos;
       drawTileWolfram[$empty] := Graphics[{$emptyColor, Rectangle[RoundingRadius -> 0.05]}, ImageSize -> 250,
           ContentSelectable -> False, PlotRangePadding -> 0];
       drawTileWolfram[n_Integer] /; IntegerQ[Log2[n]] := Image[roundedLogos[[Log2[n]]], ImageSize -> 250];
       hexToRGB[s_String] := RGBColor @@ (IntegerDigits[FromDigits[StringTake[s, -6], 16], 256, 3]/255.);
       css = Import["http://gabrielecirulli.github.io/2048/style/main.css", "XHTML"];
       colors = StringCases[css, ".tile.tile-" ~~ b : Alternatives @@ ToString /@ Table[2^i, {i, 11}] ~~ " " ~~
           Shortest[___] ~~ "{" ~~ Shortest[a___] ~~ "}"
           :> (Flatten[{b, StringCases[a, {"color: " ~~ Shortest[c__] ~~ ";" :> ("Color" -> c),
                "background: " ~~ Shortest[d__] ~~  ";" :> ("Background" -> d)}]}] /. {_} -> Sequence[])];
       defaultColor = First@StringCases[css, "body {" ~~ Shortest[Except["{"] ..] ~~ "color: " ~~
           Shortest[c__] ~~ ";" ~~ Shortest[Except["}"] ..] ~~ "}" :> c];
       colors = If[!MemberQ[#, "Color", Infinity], #~Join~{"Color" -> defaultColor}, #] & /@ colors;
       colorForNumber[n_Integer, s : "Background" | "Color"] /; MemberQ[Table[2^i, {i, 11}], n] :=
           hexToRGB[First[Cases[colors, {ToString[n], r___} :> (s /. {r})]]];
       colorForNumber[_Integer, "Background"] := hexToRGB["#3c3a32"];
       colorForNumber[_Integer, "Color"] := hexToRGB["#f9f6f2"];
       $emptyColor = RGBColor[0.75436, 0.701427, 0.642634];
       $backgroundColor = RGBColor[0.676677, 0.616403, 0.559747];
       drawTileDefault[$empty] := Graphics[{$emptyColor, Rectangle[RoundingRadius -> 0.05]},
           ImageSize -> 250, ContentSelectable -> False];
       drawTileDefault[n_Integer] := Graphics[{colorForNumber[n, "Background"],
          Rectangle[{-1/2, -1/2}, RoundingRadius -> 0.05],
          colorForNumber[n, "Color"],
          Text[Style[n, Bold, FontFamily -> "Helvetica",
            FontSize -> Scaled[Switch[IntegerLength[n], 1 | 2, .5, 3, .4, _, .34]]], {0, 0}]},
          ImageSize -> 250, ContentSelectable -> False];
      drawGrid[board : {{__} ..}] := Framed[GraphicsGrid[Map[drawTile, board, {2}],
         ContentSelectable -> False, ImageSize -> 450],
         FrameMargins -> 10, Background -> $backgroundColor, RoundingRadius -> 10, FrameStyle -> None];
      drawTile = drawTileDefault;
      
      If[MatchQ[board, {{$empty ..} ..}],
         Do[tile = newTile[board]; board[[Sequence @@ tile[[2]]]] = tile[[1]], {2}]
      ];
    )
   ],
   WindowSize -> {800, 520},
   Background -> White
  ]
]




Attachments:
POSTED BY: Daniel Fortunato
Wow very neat. I case someone is curios - these are some interesting links:

Turns out, there is AI written in Mathematica to win the game - by two mathematicians, Hein Hundal and Carl Cotner, at the Pennsylvania State University. Below are sample plots from their analysis.

Source code:
Mathematica 2048 Simulator

Math behind:
An AI for 2048 — Part 1
An AI for 2048 — Part 2 Cyclic Blind Strategies
An AI for 2048 – Part 3 Biased Random Blind Strategies

And some basic links:

Wikipedia page of 2048
http://en.wikipedia.org/wiki/2048_(video_game)

Developing AI algorithm to win the game from Stack Overflow
What is the optimal algorithm for the game, 2048?

BTW I could not hyperlink the Wikipedia URL.

@Rojo - beautiful variant! - but after some large number of moves interface breaks. Code or Dynamic issue? 

Analysis of random vs Greedy players from Hein Hundal and Carl Cotner blog:



POSTED BY: Sam Carrettie
Posted 10 years ago
Very nice. You could use key handlers. Perhaps one could also handle the winning and losing cases. You made me google this game and waste a lot of minutes emoticon. The version I googled didn't allow you to slide to a side where no tiles would slide, I am not sure if this is general behaviour.

Btw, in general it's a good habit to use lowercase for your symbols, or at least localize them

In any case, here is a possible modification with imo nicer visuals and the key events.
It just replaces your Visual function. Also, I changed the second arguments of Slide to strings
 Shift[list_] := PadRight[Cases[list, Except[0]], 4];
 Merge[list_] :=
   Flatten[list //. {x___, c_, c_, y___} -> {x, {2*c}, y}];
 SlideRow[list_] := Shift[Merge[Shift[list]]];
 Slide[list_, "Left"] := Table[SlideRow[list[[j]]], {j, 1, 4}];
 Slide[list_, "Right"] :=
   Table[Reverse[SlideRow[Reverse[list[[j]]]]], {j, 1, 4}];
 Slide[list_, "Up"] :=
   Transpose[Table[SlideRow[Transpose[list][[j]]], {j, 1, 4}]];
Slide[list_, "Down"] :=
  Transpose[
   Table[Reverse[SlideRow[Reverse[Transpose[list][[j]]]]], {j, 1, 4}]];
RandInsert[list_] :=
ReplacePart[list,
  RandomChoice[Position[list, 0]] -> RandomChoice[{2, 4}]]

Col[n_] :=
  Blend[{Yellow, Cyan, Purple, Red}, ((Log[n + 1]/Log[2]))/11];
(*the tiles,with colors and numbers*)

Nex[list_, move_] :=
If[FreeQ[list, 0], ConstantArray[Infinity, {4, 4}],
  RandInsert[Slide[list, move]]]
(*the update rule*)


tile[n_] :=
Graphics[{{Col[n],
    Rectangle[RoundingRadius -> 0.1]}, {Text[
     Style[n, FontSize -> 20], {0.5, 0.5}]}}]

Visual[game_] :=
Style[Grid[Map[tile, game, {2}],  Frame -> True,
   Selectable -> False],
  "GraphicsBoxOptions" :> {AspectRatio -> 1, ImageSize -> Tiny}]

With[{game :=
   CurrentValue[SelectedNotebook[], {TaggingRules, "game"}]},
With[{nb =
    CreateDialog[{
      Button["Restart", game = ConstantArray[0, {4, 4}]],
      Dynamic@Visual[game]
      },
     Background -> White,
     NotebookEventActions -> (
       Function[key,
         key <> "ArrowKeyDown" :> (game =
            Nex[game, key])] /@ {"Left", "Down", "Up", "Right"})
     ]},
  CurrentValue[nb, {TaggingRules, "game"}] = ConstantArray[0, {4, 4}];
  ]]

If you add the required definitions to the Initialization section of the dialog, then you can save it an open it and start playing at any time without running any code.

POSTED BY: Rui Rojo
Wow, thanks for cleaning up my post! I'll keep those tips in mind, and definitely add the EventHandlers tonight.
POSTED BY: Brady Pelkey
Dear Brady,

I see you just joined Wolfram Community – welcome!

This is very nicely done – especially for a beginner as you say. I will take more careful look at the code – but for what it is already – you are not a beginner any more ;-)

As you asked – a few things.
  • I would set it up in such way that if you enter a letter besides {u,d,l,r} – the game will not break.
  • As a potential remedy to the privios suggestion you cloud try to play with EventHandler and "LeftArrowKeyDown" etc. to make game more interactive and close to original one using keyboard.
  • Note I added a .GIF image to showcase your handiwork
  • I also formatted your code a bit so when it is copied and pasted from Community to a Mathematica notebook it simply works. Main problem was in comments you denoted as // while in Mathematica comments are (* … *).
  • I also used not a general but M-code blocks to have syntax highlighting in your code.
  • For more tricks on posting you can take a look at this tutorial.
  • If you can find a minute would you add some info to your profile page? – It would be very nice to meet you information-wise ;-)
Generally – great job – thanks for sharing!
POSTED BY: Vitaliy Kaurov
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract