File Coverage

blib/lib/Math/OEIS/Grep.pm
Criterion Covered Total %
statement 41 281 14.5
branch 7 134 5.2
condition 1 62 1.6
subroutine 11 17 64.7
pod 1 2 50.0
total 61 496 12.3


line stmt bran cond sub pod time code
1             # Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde
2              
3             # This file is part of Math-OEIS.
4             #
5             # Math-OEIS is free software; you can redistribute it and/or modify it
6             # under the terms of the GNU General Public License as published by the Free
7             # Software Foundation; either version 3, or (at your option) any later
8             # version.
9             #
10             # Math-OEIS is distributed in the hope that it will be useful, but
11             # WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
12             # or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
13             # for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Math-OEIS. If not, see .
17              
18             package Math::OEIS::Grep;
19 1     1   74020 use 5.006;
  1         4  
20 1     1   6 use strict;
  1         2  
  1         19  
21 1     1   5 use warnings;
  1         2  
  1         42  
22 1     1   7 use Carp 'croak';
  1         1  
  1         47  
23 1     1   485 use Math::OEIS::Names;
  1         3  
  1         32  
24 1     1   476 use Math::OEIS::Stripped;
  1         3  
  1         1957  
25              
26             our $VERSION = 14;
27              
28             # uncomment this to run the ### lines
29             # use Smart::Comments;
30              
31              
32             my $stripped_mmap;
33              
34             sub import {
35 1     1   8 my $class = shift;
36 1         3 my $arg = shift;
37 1 50 33     1812 if ($arg && $arg eq '-search') {
38             ### Grep import() -search
39              
40             # Encode::Locale output coding if available, otherwise utf8 since that
41             # is the coding of the names file so we become a pass-through.
42 0         0 eval {
43 0         0 require Encode;
44 0         0 require PerlIO::encoding;
45 0         0 my $coding = 'utf8';
46 0         0 eval { require Encode::Locale; $coding = 'console_out'; };
  0         0  
  0         0  
47 0         0 $coding = ":encoding($coding)";
48             {
49 0         0 local $PerlIO::encoding::fallback = Encode::PERLQQ();
  0         0  
50 0         0 binmode(STDOUT, $coding);
51             # Not sure coding on STDERR is a good idea, could loop trying to print.
52             # binmode(STDERR, $coding);
53             }
54             ### $coding
55             };
56 0         0 $class->search(array=>\@_);
57 0         0 exit 0;
58             }
59             }
60              
61             sub search {
62             ### Grep search() ...
63 0     0 1 0 my $class = shift;
64 0         0 my %h = (try_abs => 1,
65             verbose => 0,
66             use_mmap => 'if_possible',
67             max_matches => 10,
68             @_);
69             ### $class
70              
71 0   0     0 my $verbose = $h{'verbose'} || 0;
72              
73 0         0 my $values_min = $h{'values_min'};
74 0         0 my $values_max = $h{'values_max'};
75             ### $values_min
76             ### $values_max
77              
78 0         0 my $name = $h{'name'};
79 0 0       0 if (defined $name) {
80 0         0 $name = "$name: ";
81             } else {
82 0         0 $name = '';
83             }
84             ### $name
85              
86 0         0 my %exclude;
87 0 0       0 if (my $aref = $h{'exclude_list'}) {
88 0         0 @exclude{@$aref} = (); # hash slice
89             }
90             ### %exclude
91              
92 0         0 my $array = $h{'array'};
93 0 0       0 if (! $array) {
94 0         0 my $string = $h{'string'};
95 0         0 $string =~ s/\s+/,/;
96 0         0 $array = [ grep {defined} split /,+/, $string ];
  0         0  
97             }
98 0 0       0 unless ($array) {
99 0         0 croak 'search() missing array=>[] parameter';
100             }
101 0 0       0 if (@$array == 0) {
102             ### empty ...
103 0         0 print "${name}no match empty list of values\n\n";
104 0         0 return;
105             }
106              
107 0         0 my $use_mmap = $h{'use_mmap'};
108              
109 0 0 0     0 if ($use_mmap && ! defined $stripped_mmap) {
110 0         0 my $stripped_obj = Math::OEIS::Stripped->instance;
111 0         0 my $stripped_filename = $stripped_obj->filename;
112 0 0       0 if (eval {
113 0         0 require File::Map;
114 0         0 File::Map::map_file ($stripped_mmap, $stripped_filename);
115 0         0 1;
116             }) {
117 0 0       0 if ($verbose) {
118 0         0 print "mmap stripped file, length ",length($stripped_mmap),"\n";
119             }
120             } else {
121 0         0 my $err = $@;
122 0 0       0 if ($use_mmap eq 'if_possible') {
123 0 0       0 if ($verbose >= 2) {
124 0         0 print "cannot mmap, fallback to open: $err\n";
125             }
126 0         0 $use_mmap = 0;
127             } else {
128 0         0 croak "Cannot mmap $stripped_filename: $err";
129             }
130             }
131             }
132              
133 0         0 my $fh;
134 0 0       0 if (! $use_mmap) {
135             # ENHANCE-ME: show the reason ENOENT etc here
136 0   0     0 $fh = Math::OEIS::Stripped->fh
137             || croak "Cannot open ~/OEIS/stripped file";
138             }
139              
140             {
141 0         0 my $str = $array->[0];
  0         0  
142 0         0 for (my $i = 1; $i <= $#$array; $i++) {
143 0         0 $str .= ','.$array->[$i];
144 0 0 0     0 if (length($str) > 50 && $i != $#$array) {
145 0         0 $str .= ',...';
146 0         0 last;
147             }
148             }
149 0         0 $name .= "match $str\n";
150             }
151              
152 0 0       0 if (defined (my $value = _constant_array(@$array))) {
153 0 0 0     0 if ($value != 0 && abs($value) <= 1000) {
154 0         0 print "${name}constant $value\n\n";
155 0         0 return;
156             }
157             }
158              
159 0 0       0 if (defined (my $diff = _constant_diff(@$array))) {
160 0 0 0     0 if (abs($diff) < 20 && abs($array->[0]) < 100) {
161 0         0 print "${name}constant difference $diff\n\n";
162 0         0 return;
163             }
164             }
165              
166 0 0       0 if ($verbose) {
167 0         0 print $name;
168 0         0 $name = '';
169             }
170             ### $use_mmap
171              
172 0         0 my $max_matches = $h{'max_matches'};
173 0         0 my $count = 0;
174              
175 0         0 my $orig_array = $array;
176 0         0 my @orig_mung_desc;
177             my @mung_desc;
178 0         0 my $show_mung; # when mung_desc changed so show it if any match
179 0 0       0 MUNG: foreach my $mung ('none',
    0          
180             ($h{'_EXPERIMENTAL_exact'}
181             ? ()
182             : ('trim',
183             'negate',
184             ($h{'try_abs'} ? 'abs' : ()),
185             'half',
186             'quarter',
187             'double')),
188             ){
189             ### $mung
190 0 0       0 last if $count; # no more munging when found a match
191              
192 0 0       0 if ($mung eq 'none') {
    0          
    0          
    0          
    0          
    0          
    0          
193              
194             } elsif ($mung eq 'trim') {
195 0         0 my $count = 0;
196 0         0 $array = [ @$orig_array ]; # copy
197 0   0     0 while (@$array && $array->[0] == 0) { # leading zeros
198 0         0 shift @$array;
199 0         0 $count++;
200             }
201 0 0       0 if (@$array) { # plus one more
202 0         0 shift @$array;
203 0         0 $count++;
204             }
205             ### trimmed to: join(',',@$array)
206 0         0 @orig_mung_desc = ("[TRIMMED START $count VALUES]");
207 0         0 $show_mung = 1;
208 0 0 0     0 if (_aref_any_nonzero($array) &&
      0        
209             (@$array >= 3 || length(join(',',@$array)) >= 5)) {
210 0         0 $orig_array = $array;
211             } else {
212             ### too few values to trim ...
213 0         0 next MUNG;
214             }
215              
216             } elsif ($mung eq 'negate') {
217 0         0 @mung_desc = ('[NEGATED]');
218 0         0 $show_mung = 1;
219 0         0 $array = [ map { my $value = $_;
  0         0  
220 0 0 0     0 unless ($value eq '0' || $value =~ s/^-//) {
221 0         0 $value = "-$value";
222             }
223             $value
224 0         0 } @$orig_array ];
225              
226             } elsif ($mung eq 'half') {
227 0         0 @mung_desc = ('[HALF]');
228 0         0 $show_mung = 1;
229             $array = [ map {
230 0         0 my $value = _to_bigint($_);
  0         0  
231 0 0       0 if ($value % 2) {
232 0 0       0 if ($verbose) {
233 0         0 print "not all even, skip halving\n";
234             }
235 0         0 next MUNG;
236             }
237 0         0 $value/2
238             } @$orig_array ];
239              
240             } elsif ($mung eq 'quarter') {
241 0         0 @mung_desc = ('[QUARTER]');
242 0         0 $show_mung = 1;
243             $array = [ map {
244 0         0 my $value = _to_bigint($_);
  0         0  
245 0 0       0 if ($value % 4) {
246 0 0       0 if ($verbose) {
247 0         0 print "not all multiple of 4, skip quartering\n";
248             }
249 0         0 next MUNG;
250             }
251 0         0 $value/4
252             } @$orig_array ];
253              
254             } elsif ($mung eq 'double') {
255 0         0 @mung_desc = ('[DOUBLE]');
256 0         0 $show_mung = 1;
257 0         0 $array = [ map {2*_to_bigint($_)} @$orig_array ];
  0         0  
258              
259             } elsif ($mung eq 'abs') {
260 0         0 @mung_desc = ('[ABSOLUTE VALUES]');
261 0         0 $show_mung = 1;
262 0         0 my $any_negative = 0;
263 0         0 $array = [ map { my $abs = $_;
  0         0  
264 0         0 $any_negative |= ($abs =~ s/^-//);
265 0         0 $abs
266             } @$orig_array ];
267 0 0       0 if (! $any_negative) {
268 0 0       0 if ($verbose) {
269 0         0 print "no negatives, skip absolutize\n";
270             }
271 0         0 next;
272             }
273 0 0       0 if (_constant_array(@$array)) {
274 0 0       0 if ($verbose) {
275 0         0 print "abs values all equal, skip absolutize\n";
276             }
277 0         0 next;
278             }
279             }
280              
281             ### @mung_desc
282             ### @orig_mung_desc
283              
284 0         0 my $re = $class->array_to_regexp($array);
285 0 0       0 if ($h{'_EXPERIMENTAL_exact'}) {
286 0         0 $re = ' '.$re;
287             }
288              
289 0 0       0 if ($use_mmap) {
290 0         0 pos($stripped_mmap) = 0;
291             ### mmap total length: length($stripped_mmap)
292             } else {
293 0 0       0 seek $fh, 0, 0
294             or croak "Error seeking stripped file: ",$!;
295             }
296 0         0 my $block = '';
297 0         0 my $extra = '';
298 0         0 SEARCH: for (;;) {
299 0         0 my $line;
300 0 0       0 if ($use_mmap) {
301              
302             # using regexp only
303 0 0       0 $stripped_mmap =~ /$re/g or last SEARCH;
304 0         0 my $found_pos = pos($stripped_mmap);
305              
306             # my $found_whole = $&;
307             # ### $found_whole
308              
309             # $re matches , or \n at end
310             # $found_pos may be after \n of matched line
311             # So for $end look from $found_pos-1 onwards.
312             # For $start look from $found_pos-2 since don't want rindex() to
313             # give the \n which is at $found_pos-1.
314 0         0 my $start = rindex($stripped_mmap,"\n",$found_pos-2) + 1;
315 0         0 my $end = index($stripped_mmap,"\n",$found_pos-1);
316 0         0 pos($stripped_mmap) = $end;
317 0         0 $line = substr($stripped_mmap, $start, $end-$start);
318              
319             ### $found_pos
320             ### char at found_pos: substr($stripped_mmap,$found_pos,1)
321             ### $start
322             ### $end
323             ### found_pos from line end: $end-$found_pos
324             ### $line
325             ### assert: $end >= $start
326              
327             # my $pos = 0;
328             # using combination index() and regexp
329             # for (;;) {
330             # $stripped_mmap =~ /$re/g or last SEARCH;
331             # my $found_pos = pos($stripped_mmap)-1;
332             # # my $found_pos = index($stripped_mmap,$fixed,$pos);
333             # # if ($found_pos < 0) { last SEARCH; }
334             #
335             # my $start = rindex($stripped_mmap,"\n",$found_pos) + 1;
336             # my $end = index($stripped_mmap,"\n",$found_pos);
337             # $pos = $end;
338             # $line = substr($stripped_mmap, $start, $end-$start);
339             # last if $line =~ $re;
340             # }
341              
342             } else {
343             ### block reads ...
344              
345 0         0 for (;;) {
346 0 0       0 if ($block =~ /$re/g) {
347             # same $found_pos logic as the mmap case above
348 0         0 my $found_pos = pos($block);
349 0         0 my $start = rindex($block,"\n",$found_pos-2) + 1;
350 0         0 my $end = index($block,"\n",$found_pos-1);
351 0         0 pos($block) = $end;
352 0         0 $line = substr($block, $start, $end-$start);
353 0         0 last;
354             }
355 0         0 $block = _read_block_lines($fh, $extra);
356 0 0       0 defined $block or last SEARCH;
357              
358             # or line by line
359             # $line = readline $fh;
360             # defined $line or last SEARCH;
361             }
362             }
363              
364 0 0       0 my ($anum,$found_values_str)
365             = Math::OEIS::Stripped->line_split_anum($line)
366             or die "oops, A-number not matched in line: ",$line;
367             ### $anum
368              
369 0 0       0 if (exists $exclude{$anum}) {
370             ### exclude ...
371 0         0 next;
372             }
373              
374             # enforce values_min, values_max on the found sequence
375 0 0 0     0 if (defined $values_min || defined $values_max) {
376 0         0 my @found_values =Math::OEIS::Stripped->values_split($found_values_str);
377 0 0 0     0 if ((defined $values_min && grep {$_ < $values_min} @found_values)
  0   0     0  
      0        
378 0         0 || (defined $values_max && grep {$_ > $values_max} @found_values)) {
379             ### skip due to found values out of range ...
380 0         0 next;
381             }
382             }
383              
384 0 0 0     0 if (defined $max_matches && $count >= $max_matches) {
385 0         0 print "... and more matches\n";
386 0         0 last SEARCH;
387             }
388              
389 0         0 print $name;
390 0         0 $name = '';
391              
392 0 0 0     0 if ($show_mung && (@orig_mung_desc || @mung_desc)) {
      0        
393 0         0 print join(' ',@mung_desc,@orig_mung_desc),"\n";
394 0         0 $show_mung = 0;
395             }
396              
397 0         0 my $anum_name = Math::OEIS::Names->anum_to_name($anum);
398 0 0       0 if (! defined $anum_name) { $anum_name = '[unknown name]'; }
  0         0  
399 0         0 print "$anum $anum_name\n";
400              
401 0         0 print "$line\n";
402 0         0 $count++;
403             }
404             }
405 0 0       0 if ($count == 0) {
406 0 0       0 if ($verbose) {
407 0         0 print "no matches\n";
408             }
409             }
410 0 0 0     0 if ($count || $verbose) {
411 0         0 print "\n";
412             }
413             }
414              
415             # Read a block of multiple lines from $fh.
416             # The return is a string $block, or undef at EOF.
417             # $extra in $_[1] is used to hold a partial line.
418             sub _read_block_lines {
419 4     4   4178 my ($fh, $extra) = @_;
420 4         9 my $block = $extra;
421 4         5 for (;;) {
422 7         273 my $len = read($fh, $block, 65536,
423             length($block)); # append to $block
424 7 50       25 if (! defined $len) {
425 0         0 croak "Error seeking stripped file: ",$!;
426             }
427 7 100       12 if (! $len) {
428             # EOF
429 4         9 $_[1] = '';
430 4 100       11 if (length ($block)) {
431 2         107 return $block;
432             } else {
433 2         6 return undef;
434             }
435             }
436 3         276 my $end = rindex $block, "\n";
437 3 50       10 if ($end >= 0) {
438             # keep partial line in $extra
439 0           $_[1] = substr ($block, $end); # partial line
440 0           substr($block, $end, length($block)-$end, ''); # truncate block
441 0           return $block;
442             }
443             # no end of line in $block, keep reading to find one
444             }
445             }
446              
447 1     1   9 use constant _MIN_MATCH_COUNT => 15;
  1         2  
  1         55  
448 1     1   5 use constant _MIN_MATCH_CHARS => 40;
  1         2  
  1         73  
449 1     1   7 use constant _MAX_REGEXP_LENGTH => 400;
  1         1  
  1         512  
450              
451             # Return a regexp (a string) which matches the numbers in $array.
452             # $str =~ s/^\s+//;
453             # $str =~ s/\s+$//;
454             # split /\s*,\s*/, $str
455             sub array_to_regexp {
456 0     0 0   my ($self, $array) = @_;
457             ### array_to_regexp(): join(',',@$array)
458 0           my $re = ',';
459 0           my $close = 0;
460 0           foreach my $i (0 .. $#$array) {
461 0           my $value = $array->[$i];
462 0 0         if (length($re) > _MAX_REGEXP_LENGTH) { # don't make a huge regexp
463 0           last;
464             }
465              
466             # Mandatory match of numbers or chars, whichever comes first,
467             # after that OEIS can end.
468             # Most OEIS samples are nice and long, with even hard ones going to
469             # limits of reasonable computing, but some are shorter. For example
470             # A109680 circa July 2016 had only 19 values 46 chars.
471             # ENHANCE-ME: take a parameter for these minimums.
472             #
473 0 0 0       if ($i >= _MIN_MATCH_COUNT || length($re) > _MIN_MATCH_CHARS) {
474 0           $re .= '(?:[\r\n]|';
475 0           $close++;
476             }
477 0           $re .= $value . ',';
478             }
479 0           $re .= ')' x $close;
480             # $re .= "[,\r\n]";
481             ### $re
482 0           return $re;
483             }
484              
485             # constant_diff($a,$b,$c,...)
486             # If all the given values have a constant difference then return that amount.
487             # Otherwise return undef.
488             #
489             sub _constant_diff {
490 0     0     my $diff = shift;
491 0 0         unless (@_) {
492 0           return undef;
493             }
494 0           my $value = shift;
495 0           $diff = $value - $diff;
496 0           while (@_) {
497 0           my $next_value = shift;
498 0 0         if ($next_value - $value != $diff) {
499 0           return undef;
500             }
501 0           $value = $next_value;
502             }
503 0           return $diff;
504             }
505              
506             # _constant_array($a,$b,$c,...)
507             # If all the given values are all equal then return that value.
508             # Otherwise return undef.
509             #
510             sub _constant_array {
511 0     0     my $value = shift;
512 0           while (@_) {
513 0           my $next_value = shift;
514 0 0         if ($next_value != $value) {
515 0           return undef;
516             }
517             }
518 0           return $value;
519             }
520              
521             # return true if the array in $aref has any non-zero entries
522             sub _aref_any_nonzero {
523 0     0     my ($aref) = @_;
524 0           foreach my $value (@$aref) {
525 0 0         if ($value) { return 1; }
  0            
526             }
527 0           return 0;
528             }
529              
530             {
531             my $bigint_class;
532             my $length_limit = length(~0) - 2;
533             sub _to_bigint {
534 0     0     my ($n) = @_;
535 0 0         if (length($n) < $length_limit) {
536 0           return $n;
537             }
538 0   0       $bigint_class ||= do {
539             # Crib note: don't change the back-end if already loaded
540 0           require Math::BigInt;
541 0           'Math::BigInt'
542             };
543             # stringize as a workaround for a bug where Math::BigInt::GMP
544             # incorrectly converts UV numbers bigger than IV
545 0           return $bigint_class->new("$n");
546             }
547             }
548              
549             1;
550             __END__