Problem

Given a positive integer, output all possible valid prime-factorization "statements" thereof created by inserting zero or more multiplication (*) symbols and zero or more power (^) symbols into the digit sequence of the integer. Each statement is to be paired with the number of decimal digits in the "ToExpression" calculation of it and the entire list should be sorted by increasing "ToExpression" size.

In order for a prime-factorization statement to be valid, it must satisfy the following conditions:

  • A single prime with or without an exponent is an acceptable output.
  • It must be (broadly speaking) the product of powers of (left to right) strictly increasing primes.
  • No prime and no exponent may begin with a zero.
  • Because primes with an exponent of one are expressed without an exponent, no exponent may ever be one.

Here are some small inputs and their outputs:

11 -> {{11, 2}}; 12 -> {}; 23 -> {{2*3, 1}, {2^3, 1}, {23, 2}}; 24 -> {{2^4, 2}}; 235 -> {{2*3*5, 2}, {2^3*5, 2}, {2*3^5, 3}, {23^5, 7}, {2^35, 11}}; 531 -> {{5*31, 3}, {5^31, 22}}; 1111 -> {{11^11, 12}}; 7013 -> {{7013, 4}, {701^3, 9}}.

The procedure should be able to correctly handle large input integers even though this might result in long computes or oversized outputs. The sorting and sizing will obviously need to be done by arithmetic subterfuge. Here is a large input and its output:

4856435684257889399168067723732710466864629267287 -> {{4856435684257889^3*99168067723732710466864629267287, 80}, {4856435684257889^3991*68067723732710466864629267^287, 70019}, {4856435684257889^3991*68067723732710466864629^267287, 6165553}, {4856435684257889^399168067*723732710466864629267287, 6261477116}, {48564356842578893991680677237^32710466864629267287, 938342842682884262823}, {4856435684257889^399168067723732710466864629267287, 6261477102687158365511012881413778}}

up vote 4 down vote accepted
func[n_]:=
Module[{f=Not@*PrimeQ@*ToExpression,seqs,splits,len
        , digits=IntegerDigits@n,find,times,power,out},

power[a_,b_]:=ToString@a<>"^"<>ToString@b;
times[a_,b_]:=ToString@a<>"*"<>ToString@b;

seqs=SequencePosition[digits,_?(PrimeQ@*FromDigits),Overlaps->All];

splits = 
With[{r = Flatten[
   ReplaceList[#, {{{x___}, {___, {a_, b_}, y___}} /; 
          If[Length@{x} > 0, 
           FromDigits[Take[digits, {a, b}]] > 
            FromDigits[Take[digits, Last@{x}]], 
           True] :> {{x, {a, b}}, 
          Select[{y}, #[[1]] > b &]}
   , {{x___}, {}} :> {{x}, {}}}] & /@ #, 1] &}, 
Flatten[FixedPointList[r, 
     Select[r@{{{}, seqs}}, #[[1, 1, 1]] == 1 &]][[;; , ;; , 1]]
, 1] /. {x___, {a_, b_}} /; 
    b < Length@digits :> {x, {a, b}, {b + 1, Length@digits}} //. 
    {x___, {a_, b_}, {c_, d_}, y___} /; 
   b < c - 1 :> {x, {a, b}, {b + 1, c - 1}, {c, d}, y} // 
DeleteDuplicates];


find[m_List]:=
 Select[StringJoin/@
   DeleteCases[
     StringSplit[Union@Groupings[m,{times->2,power->2}]
     , {"*"->"*","^"->"^"}]
   , {___,"^",_,"^",___}|
     {___,_?f,"^",___}|
     {_?f}|{___,"^","1",___}|
     {___,"*",_?f,"*",___}|
     {_?f,"*",___}|{___,"*",_?f}|
     {___,_?(StringMatchQ[#,"0"~~___]&),___}] 
, Less@@ToExpression@StringSplit[StringSplit[#,"*"],"^"][[;;,1]]&];


out = {find/@Map[StringJoin[ToString/@Take[digits,#]]&,splits,{2}]
       , If[PrimeQ@n,ToString@n,Nothing]}//Flatten;

len[s_String] := 
Times @@@ 
MapAt[Log10, 
 ToExpression /@ StringSplit[StringSplit[s, "*"], "^"]
, {;; ,  1}] // Total ;

SortBy[{# , Ceiling@len@#} & /@ out
, N@*len@*First]
]; 

Usage:

    func[4856435684257889399168067723732710466864629267287]
 (*
{{4856435684257889^3*99168067723732710466864629267287,80},
{4856435684257889^3991*68067723732710466864629267^287,70019},
{4856435684257889^3991*68067723732710466864629^267287,6165553},
{4856435684257889^399168067*723732710466864629267287,6261477116},
{48564356842578893991680677237^32710466864629267287,938342842682884262823},
{4856435684257889^399168067723732710466864629267287,6261477102687158365511012881413778}}   
 *)

    func[235]
    (* {{2*3*5,2},{2^3*5,2},{2*3^5,3},{23^5,7},{2^35,11}} *)

    func[7013]
    (* {{7013,4},{701^3,9}} *)

    func[12]
    (* {} *)

    func[23]
    (* {{2*3,1},{2^3,1},{23,2}} *)

    func[24]
    (* {{2^4,2}} *)

    func[531]
    (* {{5*31,3},{5^31,22}} *)

    func[1111]
    (* {{11^11,12}} *)
  • func[531] should not list 53^1 (no exponent = 1). func[1111] should not list 11*11 (strictly increasing primes). – Hans Havermann Jun 12 '17 at 9:50
  • @HansHavermann Fixed the bug! – dan7geo Jun 12 '17 at 9:59
  • I've added a large number proviso. I'm trying out your procedure on a 14-digit input. Is this going to get done in good time? – Hans Havermann Jun 12 '17 at 10:18
  • The Groupings function is the bottleneck. It's too slow for more than 8 digits. Trying another method now. – dan7geo Jun 12 '17 at 10:32
  • 1
    I'm impressed. This will help me with my exploration here. Thank you. – Hans Havermann Jun 15 '17 at 11:24

Your Answer

 
discard

By clicking "Post Your Answer", you acknowledge that you have read our updated terms of service, privacy policy and cookie policy, and that your continued use of the website is subject to these policies.

Not the answer you're looking for? Browse other questions tagged or ask your own question.