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

# Copyright 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Kevin Ryde

# This file is part of Math-OEIS.
#
# Math-OEIS is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# Math-OEIS is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with Math-OEIS.  If not, see .

package Math::OEIS::Grep;
use 5.006;
use strict;
use warnings;
use Carp 'croak';
use Math::OEIS::Names;
use Math::OEIS::Stripped;

our $VERSION = 14;

# uncomment this to run the ### lines
# use Smart::Comments;


my $stripped_mmap;

sub import {
  my $class = shift;
  my $arg = shift;
  if ($arg && $arg eq '-search') {
    ### Grep import() -search

    # Encode::Locale output coding if available, otherwise utf8 since that
    # is the coding of the names file so we become a pass-through.
    eval {
      require Encode;
      require PerlIO::encoding;
      my $coding = 'utf8';
      eval { require Encode::Locale; $coding = 'console_out'; };
      $coding = ":encoding($coding)";
      {
        local $PerlIO::encoding::fallback = Encode::PERLQQ();
        binmode(STDOUT, $coding);
        # Not sure coding on STDERR is a good idea, could loop trying to print.
        # binmode(STDERR, $coding);
      }
      ### $coding
    };
    $class->search(array=>\@_);
    exit 0;
  }
}

sub search {
  ### Grep search() ...
  my $class = shift;
  my %h = (try_abs     => 1,
           verbose     => 0,
           use_mmap    => 'if_possible',
           max_matches => 10,
           @_);
  ### $class

  my $verbose = $h{'verbose'} || 0;

  my $values_min = $h{'values_min'};
  my $values_max = $h{'values_max'};
  ### $values_min
  ### $values_max

  my $name = $h{'name'};
  if (defined $name) {
    $name = "$name: ";
  } else {
    $name = '';
  }
  ### $name

  my %exclude;
  if (my $aref = $h{'exclude_list'}) {
    @exclude{@$aref} = ();  # hash slice
  }
  ### %exclude

  my $array = $h{'array'};
  if (! $array) {
    my $string = $h{'string'};
    $string =~ s/\s+/,/;
    $array = [ grep {defined} split /,+/, $string ];
  }
  unless ($array) {
    croak 'search() missing array=>[] parameter';
  }
  if (@$array == 0) {
    ### empty ...
    print "${name}no match empty list of values\n\n";
    return;
  }

  my $use_mmap = $h{'use_mmap'};

  if ($use_mmap && ! defined $stripped_mmap) {
    my $stripped_obj = Math::OEIS::Stripped->instance;
    my $stripped_filename = $stripped_obj->filename;
    if (eval {
      require File::Map;
      File::Map::map_file ($stripped_mmap, $stripped_filename);
      1;
    }) {
      if ($verbose) {
        print "mmap stripped file, length ",length($stripped_mmap),"\n";
      }
    } else {
      my $err = $@;
      if ($use_mmap eq 'if_possible') {
        if ($verbose >= 2) {
          print "cannot mmap, fallback to open: $err\n";
        }
        $use_mmap = 0;
      } else {
        croak "Cannot mmap $stripped_filename: $err";
      }
    }
  }

  my $fh;
  if (! $use_mmap) {
    # ENHANCE-ME: show the reason ENOENT etc here
    $fh = Math::OEIS::Stripped->fh
      || croak "Cannot open ~/OEIS/stripped file";
  }

  {
    my $str = $array->[0];
    for (my $i = 1; $i <= $#$array; $i++) {
      $str .= ','.$array->[$i];
      if (length($str) > 50 && $i != $#$array) {
        $str .= ',...';
        last;
      }
    }
    $name .= "match $str\n";
  }

  if (defined (my $value = _constant_array(@$array))) {
    if ($value != 0 && abs($value) <= 1000) {
      print "${name}constant $value\n\n";
      return;
    }
  }

  if (defined (my $diff = _constant_diff(@$array))) {
    if (abs($diff) < 20 && abs($array->[0]) < 100) {
      print "${name}constant difference $diff\n\n";
      return;
    }
  }

  if ($verbose) {
    print $name;
    $name = '';
  }
  ### $use_mmap

  my $max_matches = $h{'max_matches'};
  my $count = 0;

  my $orig_array = $array;
  my @orig_mung_desc;
  my @mung_desc;
  my $show_mung;   # when mung_desc changed so show it if any match
 MUNG: foreach my $mung ('none',
                         ($h{'_EXPERIMENTAL_exact'}
                          ? ()
                          : ('trim',
                             'negate',
                             ($h{'try_abs'} ? 'abs' : ()),
                             'half',
                             'quarter',
                             'double')),
                        ){
    ### $mung
    last if $count;  # no more munging when found a match

    if ($mung eq 'none') {

    } elsif ($mung eq 'trim') {
      my $count = 0;
      $array = [ @$orig_array ]; # copy
      while (@$array && $array->[0] == 0) {  # leading zeros
        shift @$array;
        $count++;
      }
      if (@$array) {   # plus one more
        shift @$array;
        $count++;
      }
      ### trimmed to: join(',',@$array)
      @orig_mung_desc = ("[TRIMMED START $count VALUES]");
      $show_mung = 1;
      if (_aref_any_nonzero($array) &&
          (@$array >= 3 || length(join(',',@$array)) >= 5)) {
        $orig_array = $array;
      } else {
        ### too few values to trim ...
        next MUNG;
      }

    } elsif ($mung eq 'negate') {
      @mung_desc = ('[NEGATED]');
      $show_mung = 1;
      $array = [ map { my $value = $_;
                       unless ($value eq '0' || $value =~ s/^-//) {
                         $value = "-$value";
                       }
                       $value
                     } @$orig_array ];

    } elsif ($mung eq 'half') {
      @mung_desc = ('[HALF]');
      $show_mung = 1;
      $array = [ map {
        my $value = _to_bigint($_);
        if ($value % 2) {
          if ($verbose) {
            print "not all even, skip halving\n";
          }
          next MUNG;
        }
        $value/2
      } @$orig_array ];

    } elsif ($mung eq 'quarter') {
      @mung_desc = ('[QUARTER]');
      $show_mung = 1;
      $array = [ map {
        my $value = _to_bigint($_);
        if ($value % 4) {
          if ($verbose) {
            print "not all multiple of 4, skip quartering\n";
          }
          next MUNG;
        }
        $value/4
      } @$orig_array ];

    } elsif ($mung eq 'double') {
      @mung_desc = ('[DOUBLE]');
      $show_mung = 1;
      $array = [ map {2*_to_bigint($_)} @$orig_array ];

    } elsif ($mung eq 'abs') {
      @mung_desc = ('[ABSOLUTE VALUES]');
      $show_mung = 1;
      my $any_negative = 0;
      $array = [ map { my $abs = $_;
                       $any_negative |= ($abs =~ s/^-//);
                       $abs
                     } @$orig_array ];
      if (! $any_negative) {
        if ($verbose) {
          print "no negatives, skip absolutize\n";
        }
        next;
      }
      if (_constant_array(@$array)) {
        if ($verbose) {
          print "abs values all equal, skip absolutize\n";
        }
        next;
      }
    }

    ### @mung_desc
    ### @orig_mung_desc

    my $re = $class->array_to_regexp($array);
    if ($h{'_EXPERIMENTAL_exact'}) {
      $re = ' '.$re;
    }

    if ($use_mmap) {
      pos($stripped_mmap) = 0;
      ### mmap total length: length($stripped_mmap)
    } else {
      seek $fh, 0, 0
        or croak "Error seeking stripped file: ",$!;
    }
    my $block = '';
    my $extra = '';
  SEARCH: for (;;) {
      my $line;
      if ($use_mmap) {

        # using regexp only
        $stripped_mmap =~ /$re/g or last SEARCH;
        my $found_pos = pos($stripped_mmap);

        # my $found_whole = $&;
        # ### $found_whole

        # $re matches , or \n at end
        # $found_pos may be after \n of matched line
        # So for $end look from $found_pos-1 onwards.
        # For $start look from $found_pos-2 since don't want rindex() to
        # give the \n which is at $found_pos-1.
        my $start = rindex($stripped_mmap,"\n",$found_pos-2) + 1;
        my $end = index($stripped_mmap,"\n",$found_pos-1);
        pos($stripped_mmap) = $end;
        $line = substr($stripped_mmap, $start, $end-$start);

        ### $found_pos
        ### char at found_pos: substr($stripped_mmap,$found_pos,1)
        ### $start
        ### $end
        ### found_pos from line end: $end-$found_pos
        ### $line
        ### assert: $end >= $start

        # my $pos = 0;
        # using combination index() and regexp
        # for (;;) {
        #   $stripped_mmap =~ /$re/g or last SEARCH;
        #   my $found_pos = pos($stripped_mmap)-1;
        #   # my $found_pos = index($stripped_mmap,$fixed,$pos);
        #   # if ($found_pos < 0) { last SEARCH; }
        #
        #   my $start = rindex($stripped_mmap,"\n",$found_pos) + 1;
        #   my $end = index($stripped_mmap,"\n",$found_pos);
        #   $pos = $end;
        #   $line = substr($stripped_mmap, $start, $end-$start);
        #   last if $line =~ $re;
        # }

      } else {
        ### block reads ...

        for (;;) {
          if ($block =~ /$re/g) {
            # same $found_pos logic as the mmap case above
            my $found_pos = pos($block);
            my $start = rindex($block,"\n",$found_pos-2) + 1;
            my $end = index($block,"\n",$found_pos-1);
            pos($block) = $end;
            $line = substr($block, $start, $end-$start);
            last;
          }
          $block = _read_block_lines($fh, $extra);
          defined $block or last SEARCH;

          # or line by line
          # $line = readline $fh;
          # defined $line or last SEARCH;
        }
      }

      my ($anum,$found_values_str)
        = Math::OEIS::Stripped->line_split_anum($line)
        or die "oops, A-number not matched in line: ",$line;
      ### $anum

      if (exists $exclude{$anum}) {
        ### exclude ...
        next;
      }

      # enforce values_min, values_max on the found sequence
      if (defined $values_min || defined $values_max) {
        my @found_values =Math::OEIS::Stripped->values_split($found_values_str);
        if ((defined $values_min && grep {$_ < $values_min} @found_values)
            || (defined $values_max && grep {$_ > $values_max} @found_values)) {
          ### skip due to found values out of range ...
          next;
        }
      }

      if (defined $max_matches && $count >= $max_matches) {
        print "... and more matches\n";
        last SEARCH;
      }

      print $name;
      $name = '';

      if ($show_mung && (@orig_mung_desc || @mung_desc)) {
        print join(' ',@mung_desc,@orig_mung_desc),"\n";
        $show_mung = 0;
      }

      my $anum_name = Math::OEIS::Names->anum_to_name($anum);
      if (! defined $anum_name) { $anum_name = '[unknown name]'; }
      print "$anum $anum_name\n";

      print "$line\n";
      $count++;
    }
  }
  if ($count == 0) {
    if ($verbose) {
      print "no matches\n";
    }
  }
  if ($count || $verbose) {
    print "\n";
  }
}

# Read a block of multiple lines from $fh.
# The return is a string $block, or undef at EOF.
# $extra in $_[1] is used to hold a partial line.
sub _read_block_lines {
  my ($fh, $extra) = @_;
  my $block = $extra;
  for (;;) {
    my $len = read($fh, $block, 65536,
                   length($block)); # append to $block
    if (! defined $len) {
      croak "Error seeking stripped file: ",$!;
    }
    if (! $len) {
      # EOF
      $_[1] = '';
      if (length ($block)) {
        return $block;
      } else {
        return undef;
      }
    }
    my $end = rindex $block, "\n";
    if ($end >= 0) {
      # keep partial line in $extra
      $_[1] = substr ($block, $end);                  # partial line
      substr($block, $end, length($block)-$end, '');  # truncate block
      return $block;
    }
    # no end of line in $block, keep reading to find one
  }
}

use constant _MIN_MATCH_COUNT => 15;
use constant _MIN_MATCH_CHARS => 40;
use constant _MAX_REGEXP_LENGTH => 400;

# Return a regexp (a string) which matches the numbers in $array.
# $str =~ s/^\s+//;
# $str =~ s/\s+$//;
# split /\s*,\s*/, $str
sub array_to_regexp {
  my ($self, $array) = @_;
  ### array_to_regexp(): join(',',@$array)
  my $re = ',';
  my $close = 0;
  foreach my $i (0 .. $#$array) {
    my $value = $array->[$i];
    if (length($re) > _MAX_REGEXP_LENGTH) {  # don't make a huge regexp
      last;
    }

    # Mandatory match of numbers or chars, whichever comes first,
    # after that OEIS can end.
    # Most OEIS samples are nice and long, with even hard ones going to
    # limits of reasonable computing, but some are shorter.  For example
    # A109680 circa July 2016 had only 19 values 46 chars.
    # ENHANCE-ME: take a parameter for these minimums.
    #
    if ($i >= _MIN_MATCH_COUNT || length($re) > _MIN_MATCH_CHARS) {
      $re .= '(?:[\r\n]|';
      $close++;
    }
    $re .= $value . ',';
  }
  $re .= ')' x $close;
#  $re .= "[,\r\n]";
  ### $re
  return $re;
}

# constant_diff($a,$b,$c,...)
# If all the given values have a constant difference then return that amount.
# Otherwise return undef.
#
sub _constant_diff {
  my $diff = shift;
  unless (@_) {
    return undef;
  }
  my $value = shift;
  $diff = $value - $diff;
  while (@_) {
    my $next_value = shift;
    if ($next_value - $value != $diff) {
      return undef;
    }
    $value = $next_value;
  }
  return $diff;
}

# _constant_array($a,$b,$c,...)
# If all the given values are all equal then return that value.
# Otherwise return undef.
#
sub _constant_array {
  my $value = shift;
  while (@_) {
    my $next_value = shift;
    if ($next_value != $value) {
      return undef;
    }
  }
  return $value;
}

# return true if the array in $aref has any non-zero entries
sub _aref_any_nonzero {
  my ($aref) = @_;
  foreach my $value (@$aref) {
    if ($value) { return 1; }
  }
  return 0;
}

{
  my $bigint_class;
  my $length_limit = length(~0) - 2;
  sub _to_bigint {
    my ($n) = @_;
    if (length($n) < $length_limit) {
      return $n;
    }
    $bigint_class ||= do {
      # Crib note: don't change the back-end if already loaded
      require Math::BigInt;
      'Math::BigInt'
    };
    # stringize as a workaround for a bug where Math::BigInt::GMP
    # incorrectly converts UV numbers bigger than IV
    return $bigint_class->new("$n");
  }
}

1;
__END__