Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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:

dice.png

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.

share|improve this question

7 Answers 7

up vote 20 down vote accepted

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]

dice grid

share|improve this answer
    
Well done! Very close to my own solution. –  m_goldberg Oct 28 '13 at 0:07
    
+1 very concise. My favourite of the answers here –  Mike Honeychurch Oct 29 '13 at 1:05

The power of Mathematica's syntax allows us to create a 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 dice):

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)

enter image description here

share|improve this answer
3  
+1. I wish I could up vote this twice. –  RunnyKine Oct 27 '13 at 13:37
1  
+1 I wish I could understand it once... (Not your fault, I hasten to add.) –  cormullion Oct 27 '13 at 19:39
1  
@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 Oct 27 '13 at 20:11
1  
@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 Oct 27 '13 at 20:28
1  
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 Oct 27 '13 at 20:29

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]

enter image description here

share|improve this answer
1  
+1 it had to be done! Now can you make them spin rapidly for a time (increasing through the table)... –  cormullion Oct 28 '13 at 8:47
    
@cormullion Not difficult to do, but almost impossible to post as an animation (the resulting file will be huge) –  belisarius Oct 28 '13 at 11:41
    
+1 nice. + other characters to satisfy minimum comment length –  Mike Honeychurch Oct 29 '13 at 1:04

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

enter image description here

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]

enter image description here

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

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

enter image description here

share|improve this answer

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

enter image description here

share|improve this answer

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}}}]
share|improve this answer
1  
Please post an image ... :) –  belisarius Oct 29 '13 at 0:19

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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