Skip to content

Instantly share code, notes, and snippets.

@latkin latkin/readme.md
Last active Aug 29, 2015

Embed
What would you like to do?
Blog: Non-transitive dice
(* 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}};
(* 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]}
);
compareDice[red, blue]
compareDice[magenta, yellow]
(* output:
{{"Red"} -> {"Blue"}, 0.583}
{{"Yellow"} -> {"Magenta"}, 0.556}
*)
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}}
*)
(* 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}}
*)
(* 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];
(* 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}}]];
(* 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[__]]];
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
*)
(* 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
*)
(* 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];
(* 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]
])
]
);
cycles[3] = deDupeBy[Reap[Scan[completeCycle @@ # &, edgePairs]][[2, 1]], Sort];
CountsBy[cycles[3], Length]
(* output:
<|3 -> 49|>
*)
(* '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)}];
(* plot everything! *)
plotCycle /@ cycles[1]
plotCycle /@ cycles[2]
plotCycle /@ cycles[3]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.