Challenge: Another Infinite Lazy List

[Limbic~Region]

All,
In this node, tall_man asked how to generate the Hamming Sequence lazily in Perl5. I didn't understand the Haskell code and misunderstood the english explanation.

"how do you generate the series of numbers composed of a given list of prime factors, where each can be used an unlimited number of times?"

I interpreted that to mean all multiples of all prime factors provided minus duplicates were valid. My mistake was exacerbated by the fact the sample series provided fit my interpretation. I took my licks after posting an incorrect solution.

I was happy to take the downvotes and be wrong since the mistake was just as interesting to me. My challenge then is to produce R as shown below for any set of given factors lazily:

Given:  Factors 2, 3, 5
2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, ...
3, 6, 9, 12, 15, 18, 21, 24, 27, 30, ...
5, 10, 15, 20, 25, 30, ...

R = 2, 3, 4, 5, 6, 8, 9, 10, 12, 14, 15, 16, 18, 20, 21, 22, 24, 25, 2
+6, 27, 28, 30, ...

You can see my cleaned up solution below:

#!/usr/bin/perl
use strict;
use warnings;

use constant HEAD =>  0;
use constant TAIL => -1;

my $end = shift || 10;
my @num = @ARGV ? @ARGV : (2, 3, 5);
my $next = merge_multiple( \@num );

print $next->(), "\n" for 1 .. $end;

sub merge_multiple {
    my $list = shift;
    return () if ! $list || ref $list ne 'ARRAY';

    my $n = 1;
    my $h = $list->[TAIL];
    my (@pool, @stream);

    return sub {
        return shift @pool if @pool;

        for ( 0 .. $#$list ) {
            my $mult = $list->[ $_ ];
            my $beg = $h * ($n - 1) / $mult + 1;
            my $end = $h * $n / $mult;
            $stream[ $_ ] = [ map { $mult * $_ } $beg .. $end ];
        }
        ++$n;

        @pool = merge( \@stream );
        return shift @pool;
    }
}

sub merge {
    my $stream = shift;
    my $end = $#$stream;

    my @merged;
    while ( 1 ) {
        my $low;
        for ( 0 .. $end ) {
            my $val = $stream->[ $_ ][HEAD];
            next if ! defined $val;
            $low = $_ if ! defined $low || $val < $stream->[ $low ][HE
+AD];
        }
        last if ! defined $low;
        my $num = shift @{ $stream->[ $low ] };
        next if defined $merged[ TAIL ] && $merged[ TAIL ] == $num;
        push @merged, $num;
    }
    return @merged;
}

[tlm]

Using the subs whose definitions I posted in Re: Hamming Sequences and Lazy Lists, the following:

my $ones;
$ones = ll_new(1, memoize(sub { $ones }));

my $integers;
$integers = ll_new(0,
                   memoize(sub { ll_add($ones,
                                        $integers) }));

sub multiples {
  my $n = shift;
  return ll_map( sub { $n * $_[0] }, $integers );
}

sub challenge {
  return [] unless @_;
  my $x = shift;
  my $out;
  $out = merge( multiples($x), challenge(@_) );
  return $out;
}

my @first_200 = take( 200, challenge(2, 3, 5) );
print "@first_200\n";

prints this out:

0 2 3 4 5 6 8 9 10 12 14 15 16 18 20 21 22 24 25 26 27 28 30 32 33 34 
[phone] 45 46 48 50 51 52 54 55 56 57 58 60 62 63 64 65 
[phone] 76 78 80 81 82 84 85 86 87 88 90 92 93 94 95 96 
[phone] 105 106 108 110 111 112 114 115 116 117 118 120 122
+ 123 124 125 126 128 129 130 132 134 135 136 138 140 141 142 144 145 
[phone] 153 154 155 156 158 159 160 162 164 165 166 168 1
[phone] 176 177 178 180 182 183 184 185 186 188 189 190 19
[phone] 200 201 202 204 205 206 207 208 210 212 213 214 215
+ 216 218 219 220 222 224 225 226 228 230 231 232 234 235 236 237 238 
[phone] 246 248 249 250 252 254 255 256 258 260 261 262 2
[phone] 270 272

[Joost]

I suspect this isn't bulletproof, but it appears to work for the given example:

update2: after some thinking, I'm convinced it's ok.

#!perl -w
use strict;
my $end = shift || 40;
my $i = merge_multiple(@ARGV ? @ARGV : (2,3,5));

print $i->(),"\n" for 1 .. $end;

sub merge_multiple {
    my $last = 0;

    my %vals = map { $_ => $_ } sort { $a <=> $b } @_;

    my %vals = map { $_ => $_ } @_; 
    sub {
        for (keys %vals) {
            $vals{$_} += $_ if $vals{$_} <= $last;
        }
        my ($r) = sort { $a <=> $b } values %vals;
        $last = $r;
    }
}

Cheers. update: removed legacy sort, wasn't used anyway.

[kvale]

Here is a simple iterative solution:

my @factors = (2,3,5);  # Assmue increasing sequence
my $seq_len = 10;

my $index = 0;
foreach my $num (1..$seq_len*$factors[0]) {
   foreach my $factor (@factors) {
      unless ($num % $factor) {
         print "$num ";
         $index++;
         last;
      }
   }
   last if $index >= $seq_len;
}

[tall_man]

If you want a pure iterative solution, you could compute a factor wheel and print everything but the usual trial divisors. The code looks messier, but it requires no mod calculations in the loop, just adds. I computed the wheel using Math::Big::Factors (so for people following the original articles, we have come full circle...).
Read more... (1117 Bytes)

[tlm]

I am confused. Where is the "infinite lazy list"?

In the implementation I posted, a variable like

my $lazy235 = challenge( 2, 3, 5 );

is, effectively, an infinite lazy list. One can repeatedly extract an arbitrarily long prefix from it, using take, or repeatedly find its n-th element with something like:

sub nth {
  my $ll = shift;
  my $n = shift;
  die "Invalid argument: $n\n" if $n < 0;
  return $n == 0 ? head( $ll ) : nth( tail( $ll ), $n - 1 );
}

For example, the following:

my @first_50 = take( 50, $lazy235 );
my @again    = take( 50, $lazy235 );

print "@first_50\n\n@again\n\n";

for ( map int( rand( 1000 ) ), ( 1 .. 5 ) ) {
  printf "%3d %d\n", $_, nth( $lazy235, $_ );
}

prints out something like

0 2 3 4 5 6 8 9 10 12 14 15 16 18 20 21 22 24 25 26 27 28 30 32 33 34 
[phone] 45 46 48 50 51 52 54 55 56 57 58 60 62 63 64 65 
+66

0 2 3 4 5 6 8 9 10 12 14 15 16 18 20 21 22 24 25 26 27 28 30 32 33 34 
[phone] 45 46 48 50 51 52 54 55 56 57 58 60 62 63 64 65 
+66

347 474
857 1168
530 723
994 1355
579 789

[demerphq]

Heres my go without reviewing your code first.

Read more... (2 kB)

Update: It looks like this is the lazy version of the iterative solution by kvale.
Update2: BrowserUk correctly points out the sort needs to be numeric, which ive fixed.

Update3: I tweaked my original a little to support a DESTROY method, and added a second more efficient variant.
Update4: Added readmore around original code.

use strict;
use warnings;
use overload '""'=>'stringify';
sub stringify { $_[0]->() };

sub lcf {
    my @f=sort {$a<=>$b} @_;
    my @v=shift @f;
    for my $f (@f) {
        push @v,$f
            unless grep !($f % $_),@v;
    }
    @v
}

sub make_sub1 {
    my ($N) =  my @f = lcf( @_ );
    return bless sub{
        return "Simple Factors = [ @f ] Cur = $N" if @_;
        for(;;$N++){ $N % $_ || return $N++ for @f }
    };
}


sub make_sub2 {
    my @f = my @v = lcf( @_ );
    return bless sub {
        return "Smart  Factors = [ @f ] Cur = [ @v ]" if @_;
        my ($min,$ret);
        do {
            $min = 0;
            $v[$min] >= $v[$_] and $min=$_ for 1..$#v;
            $ret = $v[$min];
            $v[$min] += $f[$min];
        } while grep !($ret % $f[$_]), 0 .. $min-1;
        return $ret;
    };
}

sub DESTROY {
    my $s=shift;
    warn "DESTROY: $s ",$s->(1),"\n";
}

@ARGV=(2,3,4,5,6) unless @ARGV;
@ARGV=sort @ARGV;

{
    local $"=", ";
    local $\="\n";
    print "Factors: @ARGV";

    foreach  (@ARGV) {
        my $f=make_sub1($_);
        print "F($_) = @{[($f) x 25]}";
    }
    for my $o ( make_sub1(@ARGV),make_sub2(@ARGV)) {
        print "R(@ARGV) = @{[($o) x 25]}";
    }
    print "----";
}
__END__
DESTROY: main=CODE(0x1ac5130) Simple Factors = [ 2 ] Cur = 51
DESTROY: main=CODE(0x1ac5130) Simple Factors = [ 3 ] Cur = 76
DESTROY: main=CODE(0x1ac5130) Simple Factors = [ 4 ] Cur = 101
DESTROY: main=CODE(0x1ac5130) Simple Factors = [ 5 ] Cur = 126
DESTROY: main=CODE(0x1ac5130) Simple Factors = [ 6 ] Cur = 151
DESTROY: main=CODE(0x1ac21c8) Smart  Factors = [ 2, 3, 5 ] Cur = [ 36,
+ 36, 35 ]
DESTROY: main=CODE(0x1c0535c) Simple Factors = [ 2, 3, 5 ] Cur = 35
Factors: 2, 3, 4, 5, 6
F(2) = 2, 4, 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34,
+ 36, 38, 40, 42, 44, 46, 48, 50
F(3) = 3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51
+, 54, 57, 60, 63, 66, 69, 72, 75
F(4) = 4, 8, 12, 16, 20, 24, 28, 32, 36, 40, 44, 48, 52, 56, 60, 64, 6
+8, 72, 76, 80, 84, 88, 92, 96, 100
F(5) = 5, 10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 
+85, 90, 95, 100, 105, 110, 115, 120, 125
F(6) = 6, 12, 18, 24, 30, 36, 42, 48, 54, 60, 66, 72, 78, 84, 90, 96, 
+102, 108, 114, 120, 126, 132, 138, 144, 150
R(2, 3, 4, 5, 6) = 2, 3, 4, 5, 6, 8, 9, 10, 12, 14, 15, 16, 18, 20, 21
+, 22, 24, 25, 26, 27, 28, 30, 32, 33, 34
R(2, 3, 4, 5, 6) = 2, 3, 4, 5, 6, 8, 9, 10, 12, 14, 15, 16, 18, 20, 21
+, 22, 24, 25, 26, 27, 28, 30, 32, 33, 34
----

[BrowserUk]

You need to make your sorts numeric.

[10:09:10.72] P:\test>copy con junk.pl
use strict;
use warnings;
use overload '""'=>'stringify';
sub stringify { $_[0]->() };

sub make_sub {
    my ($N) = ( my @f = sort @_ );
    return bless sub{ for(;;$N++){ $N % $_ || return $N++ for @f }  };
}

@ARGV=(2,3,5) unless @ARGV;
@ARGV=sort @ARGV;

{
    local $"=", ";
    local $\="\n";
    print "Factors: @ARGV";

    foreach  (@ARGV) {
        my $f=make_sub($_);
        print "F($_) = @{[($f) x 25]}";
    }
    my $o=make_sub(@ARGV);
    print "R(@ARGV) = @{[($o) x 25]}";
    print "----";
}
^Z
        1 file(s) copied.

[10:09:30.92] P:\test>junk 3 22 111
Factors: 111, 22, 3
F(111) = 111, 222, 333, 444, 555, 666, 777, 888, 999, 1110, 1221, 1332
+, 1443, 1554, 1665, 1776, 1887, 1998, 2109, 2220, 2331, 2442, 2553, 2
+664, 2775
F(22) = 22, 44, 66, 88, 110, 132, 154, 176, 198, 220, 242, 264, 286, 3
+08, 330, 352, 374, 396, 418, 440, 462, 484, 506, 528, 550
F(3) = 3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51
+, 54, 57, 60, 63, 66, 69, 72, 75
R(111, 22, 3) = 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141,
+ 144, 147, 150, 153, 154, 156, 159, 162, 165, 168, 171, 174, 176, 177
----

[Roy Johnson]

This is actually a simpler problem, because the output for each iteration comes directly off of one of the input streams. One interesting property of that is that you can easily advance yourself in the output stream without generating the whole sequence.

use strict; 
use warnings;

{
    my @streams = map [$_, 0], (2,3,5);
    sub limbic_sequence {
        my $first_after = shift;
        if (defined $first_after) {
             $_->[1] = int($first_after/$_->[0]) for @streams;
        }
        my ($lowest) = sort {$a <=> $b} map {($_->[1]+1) * $_->[0]} @s
+treams;
        $_->[1]++ for grep {($_->[1]+1) * $_->[0] == $lowest} @streams
+;
        $lowest;
    }
}

print join ', ', map limbic_sequence, 1..50;
print "\n";
printf "First after 100000 is: %d\n", limbic_sequence(100000);
print join ', ', map limbic_sequence, 1..50;
print "\n";
__END__
#Output
2, 3, 4, 5, 6, 8, 9, 10, 12, 14, 15, 16, 18, 20, 21, 22, 24, 25, 26, 2
+7, 28, 30, 32, 33, 34, 35, 36, 38, 39, 40, 42, 44, 45, 46, 48, 50, 51
+, 52, 54, 55, 56, 57, 58, 60, 62, 63, 64, 65, 66, 68
First after 100000 is: 100002
100004, 100005, 100006, 100008, 100010, 100011, 100012, 100014, 100015
+, 100016, 100017, 100018, 100020, 100022, 100023, 100024, 100025, 100
+026, 100028, 100029, 100030, 100032, 100034, 100035, 100036, 100038, 
+100040, 100041, 100042, 100044, 100045, 100046, 100047, 100048, 10005
+0, 100052, 100053, 100054, 100055, 100056, 100058, 100059, 100060, 10
+0062, 100064, 100065, 100066, 100068, 100070, 100071

[demerphq]

Am I right in thinking you are basically doing the same thing as my make_sub2() implementation but rotating the data (Ie, i have two array of N elements, you have N arrays of 2 elements)?

[Roy Johnson]

It looks like we're working with the same data, though I don't think we're doing the same thing with it to get our results. Here's mine explained: Each stream stores its base (2, 3, or 5) and the multiplier last used with that base to generate an output element. To generate the next element of the sequence, I check what the next output would be from each stream (multiply the base by the last multiplier + 1) and choose the lowest of those, incrementing the multiplier of each stream that would give me that lowest number. That's it.

[tmoertel]

For comparision with Haskell, we can define R for any given list of factors by folding the merge operator through the list of lists of multiples:

r = foldr merge [] . map (\n -> map (*n) [1..])

We use a duplicate-eating merge:

merge []     ys = ys
merge xs     [] = xs
merge (x:xs) (y:ys)
    | x < y     = x : merge xs (y:ys)
    | y < x     = y : merge (x:xs) ys
    | otherwise = x : merge xs ys

Sample output:

> take 60 (r [2,3,5])
[2,3,4,5,6,8,9,10,12,14,15,16,18,20,21,22,24,25,26,27,28,30,32,33,34,3
+5,36,38,39,40,42,44,45,46,48,50,51,52,54,55,56,57,58,60,62,63,64,65,6
+6,68,69,70,72,74,75,76,78,80,81,82]

[kelan]

I guess I don't have enough practice with Haskell yet. When trying to think of an easy way to merge a list of lists I completely forgot about folding. ++ to you.

[tall_man]

This particular challenge can be done much more simply with a filter approach instead of merging multiple lists. Here is an implementation using the Stream.pm class given by Dominus in this article.

use strict;
use Stream;
use Math::Pari qw(gcd);
 
 
# We can test all the factors at once using the greatest common diviso
+r algorithm.
my @factors = @ARGV;
my $test_number = 1;
$test_number *= $_ for @factors;
die "Must provide a list of non-zero factors\n" unless $test_number > 
+1;
 
sub has_common_factor { gcd($_[0], $test_number) != 1 }
 
my $integers = Stream::tabulate( sub { $_[0] }, 1);
my $challenge = $integers->filter(\&has_common_factor);
$challenge->show(50);

[tlm]

This particular challenge can be done much more simply with a filter approach instead of merging multiple lists.

This is the precise description of my solution (except that no "filtering" is required; it's enough to merge the lists of multiples).

Update: see here and here.

[tall_man]

The two approaches are not the same at all. Say there are N numbers and R prime factors. The merge methods use:

N*(1/p1 + 1/p2 + ... 1/pR)*(R-1)

comparison operations to process a list of size N.

The filter method tests each number with a single gcd calculation, which is O(logN) and is independent of the total number of factors. So to produce a list of size N should be O(NlogN).

Depending on the size and quantity of factors, one or the other will be better. I would expect the filter to be better when there are many small factors, and the merge to be better when there are few factors or the factors are large.

[kelan]

Here's my naive Haskell implementation, done without studying any of the others here, though after finishing and looking briefly through them, it is rather similar to some.

merge (x:xs) (y:ys)
    | x < y  = x : merge xs (y:ys)
    | x > y  = y : merge (x:xs) ys
    | x == y = x : merge xs ys

supermerge (x:[]) = x
supermerge (x:y:ys) =
    supermerge $ (merge x y) : ys

multiples x =
    map (*x) [1..]

multiplesFromList x =
    supermerge $ map (multiples) x

limbic's_challenge = multiplesFromList [2,3,5]

I'm not sure how fast it is comparatively (especially since I'm running it in Hugs), but I can get a million items in about 20 seconds.

[Limbic~Region]

My solution in the root thread required was only minimally better than my original solution (to the wrong problem). This minimally tested version is vast improvement over both previous solutions.

#!/usr/bin/perl
use strict;
use warnings;

my $end = shift || 22;
my $next = lazy_merge( [ @ARGV ? @ARGV : (2, 3, 5) ] );
print $next->(), "\n" for 1 .. $end;

sub lazy_merge {
    my ($list, $last) = (shift(), 0);

    my $by_n = sub { my ($n, $k) = (shift(), 0); return sub { $_[0] ? 
+$k += $n : $k } };
    $_ = $by_n->( $_ ) for @$list;

    return sub {
        my $low;
        for ( @$list ) {
            my $val = $_->();
            $val = $_->( 'next' ) if $val <= $last;
            $low = $val if ! defined $low || $val < $low;
        }
        return $last = $low;
    };
}