Try to find a number that takes more than eleven steps.

use v5.10;
use strict;
use warnings;
use List::Util qw(product);

sub per {
    my ($n) = @_;
    return if $n < 10;
    my $p = product split //, $n;
    return $p, per($p);
}

my @steps = per 277777788888899;
my $steps = @steps;

say "$steps steps";
say for @steps;

[download]
toby döt ink

Replies are listed 'Best First'.
Re: Multiplication digit persistence
by haukex (Archbishop) on Mar 21, 2019 at 13:26 UTC
    Try to find a number that takes more than eleven steps.

    Heh, I guess you just watched the Numberphile video that was just released? ;-)

[reply]
[d/l]
[reply]
Re: Multiplication digit persistence
by choroba (Cardinal) on Mar 21, 2019 at 17:41 UTC
    When searching for the 12 stepper, you probably need to modify the script in the following way: 
    -     my $p = product split //, $n;
+     my $p = 'Math::BigInt'->new(product split //, $n);

    [download]
    Also, put 
    use Math::BigInt;

    [download]
    somewhere to the top, and enclose the to-be-winner in quotes.

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
[reply]
[d/l]
[select]

      Tbh, I doubt that's enough. product is written in C. You'd probably want to replace it with a Math::BigInt version.

      toby döt ink
[reply]
[d/l]
Re: Multiplication digit persistence
by golux (Chaplain) on Mar 21, 2019 at 15:03 UTC
    I also watched the video this morning, not realizing it came up because it was new.

    When I saw that Matt was using Python to code it, of course I wanted to try it in Perl instead!

    This was what I came up with: 

    #!/usr/bin/perl

use strict;
use warnings;
use feature qw( say );
use Function::Parameters;

$| = 1;

# Try the record-holder
try_num(277777788888899, 1);

# Search for record holders at each # iterations
my $num = my $max = my $maxn = my $print = 0;
while (1) {
    ++$num;
    my ($per, $new) = (persist($num), 0);
    (0 == $num % 100_000) and $print = 1;
    ($per > $max) and ($maxn, $max, $print, $new) = ($num, $per, 1, 1)
+;
    $print and print " CURR=$num,  MAX=$max,  MAXP=$maxn\e[K\r";
    $new and say "";
    $print = $new;
}



fun try_num($num, $dbg = 0) {
    my $per = persist($num, $dbg);
    printf "\e[102m Count[$num] = %s\e[m\n\n", persist($num, $dbg);
}

fun muldigs($num, $dbg = 0, $res = 1) {
    $dbg and say " Num: $num";
    my @dbg = ( );
    map { push @dbg, ($res *= $_) } split(//, $num);
    $dbg and say "   -> " . join(",", @dbg);
    return $res;
}

fun persist($num, $dbg = 0) {
    my ($mul, $iter) = ($num, 0);
    while (1) {
        (length($mul) > 1) or return $iter;
        ($iter, $mul) = ($iter+1, muldigs($mul, $dbg));
        $dbg and say "Iter: $iter [$mul]\n";
    }
}

    [download]
    say  substr+lc crypt(qw $i3 SI$),4,5
[reply]
[d/l]
      
    printf "\e[102m Count[$num] = %s\e[m\n\n", persist($num, $dbg);

      [download]

      You are not using printf correctly. 

      
    printf "\e[102m Count[%s] = %s\e[m\n\n", $num, persist($num, $dbg)
+;

      [download]

      The first argument is a FORMAT string and using variable interpolation could introduce an invalid '%' character. 

      
    my @dbg = ( );
    map { push @dbg, ($res *= $_) } split(//, $num);

      [download]

      You are not using map correctly: 

      
    my @dbg = map { $res *= $_ } split(//, $num);

      [download]
[reply]
[d/l]
[select]

        Not many numbers have % as a digit.

[reply]
[d/l]
Re: Multiplication digit persistence
by johngg (Canon) on Mar 28, 2019 at 11:47 UTC

    I don't have the math skills to know whether there is some formula to find the "steps" so a brute force approach was my only option. Initially I used glob with multiples of the {1,2,3,4,5,6,7,8,9} pattern to generate an array of n-digit numbers to test but that was wasteful. All that is needed are numbers where digits are equal or greater than the preceding digit. I used Math::BigInt to cope with large values and initially used ->bmul() to find the product of all the digits. However, changing

        my $prod = Math::BigInt->new( 1 );
    $prod->bmul( $_ ) for split m{}, $nVal->bstr();

    [download]

    to

        my $prod = Math::BigInt->new( 1 );
    my %digits;
    $digits{ $_ } ++ for split m{}, $nVal->bstr();
    $prod->bmul( $_ ) for
       map {
          $digits{ $_ } > 1
          ? Math::BigInt->new( $_ )->bpow( $digits{ $_ } )
          : $_
          } keys %digits;

    [download]

    produced gains in performance as the length of the numbers increased. I tried to make further gains by employing threads but the results were woeful; I am obviously not understanding something about them and where they can usefully be employed and may well raise a SoPW to seek enlightenment. The code:-

    use 5.018;
use warnings;

use Math::BigInt;
use Time::HiRes qw{ gettimeofday tv_interval };

use Fcntl;
STDOUT->autoflush( 1 );
STDERR->autoflush( 1 );

my $startDigits;
my $stopDigits;

if ( scalar @ARGV == 2 )
{
    ( $startDigits, $stopDigits ) = @ARGV;
}
elsif ( scalar @ARGV == 1 )
{
    $startDigits = 2;
    $stopDigits = shift;
}
else
{
    $startDigits = 2;
    $stopDigits = 8;
}

my $maxSteps  = 0;
my $nTried    = 0;

my $rcGenDigits;
$rcGenDigits = sub
{
    my( $depth, $start ) = @_;
    return [] unless $depth;
    my $raValues;
    foreach my $digit ( $start .. 9 )
    {
        my $raInner = $rcGenDigits->( $depth - 1, $digit );
        push @{ $raValues },
           scalar @{ $raInner }
           ? map { $digit . $_ } @{ $raInner }
           : $digit;
    }
    return $raValues;
};

my $steps;
my $raRecord;

my $startTV = my $lastTV = [ gettimeofday() ];
my $nowTV;
my $elapsed;
my $delta;

foreach my $nDigits ( $startDigits .. $stopDigits )
{
    print
       q{ } x $stopDigits,
       qq{\rGenerating ${nDigits}-digit values ... };
    my $raValues = $rcGenDigits->( $nDigits, 1 );
    $nowTV       = [ gettimeofday() ];
    $delta       = tv_interval( $lastTV, $nowTV );
    $elapsed     = tv_interval( $startTV, $nowTV );
    $lastTV      = $nowTV;
    say
       qq{found @{ [ scalar @{ $raValues } ] }, },
       qq{took @{ [ scaleSecs( $delta ) ] }\n},
       qq{Trying ${nDigits}-digit values, },
       qq{at elapsed time @{ [ scaleSecs( $elapsed ) ] }\n};

    foreach my $value ( @{ $raValues } )
    {
        $nTried ++;
        print STDERR qq{$value\r} unless $nTried %1000;
        $raRecord = [];
        try( $value );
    }

    $nowTV       = [ gettimeofday() ];
    $delta       = tv_interval( $lastTV, $nowTV );
    $lastTV      = $nowTV;
    say
       q{ } x $stopDigits,
       qq{\nTrying ${nDigits}-digit values },
       qq{took @{ [ scaleSecs( $delta ) ] }\n};    
}

say q{ } x $stopDigits, q{};
$nowTV   = [ gettimeofday() ];
$elapsed = tv_interval( $startTV, $nowTV );
say qq{Total elapsed time @{ [ scaleSecs( $elapsed ) ] }\n};

sub per
{
    my $nStr = shift;
    my $nVal = Math::BigInt->new( $nStr );
    push @{ $raRecord }, [ $steps ++, $nVal->bstr() ];
    return if $nVal->bcmp( 10 ) == -1;

    my $prod = Math::BigInt->new( 1 );
    my %digits;
    $digits{ $_ } ++ for split m{}, $nVal->bstr();
    $prod->bmul( $_ ) for
       map {
          $digits{ $_ } > 1
          ? Math::BigInt->new( $_ )->bpow( $digits{ $_ } )
          : $_
          } keys %digits;
    return per( $prod->bstr() );
}

sub scaleSecs
{
    my $tv          = shift;
    my $secs        = int $tv;
    my( $fracPart ) = $tv =~ m{(?<=\.)(\d+)};

    my $wks  = 0;
    my $days = 0;
    my $hrs  = 0;
    my $mins = 0;

    while($secs >= 604800)
    {
        $wks ++;
        $secs -= 604800;
    }
    while($secs >= 86400)
    {
        $days ++;
        $secs -= 86400;
    }
    while($secs >= 3600)
    {
        $hrs ++;
        $secs -= 3600;
    }
    while($secs >= 60)
    {
        $mins ++;
        $secs -= 60;
    }

    my $retStr
       = ( $wks ? qq{${wks}w } : q{} )
       . ( $days ? qq{${days}d } : q{} )
       . ( $hrs ? qq{${hrs}h } : q{} )
       . ( $mins ? qq{${mins}m } : q{} )
       . qq{$secs.${fracPart}s};    
}

sub try
{
    my $nStr = shift;
    $steps   = 0;
    per( $nStr );

    my $actualSteps = $steps - 1;
    if ( $actualSteps > $maxSteps )
    {
        $nowTV    = [ gettimeofday() ];
        $elapsed  = tv_interval( $startTV, $nowTV );
        say
           q{ } x $stopDigits,
           qq{\rFound steps: $actualSteps -- },
           qq{at elapsed time @{ [ scaleSecs( $elapsed ) ] }};
        printf qq{%7d %s\n}, @{ $_ } for @{ $raRecord };
        $maxSteps = $actualSteps;
    }
}

    [download]

    Running the script with no arguments tests numbers of length 2 through 8 digits.

    Read more... (2 kB)

    The script successfully finds the 15-digit value with 11 steps but I have yet to find a 12 stepper, having run with up to 27-digit values. Output from a 26- and 27-digit run below:-

    Read more... (2 kB)

    As you can see, the above run finds all the steps up to 11, just with a series of 1s prepended and the whole run took almost 9 hours on a 2012 MacBook Pro 2.3GHz quad core i7. It may be that there are no 12-steppers at all, I don't have the maths to tell, but I think any further tests will have to be using a faster language. Perhaps this will be a good project to translate to Go, as I try to learn more.

    Update: Corrected typo, s/MacBoon/MacBook/

    Cheers,

    JohnGG

[reply]
[d/l]
[select]

      The script successfully finds the 15-digit value with 11 steps but I have yet to find a 12 stepper, having run with up to 27-digit values. Output from a 26- and 27-digit run below:-

      ...

      As you can see, the above run finds all the steps up to 11, just with a series of 1s prepended and the whole run took almost 9 hours on a 2012 MacBook Pro 2.3GHz quad core i7. It may be that there are no 12-steppers at all, I don't have the maths to tell,...

      It was mentioned in the video, and I am quoting the similar idea from the Wolfram MathWorld Multiplicative Persistence article: "There is no number <10^(233) with multiplicative persistence >11". You're going to have to go a lot higher than 27 digits if you want to find the elusive 12-stepper.

      I tried talking the lowest 11-stepper (277777788888899), then permuting its digits, and listing the factors of each of those permutations (keeping the single-digit factors separate, then lumping what's left if it's not), trying to find one or more permutations that is soley made up of single-digit factors -- because if there's a group of only-single-digit factors that make up a 11-stepper, then making a 12-stepper is as simple as concatenating those digits. -- Actually, I remembered that I started with a 10-stepper, because I wanted to see if I could proof-of-concept it to go from the 10-stepper to a known 11-stepper. I only made it about a million permutations through. If I had started with the 11-stepper, that would have been almost enough, because there are only 15! / 6! / 6! / 2! permutations of 277777788888899, which is 1.3million permutations. But since I was using the 10-stepper 4996238671872 => 1223466778899, which has fewer repeating digits, so is 13!/2!/2!/2!/2!/2! = 195million permutations.

      Looks like I'll have to find some spare CPU cycles to try the 11-stepper, too.

      <Reveal this spoiler or all in this thread>
[reply]
[d/l]
        > Looks like I'll have to find some spare CPU cycles to try the 11-stepper, too.

        But you know that'll fail?

        • The smallest useful digit is 2
        • 2**50 has already more than 15 digits.
        • Any of your permutations will have 15 only.
        • It was said that there's no solution under 200+ digits
        update

        Probably I didn't think it thru, the product of more than 50 digits could contain many 1s acting as fillers in between your targeted 15 digits...

        in other words 1277777788888899 is am eleven stepper too, just not the smallest.

        BTW: For the same reason is 1223466778899 not the smallest 10 stepper.

        Cheers Rolf
        (addicted to the Perl Programming Language :)
        Wikisyntax for the Monastery FootballPerl is like chess, only without the dice

[reply]

Back to Cool Uses for Perl