Hunt for expressions yielding 2026

Introduction

This notebook has code for finding arithmetic expressions that evaluation to 2026. It is a comment on the Wolfram Community post "Happy √2²²-22 -- And other ways to calculate 2026" by Ed Pegg.
The idea is simple: generate many random expressions that adhere to certain constraints and pick those that produce the target number.
If we consider each expression to be a sentence of a certain grammar here the main constraints for that grammar:
◼
  • All digits from 1 to 9 must appear in a sentence
    • ◼
  • 2 is after 1, 3 is after 2, etc.
    • ◼
  • The arithmetic signs and factorial sign can follow any digit
    • ◼
  • Each sentence is a correct mathematical expression
    • In order to make computations faster, in the code below in the integer expressions are inserts “.” signs.
    Remark: The code below is by no mean exhaustive. Changing the weights or the order of the digits would produce different results. YMMV.

    Random generation

    In[]:=
    digits=ToString/@Range[1,9];
    In[]:=
    signs={"",".+",".-",".*","./",".^","!*","!+","!-"};
    In[]:=
    AbsoluteTiming[candidates=StringJoin/@Table[Riffle[digits,RandomChoice[Prepend[Table[1,Length[signs]-1],4]->signs,8]],5000000];​​]
    Out[]=
    {10.5011,Null}
    In[]:=
    AbsoluteTiming[​​candidates=Union[candidates];​​]​​Length[candidates]
    Out[]=
    {12.2179,Null}
    Out[]=
    3468320
    In[]:=
    AbsoluteTiming[​​candidates=Map[#<>"."&,candidates];​​]
    Out[]=
    {1.55792,Null}
    In[]:=
    RandomSample[candidates,10]
    Out[]=
    {1.*2!*3./45.+6./7.*8!+9.,1.^2!*34!*5.+67.*8!-9.,1.^2.*3.-4.+5.-6./7.^8.+9.,1.-2.*3./45!-6.*78.^9.,1./2./3.^456!*7.+89.,1.+2.+3.-4.^5!+6!-789.,12!+3.^4!+5!*678!+9.,1./2!*3.+4.^5.-6.^7.-89.,12./3.-4.*5./6!*7./8.*9.,1!-2.*3.*4!-56.*78.-9.}
    In[]:=
    AbsoluteTiming[​​candidateResults=ParallelMap[TimeConstrained[ToExpression[#],0.001]&,candidates,Method->"CoarsestGrained"];​​]
    Out[]=
    {50.2701,Null}
    In[]:=
    AbsoluteTiming[​​pos=Flatten@Position[candidateResults,x_/;(Abs[x-2026]≤0.1)]​​]
    Out[]=
    {2.72288,{2806520,2959041,3374415}}
    In[]:=
    candidates〚pos〛
    Out[]=
    {12./3!*4.^5.+67.-89.,12.^3.+45./6!*7!-8.-9.,123./4!*56.*7.+8.+9.}
    In[]:=
    ToExpression/@candidates〚pos〛
    Out[]=
    {2026.,2026.,2026.}

    Saved expressions

    The ones with “✓” are in the original post by Ed Pegg.
    In[]:=
    res=Union@Map[StringReplace[#,"."->""]&,candidates〚pos〛]
    Out[]=
    {12/3!*4^5+67-89,12^3+45/6!*7!-8-9,123/4!*56*7+8+9}
    In[]:=
    {​​1+2*3/4/5/6*7!*8+9,​​1+2+3*4!+5/6!*7*8!-9,​​1+2+345*6-7*8+9,(*✓*)​​1-2*3!*456*7+8!+9,​​12/3!*4^5+67-89,​​12^3+45/6!*7!-8-9,​​123/4!*56*7+8+9(*✓*)​​}
    Out[]=
    {2026,2026,2026,2026,2026,2026,2026}