File Coverage

blib/lib/Math/Aronson.pm

Criterion	Covered	Total	%
statement	89	95	93.6
branch	27	34	79.4
condition	8	13	61.5
subroutine	12	13	92.3
pod	2	2	100.0
total	138	157	87.9

# Copyright 2010, 2011, 2012 Kevin Ryde

# This file is part of Math-Aronson.
#
# Math-Aronson 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-Aronson 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-Aronson.  If not, see .

package Math::Aronson;
use 5.004;
use strict;
use Carp;

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

use vars '$VERSION';
$VERSION = 9;

# maybe a hi=>$limit option to stop the ret or queue building up beyond a
# desired point


my $unaccent;
BEGIN {
  if (eval "use Unicode::Normalize 'normalize'; 1") {
    $unaccent = sub {
      ### unaccent: $_[0]
      # uncombine the latin-1 etc equivs then strip the zero-width marks
      ($_[0] = normalize('D',$_[0])) =~ s/\pM+//g;
      };
  } else {
    $unaccent = sub {
      # latin-1, generated by devel/unaccent.pl
      $_[0] =~ tr/\300\301\302\303\304\305\307\310\311\312\313\314\315\316\317\321\322\323\324\325\326\331\332\333\334\335\340\341\342\343\344\345\347\350\351\352\353\354\355\356\357\361\362\363\364\365\366\371\372\373\374\375\377/AAAAAACEEEEIIIINOOOOOUUUUYaaaaaaceeeeiiiinooooouuuuyy/;
    };
  }
}

my %default_letter = ('en' => 'T',
                      'fr' => 'E');
my %default_initial_string = ('en' => 'is the',
                              'fr' => 'est la');
sub new {
  my $class = shift;
  ### Aronson new(): @_

  my @ret;
  my $self = bless { ret   => \@ret,
                     queue => [ ],
                     @_
                   }, $class;

  # 1 or '' for use with xor
  $self->{'lying'} = !! $self->{'lying'};

  my $lang = ($self->{'lang'} ||= 'en');  # default
  if ($lang eq 'en') {
    %$self = (conjunctions_word => 'and',
              %$self);
  } elsif ($lang eq 'fr') {
    %$self = (conjunctions_word => 'et',
              %$self);
  }
  # for oeis_anum()
  $self->{'lang'} = ($self->{'ordinal_func'} ? 'func' : lc($lang));

  my $without_conjunctions = delete $self->{'without_conjunctions'};
  my $conjunctions_word    = delete $self->{'conjunctions_word'};

  $self->{'conjunctions'}
    = (($lang eq 'en' && $conjunctions_word ne 'and')
       && ($lang eq 'fr' && $conjunctions_word ne 'et')
       ? 'x'
       : ($without_conjunctions ? 0 : 1));

  $self->{'ordinal_func'} ||=
    ($lang eq 'en' ? do {
      require Lingua::EN::Numbers;
      Lingua::EN::Numbers->VERSION(1.01);  # 1.01 rewrite
      \&Lingua::EN::Numbers::num2en_ordinal
    }
     : $lang eq 'fr' ? do {
       require Lingua::FR::Numbers;
       \&_fr_ordinal
     }
     : do {
       require Lingua::Any::Numbers;
       sub {
         return Lingua::Any::Numbers::to_ordinal($_[0], $lang);
       }
     });

  my $without_conjunctions_func
    = $self->{'without_conjunctions_func'}
      = ($without_conjunctions && defined $conjunctions_word
         ? do {
           $conjunctions_word = lc($conjunctions_word);
           sub { $_[0] =~ s/\b\Q$conjunctions_word\E\b// }
         }
         : \&_conjunctions_noop);  # no change to strings

  my $initial_string = delete $self->{'initial_string'};
  my $letter = $self->{'letter'};

  if (! defined $initial_string) {
    if (! $letter) {
      # default 'T' for en or 'E' for fr
      $letter = $default_letter{$lang};
    }
    if (! defined ($initial_string = $default_initial_string{$lang})) {
      croak 'No default initial_string for language \'',$lang,'\'';
    }
    $initial_string = $letter . $initial_string;
  }

  &$unaccent ($initial_string);
  $initial_string = lc ($initial_string);

  &$without_conjunctions_func ($initial_string);
  $initial_string =~ s/(\W|_)+//g;  # strip non alphas
  ### initial: $initial_string

  if (! defined $letter) {
    if (defined $initial_string) {
      # initial_string but no letter, take letter as first alphabetical
      $letter = substr($initial_string,0,1);
    } else {
    }
  }

  unless (length($letter)) {
    # empty letter string no good as will match endlessly, change to a space
    # which will never match
    $letter = ' ';
  }
  $self->{'letter'} = $letter = lc($letter);

  # my $upto = 1;
  push @ret,
    grep {(substr($initial_string,$_-1,1) eq $letter) ^ $self->{'lying'}}
      1 .. (1 + length($initial_string)-1);
  $self->{'upto'} = 1 + length($initial_string);
  ### initial: $self
  return $self;
}

sub _conjunctions_noop {
}

sub _fr_ordinal {
  my $str = Lingua::FR::Numbers::ordinate_to_fr($_[0]);
  # Feminine "E est la premiere lettre ..."
  if ($str eq 'premier') { $str = 'premiere'; }
  return $str;
}


sub next {
  my ($self) = @_;
  my $ret = $self->{'ret'};
  for (;;) {
    if (my $n = shift @$ret) {
      push @{$self->{'queue'}}, $n;
      return $n;
    }

    my $k = shift @{$self->{'queue'}}
      || return;  # end of sequence

    my $str = &{$self->{'ordinal_func'}}($k);
    ### orig str: $str
    &{$self->{'without_conjunctions_func'}}($str);
    &$unaccent ($str);
    $str = lc ($str);

    # could be s/[[:punct:][:space:]]+//g, but [::] new in 5.005 or something
    $str =~ s/(\W|_)+//g;  # strip non alphas
    ### munged str: $str

    my $upto = $self->{'upto'};
    my $letter = $self->{'letter'};
    push @$ret,
      grep {(substr($str,$_-$upto,1) eq $letter) ^ $self->{'lying'}}
        $upto .. ($upto + length($str)-1);

    $self->{'upto'} += length($str);
    ### now upto: $self->{'upto'}
    ### ret: $ret
    ### queue: $self->{'queue'}
  }
}

1;
__END__