Blog: Non-transitive dice

readme.md

Sample code from blog post Non-transitive Grime Dice, via Mathematica.

snip01.nb

(* represent the dice, their names, and their face values *)
red = dice["Red"] = {{"Red"}, {4, 4, 4, 4, 4, 9}};
blue = dice["Blue"] = {{"Blue"}, {2, 2, 2, 7, 7, 7}};
olive = dice["Olive"] = {{"Olive"}, {0, 5, 5, 5, 5, 5}};
yellow = dice["Yellow"] = {{"Yellow"}, {3, 3, 3, 3, 8, 8}};
magenta = dice["Magenta"] = {{"Magenta"}, {1, 1, 6, 6, 6, 6}};

snip02.nb

(* compute which of two dice would win, including the odds *)
(* returns {winner -> loser, odds} *)
compareDice[{lName_, lVals_}, {rName_, rVals_}] := (
  rolls = Tuples[{lVals, rVals}];
  winDiff = Total[rolls /. {l_, r_} -> Sign[r - l]];
  odds = 1/2 +  Abs[winDiff]/(2*Length[rolls]);
  {If[winDiff > 0, rName -> lName, lName -> rName], N[odds, 3]}
);

snip03.nb

compareDice[red, blue]
compareDice[magenta, yellow]
 
(* output:
    {{"Red"} -> {"Blue"}, 0.583}
    {{"Yellow"} -> {"Magenta"}, 0.556}
*)

snip04.nb

byWordLength = {{red, blue}, {blue, olive}, {olive, yellow}, {yellow, magenta}, {magenta, red}};
byAlpha = {{blue, magenta}, {magenta, olive}, {olive, red}, {red, yellow}, {yellow, blue}};

compareDice @@@ byWordLength
compareDice @@@ byAlpha

(* output:
  {{{"Red"} -> {"Blue"}, 0.583}, {{"Blue"} -> {"Olive"}, 0.583}, {{"Olive"} -> {"Yellow"}, 0.556}, {{"Yellow"} -> {"Magenta"}, 0.556}, {{"Magenta"} -> {"Red"}, 0.556}}
  {{{"Blue"} -> {"Magenta"}, 0.667}, {{"Magenta"} -> {"Olive"}, 0.722}, {{"Olive"} -> {"Red"}, 0.694}, {{"Red"} -> {"Yellow"}, 0.722}, {{"Yellow"} -> {"Blue"}, 0.667}}
 *)

snip05.nb

(* create a new "die" by combining two dice *)
combine[{name1_, vals1_}, {name2_, vals2_}] := {Join[name1, name2], Plus @@@ Tuples[{vals1, vals2}]};
double[die_] := combine[die, die];

compareDice @@@ Map[double, byWordLength, {2}]
compareDice @@@ Map[double, byAlpha, {2}]

(* output
  {{{"Blue", "Blue"} -> {"Red", "Red"}, 0.590}, {{"Olive", "Olive"} -> {"Blue", "Blue"}, 0.590}, {{"Yellow", "Yellow"} -> {"Olive", "Olive"}, 0.691}, {{"Magenta", "Magenta"} -> {"Yellow", "Yellow"}, 0.593}, {{"Red", "Red"} -> {"Magenta", "Magenta"}, 0.691}}
  {{{"Blue", "Blue"} -> {"Magenta", "Magenta"}, 0.556}, {{"Magenta", "Magenta"} -> {"Olive", "Olive"}, 0.583}, {{"Red", "Red"} -> {"Olive", "Olive"}, 0.518}, {{"Red", "Red"} -> {"Yellow", "Yellow"}, 0.583}, {{"Yellow", "Yellow"} -> {"Blue", "Blue"}, 0.556}}
*)

snip06.nb

(* keep track of which colors should be used in plots *)
colors["Red"] = Red;
colors["Blue"] = Blue;
colors["Olive"] = Green;
colors["Yellow"] = Yellow;
colors["Magenta"] = Purple;

(* plot colored rectangles to represent the dice at a graph vertex *)
getVertex[center_, names_] := (
  numDice = Length@names;
  positions = {-0.08 + #, 0.08 + #} & /@ 
    Range[-0.04*(numDice - 1)/2, 0.04*(numDice - 1)/2, 0.04];
  Transpose[{colors /@ names, Rectangle[center + #1, center + #2, RoundingRadius -> 0.02] & @@@ positions}]
  );

(* plot a nicely-formatted labeled arrow for graph edges *)
getEdge =
  ({Gray, If[#3 == 0.5, Line[#1], Arrow[#1, 0.15]], Black, 
     Inset[#3, Mean[#1], Background -> White]} &);

(* given a list of dice pairs, creates a nicely-formatted plot of
winning relationships and odds *)
plotDice[pairs_] :=
 GraphPlot[compareDice @@@ pairs,
  VertexRenderingFunction -> getVertex,
  EdgeRenderingFunction -> getEdge];

snip07.nb

(* dummy "white" die used to differentiate between 
two instances of the same color die *)
white = dice["White"] = {{"White"}, {0}};

(* when plotting, just make the white die invisible *)
colors["White"] = Transparent;

(* all distinct single dice from set of 10 *)
allDice[1] = 
  Join[allColors, combine @@@ Tuples[{allColors, {white}}]];

snip08.nb

(* Note that we don't return an edge here if the 2 dice are equally matched *)
getGraphEdge[left_, right_] := (
  {relationship, odds} = compareDice[left, right];
  If[odds != 1/2, relationship /. Rule -> DirectedEdge]
);

(* builds the graph of winning relationships for
n-tuples of dice *)
makeGraph[n_] := 
 Graph[Cases[getGraphEdge @@@ Subsets[allDice[n], {2}], DirectedEdge[__]]];

snip09.nb

diceGraph[1] = makeGraph[1];

(* built-in function DeleteDuplicatesBy is present only
in Mathematica 10+ *)
deDupeBy[expr_, f_] := Values[GroupBy[expr, f, First]];

(* compute all cycles of single dice that can
be made from the 10 included dice *)
cycles[1] = 
  deDupeBy[FindCycle[diceGraph[1], 10, All], 
   Sort[(# /. {e_, "White"} -> {e})] &];
   
CountsBy[cycles[1], Length]
cycles[1] // Length

(* output:
  <|3 -> 5, 4 -> 5, 5 -> 2, 6 -> 15, 7 -> 20, 8 -> 20, 9 -> 10, 10 -> 3|>
  80
*)

snip10.nb

(* all unique dice pairs *)
allDice[2] = Flatten[Table[combine @@ allColors[[{i, j}]],
    {i, 1, Length[allColors]},
    {j, i, Length[allColors]}], 1];

(* updated to avoid creating edges between nodes 
that combine to use more than 2 of any color *)
getGraphEdge[left_, right_] :=
 If[FreeQ[Tally[Join[left[[1]], right[[1]]]], {_, count_} /; count > 2],
  {relationship, odds} = compareDice[left, right];
  If[odds != 1/2, relationship /. Rule -> DirectedEdge]
 ];

(* check if a given full cycle uses more than 2 of
any particular color *)
isValidCycle[cyc_] :=
  FreeQ[Tally[Flatten[cyc /. DirectedEdge[a_, _] :> a]], {_, count_} /; count > 2];

(* compute all cycles of pairs of dice that can
be made from the 10 included dice *)
diceGraph[2] = makeGraph[2];
cycles[2] = Select[FindCycle[diceGraph[2], 5, All], isValidCycle];

CountsBy[cycles[2], Length]
cycles[2] // Length
(* output:
  <|3 -> 55, 4 -> 89, 5 -> 25|>
  169
*)

snip11.nb

(* extend to handle triples *)
combine[die1_, die2_, die3_] := combine[die1, combine[die2, die3]];

(* all unique dice triples *)
allDice[3] = Select[
   Flatten[Table[combine @@ allColors[[{i, j, k}]],
     {i, 1, Length[allColors]},
     {j, i, Length[allColors]},
     {k, j, Length[allColors]}], 2],
   Length@Union@#[[1]] != 1 &];

diceGraph[3] = makeGraph[3];

snip12.nb

(* for each edge in the graph, collect potential second edges
e.g. for edge A -> B, find all pairs {{A -> B, B -> X},{A -> B, B -> Y}, ...} *)
edgePairs = 
  Flatten[EdgeList[diceGraph[3]] /. 
    DirectedEdge[a_, b_] :> ({DirectedEdge[a, b], #} & /@ 
       EdgeList[diceGraph[3], DirectedEdge[b, _]]), 1];

(* find and validate the 3rd and final edge of a 3-cycle.
e.g. given {A -> B, B -> C}, check that C -> A exists, and 
the cycle A -> B -> C -> A is valid *)
completeCycle[DirectedEdge[a_, b_], DirectedEdge[c_, d_]] := (
   lastEdge = DirectedEdge[d, a];
   If[MemberQ[EdgeList[diceGraph[3]], lastEdge], (
     cycle = {DirectedEdge[a, b], DirectedEdge[c, d], lastEdge};
     If[isValidCycle[cycle],
      Sow[cycle]
     ])
   ]
);

snip13.nb

cycles[3] = deDupeBy[Reap[Scan[completeCycle @@ # &, edgePairs]][[2, 1]], Sort];

CountsBy[cycles[3], Length]

(* output:
  <|3 -> 49|>
*)

snip14.nb

(* 'combining' a single die is a no-op *)
combine[{name1_, vals1_}] := {name1, vals1};

(* plot a single non-transitive dice cycle *)
plotCycle[cyc_] :=
  plotDice[cyc /. DirectedEdge[l_, r_] :> {combine @@ (dice /@ l), combine @@ (dice /@ r)}];

snip15.nb

(* plot everything! *)
plotCycle /@ cycles[1]
plotCycle /@ cycles[2]
plotCycle /@ cycles[3]