# Nice formatting for the results of a dice game simulation

One of my Mathematica interests is in problems related to the formatting of output. Getting nice formatting from Mathematica is often frustrating, but occasionally Mathematica will delight me by making a formatting task, which I anticipated would be difficult, easy. I want to share one such recent experience by posing it as a question.

Can you create a 10-row, 5-column table in Mathematica presenting the results from running a dice game simulation in which a pair of dice is rolled 50 times?

The table should look like this:

Your solution may show a different sequence of dice rolls. Note that rolls of seven are highlighted in red. That feature must be reproduced.

I post this question, not because it is difficult (it isn't), but because I had fun with it myself. I will post my answer in 48 hours, providing nobody posts an equivalent answer beforehand.

We have unicode support so we can use the following strings: {"⚀", "⚁", "⚂", "⚃", "⚄", "⚅"}:

dice = FromCharacterCode /@ Range[9856, 9856 + 5];
Grid[Partition[RandomInteger[{1, 6}, {50, 2}], 5] /. {
i : {__Integer} :> Style[
Row[dice[[i]], Spacer[1]],
{Large, Total[i] /. {7 -> Red, _ -> Black}}]}
, Frame -> All]

• Well done! Very close to my own solution. Commented Oct 28, 2013 at 0:07
• +1 very concise. My favourite of the answers here Commented Oct 29, 2013 at 1:05
• A variation: dice = CharacterRange["\:2680", "\:2685"]; Grid[Map[Style[Row[#, Spacer[1]], {Large, If[Total[ToCharacterCode[#], ∞] - 19710 == 6, Red, Black]}] &, Partition[RandomChoice[dice, {50, 2}], 5], {2}], Frame -> All]. Commented Oct 15, 2015 at 16:28
• These character codes do not display in Mma 11.1 under Win 10.
– Alan
Commented Sep 19, 2017 at 18:35

The power of Mathematica's syntax allows us to create dice in several different ways. Here's one way that I like:

dice[n_Integer] := dice[n, Black]
Format[dice[n_Integer, c_]] := With[{
dots = {1 -> {5}, 2 -> {3, 7}, 3 -> {3, 5, 7}, 4 -> {1, 3, 7, 9},
5 -> {1, 3, 5, 7, 9}, 6 -> {1, 2, 3, 7, 8, 9}} /.
l : {__Integer} :> Sequence @@ Thread[l -> Graphics[{c, Disk[]}, ImageSize -> 16]],
face = Partition[Range@9, 3]},

Panel[Grid[face /. {n /. dots, _Integer -> Null}, ItemSize -> All]]
]

This gives a pretty nice looking set of die faces (since the display is entirely 2D, I didn't think it was worth the effort to construct a 3D die):

dice /@ Range@6 // Row

By keeping dice symbolic and only modifying the display via Format, we can utilize the structure for the kind of modifications you had in mind (e.g. coloring total 7 with red).

With this basic structure, the 50 rolls of a pair of dice can be simulated concisely as:

With[{trials = RandomInteger[{1, 6}, {10, 5, 2}]},
Grid[trials /. l : {__Integer} :> Row[dice /@ l], Frame -> All]
] /. l : {dice[n_, _], dice[m_, _]} /; m + n == 7 :> (l /. Black -> Red)

• +1 I wish I could understand it once... (Not your fault, I hasten to add.) Commented Oct 27, 2013 at 19:39
• @cor If you assume that each die face is a 0/1 3x3 matrix withs 1 as the dot, then the faces can be represented by just the position of the 1s. I create a 3x3 grid like a telephone dial pad (sans the zero) and replace the positions of the dots with a disk and Null otherwise. I leave the arrangement to Grid (which automatically puts a blank space for Null), set ItemSize -> All to make it square and use Panel for the pretty (IMO) grey rounded rectangle. Only the display is modified; the structure still is dice[n, Black] and not Graphics, which I then manipulate to change the color.
– rm -rf
Commented Oct 27, 2013 at 20:11
• @cormullion Ah, that... In the first code block, you can try evaluating just the dots = ... line and see what you get (remove the c). So dots essentially is a set of nested rules for each face. Later, in the Panel line, I replace the chosen die number with the set of rules that indicate where the dots lie. These rules in turn replace the respective numbers in the dial pad matrix. The remaining numbers are set to Null. It is important that the two rules are in a list and not one after the other, as then the _Integer -> Null rule will blow everything away.
– rm -rf
Commented Oct 27, 2013 at 20:28
• In the second code block, I first replace pairs of numbers (a single trial) with their respective die face and the next two /. are to replace trials that total 7 with red dies. Replacement rules are quite fun! :)
– rm -rf
Commented Oct 27, 2013 at 20:29
• Cool. I'll upvote your comments in lieu of a +2... Commented Oct 27, 2013 at 20:36

After importing a free dice 3D model

{pd, vd} = Import["c:\\dice.stl", #] & /@ {"PolygonData", "VertexData"};
g2 = Translate[GraphicsComplex[vd, Polygon /@ pd], {-10, -37.5, -10}];
rv = {{0, 0, -1}, {0, -1, 0}, {0, 0, 1}, {0, 1, 0}, {-1, 0, 0}, {1, 0, 0}};
dice[x_List, n_Integer] :=
Rasterize@(Graphics3D[{EdgeForm[None], Blue, Rotate[g2,{{0, 0, 1}, rv[[x]][[n]]}]},
Boxed -> False]/. Blue :> Red /; Tr@x == 7)
ri = RandomInteger[{1, 6}, {50, 2}];
GraphicsGrid[Partition[GraphicsRow[{dice[#,1], dice[#,2]}] & /@ ri, 5],
Frame->All, ImageSize -> 700]

• +1 it had to be done! Now can you make them spin rapidly for a time (increasing through the table)... Commented Oct 28, 2013 at 8:47
• @cormullion Not difficult to do, but almost impossible to post as an animation (the resulting file will be huge) Commented Oct 28, 2013 at 11:41

Here's one way, borrowing heavily from one of the Wolfram demonstrations.

dicelist[rb_] := {{rb, Disk[{0, 0}, 0.2]}, {rb, Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {rb, Disk[{0, 0}, 0.2], Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2]}, {rb, Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2], Disk[{-0.6, 0.6}, 0.2]}, {rb, Disk[{0, 0}, 0.2], Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2], Disk[{-0.6, 0.6}, 0.2]}, {rb, Disk[{-0.6, 0}, 0.2], Disk[{0.6, 0}, 0.2], Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2], Disk[{-0.6, 0.6}, 0.2]}};
dice[i_, col_] := Graphics[{{White, EdgeForm[Directive[col, Thickness[0.02]]], Rectangle[{-1, -1}, {1, 1}]}, If[MemberQ[Range[1, 6], i], Part[dicelist[col], i], {}]}, ImageSize -> 50];

pair := (roll = RandomInteger[{1, 6}, 2];
If[Total[roll] == 7, col = Red, col = Black]; dice[#, col] & /@ roll)

For example, simply typing pair creates a pair of dice that are red if the sum is seven and black otherwise. These can be put into a table:

GraphicsColumn[Table[GraphicsRow[ Flatten[{pair, , pair, , pair, , pair, , pair}]],{i,10}]]

Using the same (well slightly modified) Wolfram demonstrations code as bill s

dicelist = {{Disk[{0, 0}, 0.2]}, {Disk[{0.6, 0.6}, 0.2],
Disk[{-0.6, -0.6}, 0.2]}, {Disk[{0, 0}, 0.2],
Disk[{0.6, 0.6}, 0.2],
Disk[{-0.6, -0.6}, 0.2]}, {Disk[{0.6, 0.6}, 0.2],
Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2],
Disk[{-0.6, 0.6}, 0.2]}, {Disk[{0, 0}, 0.2],
Disk[{0.6, 0.6}, 0.2], Disk[{-0.6, -0.6}, 0.2],
Disk[{0.6, -0.6}, 0.2],
Disk[{-0.6, 0.6}, 0.2]}, {Disk[{-0.6, 0}, 0.2],
Disk[{0.6, 0}, 0.2], Disk[{0.6, 0.6}, 0.2],
Disk[{-0.6, -0.6}, 0.2], Disk[{0.6, -0.6}, 0.2],
Disk[{-0.6, 0.6}, 0.2]}};

Dice[i_, colour_] :=
Graphics[{{White, EdgeForm[Directive[colour, AbsoluteThickness[2]]],
Rectangle[{-1, -1}, {1, 1}]}, colour, Part[dicelist, i]},
ImageSize -> 25];

I then create the dice rolls:

tmp = Fold[Partition[#1, #2] &, RandomChoice[Range[6], 100], {2, 5}]

and display them in a way that has each dice "aligned" left and right within a grid element with the space between the dice much larger than the spacing between the grid elements (as per picture in the question):

Grid[
Map[If[Total[#] == 7,
Row[{Dice[#[[1]], Red], Dice[#[[2]], Red]}, Spacer[15]],
Row[{Dice[#[[1]], Black], Dice[#[[2]], Black]}, Spacer[15]]] &,
tmp, {2}],
Frame -> All,
FrameStyle -> AbsoluteThickness[2],
Spacings -> {1, 1}]

Possible tweeks include adjusting the divider thickness in the grid and the Row spacer. Personally I prefer thinner lines and frames around the dice but am trying to match the example in the question. This is with AbsoluteThickness[0.5]

• (+1) Your second example is certainly easier on the eye! I would prefer light gray lines myself, or even no lines and tighter spaces. Commented Oct 27, 2013 at 9:00
• I like your first version. It reproduces my result in all its ugly glory. Commented Oct 27, 2013 at 11:40
• @m_goldberg yes I was trying to mimic what you posted rather than produce it the way I would have it :) Commented Oct 27, 2013 at 20:26

Another dice:

dots = {{{2, 2}}, {{0.85, 0.85}, {3.15, 3.15}}, {{0.85, 0.85}, {2, 2},
{3.15, 3.15}}, {{0.85, 3.15}, {0.85, 0.85}, {3.15, 3.15}, {3.15, 0.85}},
{{0.85, 3.15}, {0.85, 0.85}, {2, 2}, {3.15, 3.15}, {3.15, 0.85}},
{{0.85, 3.15}, {0.85, 0.85}, {3.15, 3.15}, {3.15, 0.85}, {0.85, 2}, {3.15, 2}}};

dice[i_, color_: GrayLevel[0]] :=
Graphics[
{GrayLevel[0.94], EdgeForm[color], Polygon[{{0, 0}, {0, 4}, {4, 4}, {4, 0}}],
{color, EdgeForm[color], Disk[#, 0.45] & /@ dots[[i]]}}, ImageSize -> 30]

twoDice[{i_, j_}] /; (i + j == 7) := Row[{dice[i, Red], dice[j, Red]}, Spacer[5]]
twoDice[{i_, j_}] := Row[{dice[i], dice[j]}, Spacer[5]]

role := twoDice[RandomChoice[Range[6], 2]]

Grid[Table[role, {i, 10}, {j, 5}], Frame -> All, Spacings -> {2, 1}, FrameStyle -> GrayLevel[.8]]

When I posted this question, I said I wouldn't post my answer if someone else posted an equivalent one, but here I am doing it. Am I going back on my word?. The answer given by ssch is close enough to mine to qualify as equivalent for all practical purposes. However, although both our answers are based on the same insight: that no graphics are needed because the job can be done with Unicode text characters, I think the two implementations differ enough to justify showing my code.

My implementation is based on a styling function, which takes a pair of integers representing the dice roll and an integer giving the font size. It returns a Style expression that packages everything up nicely, all ready for the grid.

With[{faceZero = 16^^267f},
diceStyle[{dots1_, dots2_}, fontSize_] :=
Style[
FromCharacterCode[faceZero + dots1] <> " " <> FromCharacterCode[faceZero + dots2],
If[dots1 + dots2 == 7, Red, Black],
fontSize]]

A little unit testing is always in order.

diceStyle[#, 36] & /@ {{1, 1}, {3, 4}} // FullForm
List[Style["\:2680 \:2680", GrayLevel[0], 36],
Style["\:2682 \:2683", RGBColor[1, 0, 0], 36]]

Given this special styling for integer pairs, the grid I showed in my question can be generated quite concisely.

SeedRandom @ 1;
Grid[Table[diceStyle[RandomInteger[{1, 6}, 2], 36], {10}, {5}],
Dividers -> All, Spacings -> {Automatic, {{.75}}}]
• Please post an image ... :) Commented Oct 29, 2013 at 0:19