Skip to content

Instantly share code, notes, and snippets.

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

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 = 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 = makeGraph; (* 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 = deDupeBy[FindCycle[diceGraph, 10, All], Sort[(# /. {e_, "White"} -> {e})] &]; CountsBy[cycles, Length] cycles // Length (* output: <|3 -> 5, 4 -> 5, 5 -> 2, 6 -> 15, 7 -> 20, 8 -> 20, 9 -> 10, 10 -> 3|> 80 *)
 (* all unique dice pairs *) allDice = 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[], right[]]], {_, 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 = makeGraph; cycles = Select[FindCycle[diceGraph, 5, All], isValidCycle]; CountsBy[cycles, Length] cycles // 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 = Select[ Flatten[Table[combine @@ allColors[[{i, j, k}]], {i, 1, Length[allColors]}, {j, i, Length[allColors]}, {k, j, Length[allColors]}], 2], Length@Union@#[] != 1 &]; diceGraph = makeGraph;
 (* 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] /. DirectedEdge[a_, b_] :> ({DirectedEdge[a, b], #} & /@ EdgeList[diceGraph, 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], lastEdge], ( cycle = {DirectedEdge[a, b], DirectedEdge[c, d], lastEdge}; If[isValidCycle[cycle], Sow[cycle] ]) ] );
 cycles = deDupeBy[Reap[Scan[completeCycle @@ # &, edgePairs]][[2, 1]], Sort]; CountsBy[cycles, 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 plotCycle /@ cycles plotCycle /@ cycles
to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.