File Coverage

blib/lib/Data/BitStream/Code/Additive.pm
Criterion Covered Total %
statement 214 250 85.6
branch 95 158 60.1
condition 30 60 50.0
subroutine 19 22 86.3
pod 9 9 100.0
total 367 499 73.5


line stmt bran cond sub pod time code
1             package Data::BitStream::Code::Additive;
2 28     28   24734 use strict;
  28         229  
  28         1006  
3 28     28   162 use warnings;
  28         56  
  28         1752  
4             BEGIN {
5 28     28   69 $Data::BitStream::Code::Escape::AUTHORITY = 'cpan:DANAJ';
6 28         6889 $Data::BitStream::Code::Escape::VERSION = '0.08';
7             }
8              
9             our $CODEINFO = [ { package => __PACKAGE__,
10             name => 'Additive',
11             universal => 0,
12             params => 1,
13             encodesub => sub {shift->put_additive_seeded([split('-',shift)], @_)},
14             decodesub => sub {shift->get_additive_seeded([split('-',shift)], @_)},
15             },
16             { package => __PACKAGE__,
17             name => 'GoldbachG1',
18             universal => 1,
19             params => 0,
20             encodesub => sub {shift->put_goldbach_g1(@_)},
21             decodesub => sub {shift->get_goldbach_g1(@_)},
22             },
23             { package => __PACKAGE__,
24             name => 'GoldbachG2',
25             universal => 1,
26             params => 0,
27             encodesub => sub {shift->put_goldbach_g2(@_)},
28             decodesub => sub {shift->get_goldbach_g2(@_)},
29             },
30             ];
31              
32              
33              
34             #use List::Util qw(max);
35 28     28   196 use Moo::Role;
  28         111  
  28         293  
36             requires qw(read write);
37              
38             # Precalculate the lengths for small values.
39             my @_agl = (1,3,3,(5)x4,(7)x8,(9)x16,(11)x32,(13)x64,(15)x128,(17)x256);
40 2     2   3672 sub _push_more_agls { push @_agl, (19)x512,(21)x1024,(23)x2048,(25)x4096,(27)x8192; }
41             sub _additive_gamma_len {
42 145674     145674   152600 my($n) = @_;
43 145674 100       448063 return $_agl[$n] if $n <= $#_agl;
44 2 50       16 _push_more_agls if $n < 16383;
45 2         8 my $gammalen = 1;
46 2         40 $gammalen += 2 while $n >= ((2 << ($gammalen>>1))-1);
47 2         8 $gammalen;
48             }
49              
50             # Determine the best 2-ary sum over the basis p to use for this value.
51             sub _find_best_pair {
52 4172     4172   11261 my($p, $val, $pairsub) = @_;
53              
54             # Determine how far to look in the basis
55 4172         4975 my $maxbasis = 0;
56 4172   100     30985 $maxbasis+=100 while exists $p->[$maxbasis+101] && $val > $p->[$maxbasis+100];
57 4172   100     55583 $maxbasis+=10 while exists $p->[$maxbasis+ 11] && $val > $p->[$maxbasis+ 10];
58 4172   100     82238 $maxbasis++ while exists $p->[$maxbasis+ 1] && $val > $p->[$maxbasis ];
59             # Or we could do binary search:
60             # my $lo = 0;
61             # my $hi = $#$p;
62             # while ($lo < $hi) {
63             # my $mid = int(($lo + $hi) / 2);
64             # if ($p->[$mid] <= $val) { $lo = $mid+1; }
65             # else { $hi = $mid; }
66             # }
67             # my $maxbasis = $lo;
68              
69 4172         4715 my @best_pair;
70 4172         5035 my $best_pair_len = 100000000;
71 4172         4535 my $i = 0;
72 4172         4796 my $j = $maxbasis;
73 4172         5225 my $pi = $p->[$i];
74 4172         4956 my $pj = $p->[$j];
75 4172         8547 while ($i <= $j) {
76 546888         608601 my $sum = $pi + $pj;
77 546888 100       938033 if ($sum < $val) { $pi = $p->[++$i]; }
  227572 100       470966  
78 246479         530084 elsif ($sum > $val) { $pj = $p->[--$j]; }
79             else {
80 72837         124326 my($p1, $p2) = $pairsub->($i, $j); # How i,j are stored
81 72837         115458 my $glen = _additive_gamma_len($p1) + _additive_gamma_len($p2);
82             #print "poss: $pi + $pj = $val. Indices $i,$j. Pair $p1,$p2. Len $glen.\n";
83 72837 100       141570 if ($glen < $best_pair_len) {
84 6096         12055 @best_pair = ($p1, $p2);
85 6096         7329 $best_pair_len = $glen;
86             }
87 72837         173716 $pi = $p->[++$i];
88             }
89             }
90 4172         11647 @best_pair;
91             }
92              
93             # 2-ary additive code.
94             #
95             # The parameter comes in as an array. Hence:
96             #
97             # $stream->put_additive( [0,1,3,5,7,8,10,16,22,28,34,40], $value );
98             #
99             # $stream->get_additive( [0,1,3,5,7,8,10,16,22,28,34,40], $value );
100             #
101             # You can optionally put a sub in the first arg.
102             #
103             # This array must be sorted and non-negative.
104              
105             sub put_additive {
106 813     813 1 1017 my $self = shift;
107 813 50       2132 $self->error_stream_mode('write') unless $self->writing;
108 813 50       2793 my $sub = shift if ref $_[0] eq 'CODE'; ## no critic
109 813         1070 my $p = shift;
110 813 50 33     4637 $self->error_code('param', 'p must be an array') unless (ref $p eq 'ARRAY') && scalar @$p >= 1;
111              
112 813         1637 foreach my $val (@_) {
113 2340 50 33     10133 $self->error_code('zeroval') unless defined $val and $val >= 0;
114              
115             # Expand the basis if necessary and possible.
116 2340 100 66     10851 $sub->($p, $val) if defined $sub && $p->[-1] < $val;
117              
118 2340     46715   11273 my @best_pair = _find_best_pair($p, $val, sub { ($_[0], $_[1]-$_[0]) } );
  46715         103701  
119              
120 2340 50       16235 $self->error_code('range', $val) unless @best_pair;
121 2340         17351 $self->put_gamma(@best_pair);
122             }
123 813         2943 1;
124             }
125              
126             sub get_additive {
127 813     813 1 1035 my $self = shift;
128 813 50       2265 $self->error_stream_mode('read') if $self->writing;
129 813 50       2416 my $sub = shift if ref $_[0] eq 'CODE'; ## no critic
130 813         1049 my $p = shift;
131 813 50 33     4078 $self->error_code('param', 'p must be an array') unless (ref $p eq 'ARRAY') && scalar @$p >= 1;
132 813         1221 my $count = shift;
133 813 100       1686 if (!defined $count) { $count = 1; }
  792 50       2188  
    0          
134 21         47 elsif ($count < 0) { $count = ~0; } # Get everything
135 0         0 elsif ($count == 0) { return; }
136              
137 813         1273 my @vals;
138 813         2569 $self->code_pos_start('Additive');
139 813         29913 while ($count-- > 0) {
140 2361         6469 $self->code_pos_set;
141             # Read the two gamma-encoded values
142 2361         73149 my ($i,$j) = $self->get_gamma(2);
143 2361 100       5604 last unless defined $i;
144 2340 50       4238 $self->error_off_stream unless defined $j;
145 2340         2602 $j += $i;
146 2340         3736 my $pi = $p->[$i];
147 2340         3079 my $pj = $p->[$j];
148 2340 50 33     5605 if ( (!defined $pj) && (defined $sub) ) {
149 0         0 $sub->($p, -$j); # Generate the basis through j
150 0         0 $pi = $p->[$i];
151 0         0 $pj = $p->[$j];
152             }
153 2340 50 33     9750 $self->error_code('overflow') unless defined $pi && defined $pj;
154 2340         7452 push @vals, $pi+$pj;
155             }
156 813         2736 $self->code_pos_end;
157 813 50       25600 wantarray ? @vals : $vals[-1];
158             }
159              
160              
161             ########## Additive codes using seeds
162              
163             my $expand_additive_basis = sub {
164             my $p = shift;
165             my $maxval = shift;
166              
167             push @{$p}, 0, 1 unless @{$p};
168              
169             # Assume the basis is sorted and complete to $p->[-1].
170             my %sumhash;
171             my @sums;
172             foreach my $b1 (@{$p}) {
173             foreach my $b2 (@{$p}) {
174             $sumhash{$b1+$b2} = 1;
175             }
176             }
177             my $lastp = $p->[-1];
178             delete $sumhash{$_} for (grep { $_ <= $lastp } keys %sumhash);
179             @sums = sort { $a <=> $b } keys %sumhash;
180             my $n = $lastp;
181              
182             while (1) {
183             if ($maxval >= 0) { last if $maxval <= $n; }
184             else { last if -$maxval < scalar @{$p}; }
185             $n++;
186             if (!@sums || ($sums[0] > $n)) {
187             push @{$p}, $n; # add $n to basis
188             $sumhash{$n+$_} = 1 for @{$p}; # calculate new sums
189             delete $sumhash{$n}; # sums from $n+1 up
190             @sums = sort { $a <=> $b } keys %sumhash;
191             } else {
192             shift @sums if @sums && $sums[0] <= $n; # remove obsolete sums
193             delete $sumhash{$n};
194             }
195             }
196             1;
197             };
198              
199             # Give a maximum range and some seeds (even numbers). You can then take the
200             # resulting basis and hand it to get_additive() / put_additive().
201             #
202             # Examples:
203             # 99, 8, 10, 16
204             # 127, 8, 20, 24
205             # 249, 2, 16, 46
206             # 499, 2, 34, 82
207             # 999, 2, 52, 154
208             sub generate_additive_basis {
209 0     0 1 0 my $self = shift;
210 0         0 my $max = shift;
211              
212 0         0 my @basis = (0, 1);
213             # Perhaps some checking of defined, even, >= 2, no duplicates.
214 0         0 foreach my $seed (sort {$a<=>$b} @_) {
  0         0  
215             # Expand basis to $seed-1
216 0 0       0 $expand_additive_basis->(\@basis, $seed-1) if $seed > ($basis[-1]+1);
217             # Add seed to basis
218 0 0       0 push @basis, $seed if $seed > $basis[-1];
219 0 0       0 last if $seed >= $max;
220             }
221 0 0       0 $expand_additive_basis->(\@basis, $max) if $max > $basis[-1];
222 0         0 @basis;
223             }
224              
225              
226             # More flexible seeded functions. These take the seeds and expand the basis
227             # as needed to construct the desired values. They also cache the constructed
228             # bases.
229              
230             my %_cached_bases;
231              
232             sub put_additive_seeded {
233 0     0 1 0 my $self = shift;
234 0 0       0 $self->error_stream_mode('write') unless $self->writing;
235 0         0 my $p = shift;
236 0 0 0     0 $self->error_code('param', 'p must be an array') unless (ref $p eq 'ARRAY') && scalar @$p >= 1;
237              
238 0         0 my $handle = join('-', @{$p});
  0         0  
239 0 0       0 if (!defined $_cached_bases{$handle}) {
240 0         0 my @basis = $self->generate_additive_basis($p->[-1], @{$p});
  0         0  
241 0         0 $_cached_bases{$handle} = \@basis;
242             }
243 0         0 $self->put_additive($expand_additive_basis, $_cached_bases{$handle}, @_);
244             }
245              
246             sub get_additive_seeded {
247 0     0 1 0 my $self = shift;
248 0 0       0 $self->error_stream_mode('read') if $self->writing;
249 0         0 my $p = shift;
250 0 0 0     0 $self->error_code('param', 'p must be an array') unless (ref $p eq 'ARRAY') && scalar @$p >= 1;
251              
252 0         0 my $handle = join('-', @$p);
253 0 0       0 if (!defined $_cached_bases{$handle}) {
254 0         0 my @basis = $self->generate_additive_basis($p->[-1], @{$p});
  0         0  
255 0         0 $_cached_bases{$handle} = \@basis;
256             }
257 0         0 $self->get_additive($expand_additive_basis, $_cached_bases{$handle}, @_);
258             }
259              
260              
261             ########## Support code for Goldbach codes
262              
263             my $expand_primes_sub;
264              
265             # Performance options, in order:
266             #
267             # 1. Install Data::BitStream::XS.
268             #
269             # Whether you use it directly or install it and let Data::BitStream
270             # use it behind the curtains, this is BY FAR the best solution.
271             # 20-50x faster overall.
272             #
273             # 2. Install Math::Prime::Util.
274             #
275             # Fast prime basis formation. If you're installing modules, you may as
276             # well install DBXS though, as it gets you much more. With large codes
277             # this can be 1.5x faster.
278             #
279             # 3. Use this pure perl code.
280             #
281             # There really are three parts that let one efficiently produce Goldbach codes
282             # for large inputs.
283             #
284             # - Fast prime basis formation. Both options 1 and 2 will do this well.
285             # Since switching to a segmented sieve in Perl, this isn't much of a
286             # bottleneck any more. Version 0.01 of this module was MUCH slower.
287             #
288             # - Fast best-pair search. Doing this in Data::BitStream::XS is a 10-50x
289             # speedup for large numbers. For very large numbers (over 32-bit), a
290             # different algorithm would be needed, as that module uses the normal
291             # array scan method. Honestly these codes were meant for tiny inputs.
292             #
293             # - Generic coding speedup. Having the XS module installed gives a 10-100x
294             # reduction in overhead. This will have a big impact if inserting many
295             # small codes.
296             #
297             # You can find lots of benchmarks and results for prime generation in the
298             # Math::Prime::Util module. That module is by far the fastest on CPAN
299             # (2012-2014). Math::Prime::FastSieve is fast enough if you start at 2.
300             # For non-Perl solutions, I recommend primesieve -- it is faster than MPU,
301             # yafu, primegen, or TOeS's code.
302              
303             if (eval {require Math::Prime::Util; Math::Prime::Util->import(qw(primes nth_prime_upper next_prime)); 1;}) {
304              
305             $expand_primes_sub = sub {
306             my $p = shift;
307             my $maxval = shift;
308              
309             $maxval = nth_prime_upper(-$maxval) if $maxval < 0;
310             $maxval += 100;
311              
312             push @$p, @{primes($p->[-1]+1, $maxval)};
313             push @$p, next_prime($p->[-1]) if $p->[-1] < $maxval;
314             1;
315             };
316              
317             } else {
318              
319             sub _dj_pp_string_sieve {
320 34     34   57 my($end) = @_;
321 34 50       97 return '0' if $end < 2;
322 34 50       103 return '1' if $end < 3;
323 34 100       90 $end-- if ($end & 1) == 0;
324 34         48 my $s_end = $end >> 1;
325              
326 34         58 my $whole = int( ($end>>1) / 15); # prefill with 3 and 5 marked
327 34         111 my $sieve = '100010010010110' . '011010010010110' x $whole;
328 34         92 substr($sieve, ($end>>1)+1) = '';
329 34         72 my ($n, $limit) = ( 7, int(sqrt($end)) );
330 34         92 while ( $n <= $limit ) {
331 24         79 for (my $s = ($n*$n) >> 1; $s <= $s_end; $s += $n) {
332 96         201 substr($sieve, $s, 1) = '1';
333             }
334 24         37 do { $n += 2 } while substr($sieve, $n>>1, 1);
  43         131  
335             }
336 34         74 return \$sieve;
337             }
338             sub _dj_pp_segment_sieve {
339 34     34   56 my($beg,$end) = @_;
340 34         103 my $range = int( ($end - $beg) / 2 ) + 1;
341             # Prefill with 3 and 5 already marked, and offset to the segment start.
342 34         66 my $whole = int( ($range+14) / 15);
343 34         61 my $startp = ($beg % 30) >> 1;
344 34         364 my $sieve = substr("011010010010110", $startp) . "011010010010110" x $whole;
345             # Set 3 and 5 to prime if we're sieving them.
346 34 50       99 substr($sieve,0,2) = "00" if $beg == 3;
347 34 50       94 substr($sieve,0,1) = "0" if $beg == 5;
348             # Get rid of any extra we added.
349 34         98 substr($sieve, $range) = '';
350              
351             # If the end value is below 7^2, then the pre-sieve is all we needed.
352 34 50       114 return \$sieve if $end < 49;
353              
354 34         155 my $limit = int(sqrt($end)) + 1;
355             # For large value of end, it's a huge win to just walk primes.
356 34         106 my $primesieveref = _dj_pp_string_sieve($limit);
357 34         56 my $p = 7-2;
358 34         268 foreach my $s (split("0", substr($$primesieveref, 3), -1)) {
359 524         700 $p += 2 + 2 * length($s);
360 524         676 my $p2 = $p*$p;
361 524 100       916 last if $p2 > $end;
362 490 100       825 if ($p2 < $beg) {
363 330         438 $p2 = int($beg / $p) * $p;
364 330 100       558 $p2 += $p if $p2 < $beg;
365 330 100       618 $p2 += $p if ($p2 % 2) == 0; # Make sure p2 is odd
366             }
367             # With large bases and small segments, it's common to find we don't hit
368             # the segment at all. Skip all the setup if we find this now.
369 490 50       1249 if ($p2 <= $end) {
370             # Inner loop marking multiples of p
371             # (everything is divided by 2 to keep inner loop simpler)
372 490         535 my $fend = ($end - $beg) >> 1;
373 490         1101 for (my $fp2 = ($p2 - $beg) >> 1; $fp2 <= $fend; $fp2 += $p) {
374 45340         82624 substr($sieve, $fp2, 1) = '1';
375             }
376             }
377             }
378 34         242 \$sieve;
379             }
380             sub _dj_pp_sieve {
381 34     34   69 my($low, $high) = @_;
382              
383 34         120 my $sref = [];
384 34 50 33     205 return $sref if ($low > $high) || ($high < 2);
385 34 50 33     139 push @$sref, 2 if ($low <= 2) && ($high >= 2);
386 34 50 33     211 push @$sref, 3 if ($low <= 3) && ($high >= 3);
387 34 50 33     174 push @$sref, 5 if ($low <= 5) && ($high >= 5);
388 34 50       88 $low = 7 if $low < 7;
389 34 50       101 $low++ if ($low % 2) == 0;
390 34 100       79 $high-- if ($high % 2) == 0;
391 34 50       88 return $sref if $low > $high;
392              
393 34 50       166 my($n, $s, $sieveref) = ($low == 7)
394             ? ($low-2, 3, _dj_pp_string_sieve($high))
395             : ($low-2, 0, _dj_pp_segment_sieve($low,$high));
396 34         171 while ( (my $nexts = 1 + index($$sieveref, "0", $s)) > 0 ) {
397 12057         11519 $n += 2 * ($nexts - $s);
398 12057         10323 $s = $nexts;
399 12057         573139 push @$sref, $n;
400             }
401 34         1656 $sref;
402             }
403              
404             $expand_primes_sub = sub {
405             my $p = shift;
406             my $maxval = shift;
407             if ($maxval < 0) { # We need $p->[-$maxval] defined.
408             # Inequality: p_n < n*ln(n)+n*ln(ln(n)) for n >= 6
409             my $n = ($maxval > -6) ? 6 : -$maxval;
410             $n++; # Because we skip 2 in our basis.
411             $maxval = int($n * log($n) + $n * log(log($n))) + 1;
412             }
413              
414             # We want to ensure there is a prime >= $maxval on our list.
415             # Use maximal gap, so this loop ought to run exactly once.
416             my $adder = ($maxval <= 0xFFFFFFFF) ? 336 : 2000;
417             while ($p->[-1] < $maxval) {
418             push @{$p}, @{_dj_pp_sieve($p->[-1]+1, $maxval+$adder)};
419             $adder *= 2; # Ensure success
420             }
421             1;
422             };
423             }
424              
425              
426             ########## Goldbach G1 codes using the 2N form, and modified for 0-based.
427              
428             my @_pbasis = (1, 3, 5, 7, 11, 13, 17, 19, 23, 29);
429              
430             sub put_goldbach_g1 {
431 813     813 1 11652 my $self = shift;
432 813 50       2723 $self->error_stream_mode('write') unless $self->writing;
433              
434 2340         6125 $self->put_additive($expand_primes_sub,
435             \@_pbasis,
436 813         2037 map { ($_+1)*2 } @_);
437             }
438              
439             sub get_goldbach_g1 {
440 813     813 1 10831 my $self = shift;
441 813 50       2612 $self->error_stream_mode('read') if $self->writing;
442              
443 813         3359 my @vals = map { int($_/2)-1 } $self->get_additive($expand_primes_sub,
  2340         6301  
444             \@_pbasis,
445             @_);
446 813 100       3656 wantarray ? @vals : $vals[-1];
447             }
448              
449             ########## Goldbach G2 codes modified for 0-based.
450              
451             sub put_goldbach_g2 {
452 813     813 1 23747 my $self = shift;
453 813 50       2821 $self->error_stream_mode('write') unless $self->writing;
454              
455 813         1631 foreach my $v (@_) {
456 2340 50 33     10905 $self->error_code('zeroval') unless defined $v and $v >= 0;
457              
458 2340 100       4929 if ($v == 0) { $self->write(3, 6); next; }
  75         826  
  75         209  
459 2265 100       4115 if ($v == 1) { $self->write(3, 7); next; }
  36         118  
  36         72  
460              
461 2229         3015 my $val = $v+1; # $val >= 3 (note ~0 will not encode)
462              
463             # Expand prime list as needed
464 2229 100       4573 $expand_primes_sub->(\@_pbasis, $val) if $_pbasis[-1] < $val;
465 2229 50       4378 $self->error_code('assert', "Basis not expanded to $val") unless $_pbasis[-1] >= $val;
466              
467             # Check to see if $val is prime
468 2229 100 100     8982 if ( (($val%2) != 0) && (($val == 3) || (($val%3) != 0)) ) {
      66        
469             # Not a multiple of 2 or 3, so look for it in _pbasis
470 668         801 my $spindex = 0;
471 668   100     3070 $spindex += 200 while exists $_pbasis[$spindex+200]
472             && $val > $_pbasis[$spindex+200];
473 668         24609 $spindex++ while $val > $_pbasis[$spindex];
474 668 100       1464 if ($val == $_pbasis[$spindex]) {
475             # We store the index (noting that value 3 is index 1 for us)
476 397         1240 $self->put_gamma($spindex);
477 397         1234 $self->write(1, 1);
478 397         936 next;
479             }
480             }
481              
482             # Odd integer.
483 1832 100       3949 if ( ($val % 2) == 1 ) {
484 569         1964 $self->write(1, 1);
485 569         876 $val--;
486             }
487              
488             # Encode the even value $val as the sum of two primes
489             my @best_pair = _find_best_pair(\@_pbasis, $val,
490 1832     26122   11004 sub { my($i,$j) = @_; ($i+1,$j-$i+1); } );
  26122         31762  
  26122         50754  
491              
492 1832 50       10222 $self->error_code('range', $v) unless @best_pair;
493 1832         6884 $self->put_gamma(@best_pair);
494             }
495 813         2489 1;
496             }
497              
498             sub get_goldbach_g2 {
499 813     813 1 13341 my $self = shift;
500 813 50       2364 $self->error_stream_mode('read') if $self->writing;
501              
502 813         1107 my $count = shift;
503 813 100       1893 if (!defined $count) { $count = 1; }
  792 50       1045  
    0          
504 21         35 elsif ($count < 0) { $count = ~0; } # Get everything
505 0         0 elsif ($count == 0) { return; }
506              
507 813         1034 my @vals;
508 813         1398 my $p = \@_pbasis;
509 813         2676 $self->code_pos_start('Goldbach G2');
510 813         24825 while ($count-- > 0) {
511 2361         6579 $self->code_pos_set;
512              
513             # Look at the start 3 values
514 2361         79257 my $look = $self->read(3, 'readahead');
515 2361 100       5019 last unless defined $look;
516              
517 2340 100       5074 if ($look == 6) { $self->skip(3); push @vals, 0; next; }
  75         260  
  75         117  
  75         339  
518 2265 100       4334 if ($look == 7) { $self->skip(3); push @vals, 1; next; }
  36         116  
  36         47  
  36         97  
519              
520 2229         2502 my $val = -1; # Take into account the +1 for 1-based
521              
522 2229 100       4290 if ($look >= 4) { # First bit is a 1 => Odd number
523 569         772 $val++;
524 569         1737 $self->skip(1);
525             }
526              
527 2229         6940 my ($i,$j) = $self->get_gamma(2);
528 2229 50 33     10610 $self->error_off_stream unless defined $i && defined $j;
529              
530 2229 100       5319 my $maxindex = ($j == 0) ? $i : $j + ($i-1) - 1;
531 2229 50       5024 $expand_primes_sub->(\@_pbasis, -$maxindex) unless defined $p->[$maxindex];
532 2229 50       4140 $self->error_code('overflow') unless defined $p->[$maxindex];
533 2229 100       3819 if ($j == 0) {
534 397         655 $val += $p->[$i];
535             } else {
536 1832         2354 $i = $i - 1;
537 1832         2191 $j = $j + $i - 1;
538 1832         3317 $val += $p->[$i] + $p->[$j];
539             }
540              
541 2229         6786 push @vals, $val;
542             }
543 813         2613 $self->code_pos_end;
544 813 100       26070 wantarray ? @vals : $vals[-1];
545             }
546              
547              
548 28     28   146819 no Moo::Role;
  28         81  
  28         242  
549             1;
550              
551             # ABSTRACT: A Role implementing Additive codes
552              
553             =pod
554              
555             =head1 NAME
556              
557             Data::BitStream::Code::Additive - A Role implementing Additive codes
558              
559             =head1 VERSION
560              
561             version 0.08
562              
563              
564             =head1 DESCRIPTION
565              
566             A role written for L that provides get and set methods for
567             Additive codes. The role applies to a stream object.
568              
569             If you use the Goldbach codes for inputs more than ~1000, I highly recommend
570             installing L for better performance. While these codes
571             were not designed for large inputs, they work fine, however at large
572             computational costs.
573              
574              
575             =head1 EXAMPLES
576              
577             use Data::BitStream;
578              
579             my @array = (4, 2, 0, 3, 7, 72, 0, 1, 13);
580              
581             $stream->put_goldbach_g1( @array );
582             $stream->rewind_for_read;
583             my @array2 = $stream->get_goldbach_g1( -1 );
584              
585             my @seeds = (2, 16, 46);
586             $stream->erase_for_write;
587             $stream->put_additive_seeded( \@seeds, @array );
588             $stream->rewind_for_read;
589             my @array2 = $stream->get_additive_seeded( \@seeds, -1 );
590              
591             my @basis = (0,1,3,5,7,8,10,16,22,28,34,40,46,52,58,64,70,76,82,88,94);
592             $stream->erase_for_write;
593             $stream->put_additive( \@basis, @array );
594             $stream->rewind_for_read;
595             my @array2 = $stream->get_additive( \@basis, -1 );
596             =head1 METHODS
597              
598             =head2 Provided Object Methods
599              
600             =over 4
601              
602             =item B< put_goldbach_g1($value) >
603              
604             =item B< put_goldbach_g1(@values) >
605              
606             Insert one or more values as Goldbach G1 codes. Returns 1.
607             The Goldbach conjecture claims that any even number is the sum of two primes.
608             This coding finds, for any value, the shortest pair of gamma-encoded prime
609             indices that form C<2*($value+1)>.
610              
611             =item B< get_goldbach_g1() >
612              
613             =item B< get_goldbach_g1($count) >
614              
615             Decode one or more Goldbach G1 codes from the stream. If count is omitted,
616             one value will be read. If count is negative, values will be read until
617             the end of the stream is reached. In scalar context it returns the last
618             code read; in array context it returns an array of all codes read.
619              
620             =item B< put_goldbach_g2($value) >
621              
622             =item B< put_goldbach_g2(@values) >
623              
624             Insert one or more values as Goldbach G2 codes. Returns 1. Uses a different
625             coding than G1 that should yield slightly smaller codes for large values. They
626             will also be almost twice as fast to encode and decode.
627              
628             =item B< get_goldbach_g2() >
629              
630             =item B< get_goldbach_g2($count) >
631              
632             Decode one or more Goldbach G2 codes from the stream. If count is omitted,
633             one value will be read. If count is negative, values will be read until
634             the end of the stream is reached. In scalar context it returns the last
635             code read; in array context it returns an array of all codes read.
636              
637             =item B< put_additive_seeded(\@seeds, $value) >
638              
639             =item B< put_additive_seeded(\@seeds, @values) >
640              
641             Insert one or more values as Additive codes. Returns 1. Arbitrary values
642             may be given as input, with the basis constructed as needed using the seeds.
643             The seeds should be sorted and not contain duplicates. They will typically
644             be even numbers. Examples include
645             C<[2,16,46]>, C<[2,34,82]>, C<[2,52,154,896]>. Each generated basis is
646             cached, so successive put/get calls using the same seeds will run quickly.
647              
648             =item B< get_additive_seeded(\@seeds) >
649              
650             =item B< get_additive_seeded(\@seeds, $count) >
651              
652             Decode one or more Additive codes from the stream. If count is omitted,
653             one value will be read. If count is negative, values will be read until
654             the end of the stream is reached. In scalar context it returns the last
655             code read; in array context it returns an array of all codes read.
656              
657             =item B< generate_additive_basis($maxval, @seeds) >
658              
659             Construct an additive basis from C<0> to C<$maxval> using the given seeds.
660             This allows construction of bases as shown in Fenwick's 2002 paper. The
661             basis is returned as an array. The bases will be identical to those used
662             with the C routines, though the latter allows the
663             basis to be expanded as needed.
664              
665             =item B< put_additive(\@basis, $value) >
666              
667             =item B< put_additive(\@basis, @values) >
668              
669             Insert one or more values as 2-ary additive codes. Returns 1. An arbitrary
670             basis to be used is provided. This basis should be sorted and consist of
671             non-negative integers. For each value, all possible pairs C<(i,j)> are found
672             where C, with the pair having the smallest sum of Gamma
673             encoding for C and C being chosen. This pair is then Gamma encoded.
674             If no two values in the basis sum to the requested value, a range error results.
675              
676             =item B< put_additive(sub { ... }, \@basis, @values) >
677              
678             Insert one or more values as 2-ary additive codes, as above. The provided
679             subroutine is used to expand the basis as needed if a value is too large for
680             the current basis. As before, the basis should be sorted and consist of
681             non-negative integers. It is assumed the basis is complete up to the last
682             element (that is, the basis will only be expanded). The argument to the sub
683             is a reference to the basis array and a value. When returned, the last entry
684             of the basis should be greater than or equal to the value.
685              
686             =item B< get_additive(\@basis) >
687              
688             =item B< get_additive(\@basis, $count) >
689              
690             Decode one or more 2-ary additive codes from the stream. If count is omitted,
691             one value will be read. If count is negative, values will be read until
692             the end of the stream is reached. In scalar context it returns the last
693             code read; in array context it returns an array of all codes read.
694              
695             =item B< get_additive(sub { ... }, \@basis, @values) >
696              
697             Decode one or more values as 2-ary additive codes, as above. The provided
698             subroutine is used to expand the basis as needed if an index is too large for
699             the current basis. The argument to the sub is a reference to the basis array
700             and a negative index. When returned, index C<-$index> of the basis must be
701             defined as a non-negative integer.
702              
703             =back
704              
705             =head2 Parameters
706              
707             Both the basis and seed arrays are passed as array references. The basis
708             array may be modified if a sub is given (since its job is to expand the basis).
709             It is possible to use a tied array as the basis, but using an expansion
710             callback sub is typically faster.
711              
712             =head2 Required Methods
713              
714             =over 4
715              
716             =item B< read >
717              
718             =item B< write >
719              
720             =item B< get_gamma >
721              
722             =item B< put_gamma >
723              
724             These methods are required for the role.
725              
726             =back
727              
728             =head1 SEE ALSO
729              
730             =over 4
731              
732             =item L
733              
734             =item L
735              
736             =item L
737              
738             =item Peter Fenwick, "Variable-Length Integer Codes Based on the Goldbach Conjecture, and Other Additive Codes", IEEE Trans. Information Theory 48(8), pp 2412-2417, Aug 2002.
739              
740             =back
741              
742             =head1 AUTHORS
743              
744             Dana Jacobsen
745              
746             =head1 COPYRIGHT
747              
748             Copyright 2012 by Dana Jacobsen
749              
750             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
751              
752             =cut