view release on metacpan or  search on metacpan

lib/Acme/ID/CompanyName.pm  view on Meta::CPAN

            schema => ['bool*'],
            default => 1,
        },
        # XXX option to use some more specific words & suffixes/prefixes
        desired_initials => {
            schema => ['str*', min_len=>1, match=>qr/\A[A-Za-z]+\z/],
        },
    },
    result_naked => 1,
    examples => [
        {
            summary => 'Generate five random PT names',
            argv => [qw/5/],
            test => 0,
        },
        {
            summary => 'Generate three PT names with desired initials "ACME"',
            argv => [qw/-n3 --desired-initials ACME/],
            test => 0,
        },
    ],
};
sub gen_generic_ind_company_names {
    my %args = @_;

    my $type = $args{type} // 'PT';
    my $num_names = $args{num_names} // 1;
    my $num_words = $args{num_words} // 3;
    my $desired_initials = lc($args{desired_initials} // "");
    my $add_prefixes = $args{add_prefixes} // 1;
    my $add_suffixes = $args{add_suffixes} // 1;

    $num_words = length($desired_initials)
        if $num_words < length($desired_initials);

    my @res;
    my $name_tries = 0;
    for my $i (1..$num_names) {
        die "Can't produce that many unique company names"
            if ++$name_tries > 5*$num_names;

        my @words;
        my $word_tries = 0;
        my $has_added_prefix;
        my $has_added_suffix;
      WORD:
        for my $j (1..$num_words) {
            die "Can't produce a company name that satisfies requirements"
                if ++$word_tries > 1000;

            my $will_add_prefix =
                !$add_prefixes ? 0 :
                $has_added_prefix ? 0 :
                rand()*$num_words*6 > 1 ? 0 : 1;

            my $word;
            my $desired_initial = length($desired_initials) >= $j ?
                substr($desired_initials, $j-1, 1) : undef;

            if (!$will_add_prefix && $desired_initial) {
                die "There are no words that start with '$desired_initial'"
                    unless $Per_Letter_Words{$desired_initial};
                $word = $Per_Letter_Words{$desired_initial}->[
                    @{ $Per_Letter_Words{$desired_initial} } * rand()
                ];
            } else {
                $word = $Words[@Words * rand()];
            }
            next if $word =~ /^#/;

          ADD_PREFIX:
            {
                last unless $will_add_prefix;
                my $prefix = $Prefixes[@Prefixes * rand()];
                redo WORD if $desired_initial && substr($prefix, 0, 1) ne $desired_initial;

                # avoid prefixing e.g. 'indo-' to 'indonesia'
                last if $word =~ /^\Q$prefix\E/;

                # amalgamate letter
                if (substr($prefix, -1, 1) eq substr($word, 0, 1)) {
                    $word =~ s/^.//;
                }

                $word = "$prefix$word";
                $has_added_prefix++;
            }

          ADD_SUFFIX:
            {
                last unless $add_suffixes;
                last unless !$has_added_suffix && rand()*$num_words*3 < 1;
                my $suffix = $Suffixes[@Suffixes * rand()];

                # avoid suffixing e.g. '-tama' to 'pertama'
                last if $word =~ /\Q$suffix\E$/;

                # amalgamate letter
                if (substr($word, -1, 1) eq substr($suffix, 0, 1)) {
                    $word =~ s/.$//;
                }

                $word = "$word$suffix";
                $has_added_suffix++;
            }

            # avoid duplicate words
            redo if grep { $word eq $_ } @words;

            push @words, ucfirst $word;
        }
        my $name = join(" ", $type, @words);

        # avoid duplicate name
        redo if grep { $name eq $_ } @res;

        push @res, $name;

    }
    return \@res;
}