twenty-fours

Michael Stern
July 14, 2012

The game of 24s can be perfectly solved using algebraic programming, provided only binary operators are allowed. Four cards picked, ten possibilties for each. This means ten thousand possible hands, or only 715 if we eliminate all redundant hands that can be rearranged to equal each other.

I am allowing addition, multiplication, subtraction, division, powers, roots, and logarithm in this notebook but the code is general enough that this can be easily changed.

A normal user can go directly to the “run the code” section. It will execute the functions it needs from the other parts of the notebook.

setup

allPossibleHandsUnsorted=Tuples[Range[10],4];
allPossibleHandsSorted=Union[Sort/@allPossibleHandsUnsorted];

{Length[allPossibleHandsUnsorted],Length[allPossibleHandsSorted]}

algebraic programming

utility code

algebraic programming

We have a choice -- make our function set commutative, so that {3,2} is processed as both 3-2 and 2-3, or make our card set comprehensive, so that both arrangements are passed through the function. I elected the latter, but the former should work equally well.

steps

Start by finding all the ways of associating four elements.

ClearAll[f];SetAttributes[f,{Flat,OneIdentity}];rawFunctions=Union[FixedPoint[Union[Flatten[ReplaceAllList[#,f[a_,b_]->g[a,b]]]]&,f[a,b,c,d]]/.f->g];

Then we remove all duplicates and expressions that involve the application of g to three elements.

uniqueFunctions=DeleteCases[rawFunctions,_?(Not[FreeQ[#,g[x__/;Length[{x}]≥3]]]&),1];

Finally we replace g by (Subscript[A, 2]),(Subscript[A, 1]),(Subscript[A, 0]), in this order, and swap in the numbers from a hand of cards

functionsWNumbers[hands_List]:=Map[(i=0;MapAll[If[#===g,#/.g->Subscript[A,Mod[++i,3]],#]&,uniqueFunctions,Heads->True]/.{a->#[[1]],b->#[[2]],c->#[[3]],d->#[[4]]})&,hands]

The screening step. I redefine some mathematica functions to limit their inputs and simplify the errors they output in the case of, for example, division by zero. This is intended to speed up processing and reduce memory requirements. It is not otherwise necessary, and it is possible that I am eliminating good solutions here. For example,  I prevent Log from returning imaginary solutions. This may be a bad decision, as some oddball 24s may be found by multiplying two imaginary numbers together. Expanding the input band on power and root to 25 does not yield additional solutions. When I have time, I’ll weaken or remove these constraints further and see if anything additional turns up.

Off[General::"spell1"];Off[General::"spell"];
power[x_?(#>0&),y_?(-16≤#≤16&)]:=(x^y);power[x__]:=Indeterminate;
root[x_Integer?(#>0&),y_Integer?(-16≤#≤16&&#≠0&)]:=(x^(1/y));
root[x__]:=Indeterminate;
divide[x_,y_]/;y≠0:=Divide[x,y];divide[x_,0]:=Indeterminate;
log[x_?(#>0&),y_?(#>0&)]:=Log[x,y];log[x__]:=Indeterminate;

The following step generates every possible combination of operators. For six binary functions, we get 46,646 raw rules but only 216 rules once we constrict it down to four cards and eliminate redundancies. For seven binary functions, 823,543 rules, of which 343 are relevant to the game of 24s.

generateRules[binaryFunctions_List,numCards_Integer]:=Module[{raw,refined,numFuncs},
numFuncs=Length[binaryFunctions];
raw=Map[Thread,Map[RuleDelayed[Array[(Subscript[A, #-1])&,{numFuncs}], #] &,Distribute[Array[binaryFunctions&,{numFuncs}],List]]];
(*In fact,since an actual hand never involves more than three binary operations,we remove the rules involving unnecessaryAs.*)
refined=Union[DeleteCases[raw,Apply[Alternatives,Map[HoldPattern[#]&,Table[(Subscript[A, i]):>_,{i,numCards-1,numFuncs-1}]]],Infinity]];
refined
]

Now we map our selected functions over the generic rules from the previous step.

generateHands[functions_List,rules_List]:=Table[Union[#/.rules]&/@functions[[i]],{i,1,Length[functions]}]

When we get our answers, {1,1,2,2} is treated as distinct from {2,2,1,1}. Let’s fix that. The following assumes the cardSet is a single list of four integers {1,1,2,3}, and that the possibilitySet is a list of {{ordered four cards},{solutions}} like 
{{6,6,6,6},{((6+6)+6)+6,(6+(6+6))+6,(6+6)+(6+6),6+((6+6)+6),6+(6+(6+6)),6 6-(6+6),(6 6-6)-6}}

solutionsForSet[cardSet_List,possibilitySet_List]:=Module[{allVarieties,matches},
allVarieties=Permutations[cardSet];
matches=Select[possibilitySet,MemberQ[allVarieties,#[[1]]]&];
Flatten[matches[[All,2]],1]
]

all together now

legitCombos[hands_List,rules_List]:=Module[{functionsWithNumbers,everythingGeneratedFromTheseHands,patterns,allSolns},
functionsWithNumbers=
functionsWNumbers[hands];
everythingGeneratedFromTheseHands=generateHands[functionsWithNumbers,rules];
(* now find all the combinations that equal 24. This is the slow step *)
patterns=Table[Union[Flatten[Union[Flatten[Union[HoldForm[#]/.rules]]]&/@functionsWithNumbers[[i]]]],{i,1,Length[functionsWithNumbers]}];
(* print it out, replacing our constrained versions of the selected functions with Mathematica's native versions for pretty output *)
allSolns=Table[{hands[[i]],Select[patterns[[i]],ReleaseHold[#]==24&]},{i,1,Length[functionsWithNumbers]}]/.{divide->Divide,power->Power,log->Log};
Map[{#,solutionsForSet[#,allSolns]}&,allPossibleHandsSorted]
]

Given an answer list in the format discussed above, and a hand in list form, return all solutions pertaining to that hand.

getAnswers[hand_List,solutions_List]:=Select[solutions,#[[1]]==Sort[hand]&]

run the code

If the screening step is done perfectly, it may be possible to skip the following line, which suppresses error reports on division by zero and the like.

Off[Divide::indet];
Off[Power::infy];
Off[Greater::nord];
Off[Infinity::indet];
Off[N::meprec];
Off[LessEqual::nord];
Off[General::ovfl];

rules=generateRules[{Times, Plus,Subtract,divide,power,root,log},4];

sortedPossibilities=legitCombos[allPossibleHandsUnsorted,rules]; (* this is the slow step *)

(an example follows, pulling the results for the cards 4, 3, 4, and 1)

getAnswers[{4,2,4,1},sortedPossibilities]

On[Divide::indet];
On[Power::infy];
On[Greater::nord];
On[Infinity::indet];
On[N::meprec];
On[LessEqual::nord];
On[General::ovfl];

analysis

solvable hands

566 with just arithmatics, 595 if we add roots, powers, and logs. (619 if we add Mod, though that is not shown in this notebook).

unsolveable hands

unsolvableHands=Select[sortedPossibilities,Length[#[[2]]]==0&][[All,1]]

((Length[unsolvableHands])/(Length[allPossibleHandsSorted]))//N

So about 17% are unsolvable,  83% are solvable.

unique solutions

solvableHands=Select[sortedPossibilities,Length[#[[2]]]>0&];

uniqueSolutions=Select[solvableHands,Length[#[[2]]]==1&]

Only eight hands have unique solutions, though this list omits some trivial variations that a human would recognize as identical.

easiest to solve

mostSolutions=Length[First[Sort[solvableHands,Length[#1[[2]]]>Length[#2[[2]]]&]][[2]]]

Select[solvableHands,Length[#[[2]]]==mostSolutions&][[All,1]]

There are two hands — {1,1,3,8} and {1,1,4,6} that each have 522 solutions by the standards given. These are by this test the easiest hands in the game.

graph of number of solutions by hand

solutionsByHand=Table[{i,Length[sortedPossibilities[[i]][[2]]]},{i,1,Length[sortedPossibilities]}];

BarChart[solutionsByHand[[All,2]],PerformanceGoal->"Speed",BarSpacing->None,PlotLabel->"Number of Solutions",AxesLabel->{"canonical\nhand index",None}]

histogram by number of hands with each count of solutions

Histogram[solutionsByHand[[All,2]],500,PerformanceGoal->"Speed",PlotRange->{{0,80},Automatic},PlotLabel->"Number of canonical hands with x solutions",AxesLabel->{"number of\nsolutions","number\nof hands"},AxesOrigin->{0,0}]

notes & to-do

How can we eliminate trivial variations like 8 (1 2+1) and 8 (1+2 1)?

What formulae are most successful in yielding answers?

Optimize the constraint functions to yield all answers in minimal time

ISSUES WITH THE FRONT-END DISPLAY PROCESSOR:
	1. It sometimes declines to display 1*x, showing only x instead.
	2. How do we get root[x,y] to show up as (x^(1/y)) in the answers?
	3. Ditto for attractive formatting of Log[x,y].
	
The code seems highly parallelizable, and should run much more quickly if rewritten to take advantage of multiple cores.