File Coverage

blib/lib/Acme/Lingua/ZH/Remix.pm

Criterion	Covered	Total	%
statement	116	118	98.3
branch	16	20	80.0
condition	24	34	70.5
subroutine	14	14	100.0
pod	3	7	42.8
total	173	193	89.6

package Acme::Lingua::ZH::Remix;
use v5.10;
our $VERSION = "0.99";

=pod

=encoding utf8

=head1 NAME

Acme::Lingua::ZH::Remix - The Chinese sentence generator.

=head1 SYNOPSIS

    use Acme::Lingua::ZH::Remix;

    my $x = Acme::Lingua::ZH::Remix->new;

    # Generate a random sentance
    say $x->random_sentence;

=head1 DESCRIPTION

Because lipsum is not funny enough, that is the reason to write this
module.

This module is a L-based, with C method being the constructor.

The C method returns a string of one sentence
of Chinese like:

    真是完全失敗，孩子！怎麼不動了呢？

By default, it uses small corpus data from Project Gutenberg. The generated
sentences are remixes of the corpus.

You can feed you own corpus data to the `feed` method:

    my $x = Acme::Lingua::ZH::Remix->new;
    $x->feed($my_corpus);

    # Say something based on $my_corpus
    say $x->random_santence;

The corpus should use full-width punctuation characters.

=cut

use utf8;
use Moo;
use Types::Standard qw(HashRef Int);
use List::MoreUtils qw(uniq);
use Hash::Merge qw(merge);

has phrases => (is => "rw", isa => HashRef, lazy => 1, builder => "_build_phrases");

sub _build_phrases {
    my $self   = shift;
    local $/   = undef;
    my $corpus = ;
    my %phrase;
    my @phrases = $self->split_corpus($corpus);
    for (@phrases) {
        my $p = substr($_, -1);
        push @{$phrase{$p} ||=[]}, \$_;
    }
    return \%phrase;
}

sub phrase_count {
    my $self = shift;
    my %p = %{$self->phrases};
    my $count = 0;
    for(keys %p) {
        $count += scalar @{$p{$_}};
    }
    return $count;
}

sub random(@) { $_[ rand @_ ] }

=head1 METHODS

=head2 split_corpus($corpus_text)

Takes a scalar, returns an list.

This is an utility method that does not change the internal state of
the topic object.

=cut

sub split_corpus {
    my ($self, $corpus) = @_;
    return () unless $corpus;

    $corpus =~ s/^\#.*$//gm;

    # Squeeze whitespaces
    $corpus =~ s/(\s|　)*//gs;

    # Ignore certain punctuations
    $corpus =~ s/(——|──)//gs;

    my @xc = split /(?:（(.+?)）|：?「(.+?)」|〔(.+?)〕|“(.+?)”)/, $corpus;
    my @phrases = uniq sort grep /.(，|。|？|！)$/,
        map {
            my @x = split /(，|。|？|！)/, $_;
            my @r = ();
            while (@x) {
                my $s = shift @x;
                my $p = shift @x or next;

                $s =~ s/^(，|。|？|！|\s)+//;
                push @r, "$s$p";
            }
            @r;
        } map {
            s/^\s+//;
            s/\s+$//;
            s/^(.+?) //;
            $_;
        } grep { $_ } @xc;

    return @phrases;
}

=head2 feed($corpus_text)

Instance method. Takes a scalar, return the topic object.

Merge C<$corpus_text> into the internal phrases corpus of the object.

=cut

sub feed {
    my $self   = shift;
    my $corpus = shift;

    my %phrase;
    my @phrases = $self->split_corpus($corpus);

    for (@phrases) {
        my $p = substr($_, -1);
        push @{$phrase{$p} ||=[]}, \$_;
    }

    $self->phrases(merge($self->phrases, \%phrase));
    return $self;
}

sub phrase_ratio {
    my $self = shift;
    my $type = shift;
    my $phrases = $self->phrases->{$type}||=[];
    my $count   = $self->phrase_count;
    return 0 if $count == 0;
    return @{$phrases} / $count;
}

sub random_phrase {
    my $self = shift;
    my $type = shift;

    return ${ random(@{ $self->phrases->{$type}||=[] }) || \'' };
}

=head2 random_sentence( min => $min, max => $max )

Instance method. Optionally takes "min" or "max" parameter as the constraint of
sentence length (number of characters).

Both min and max values are required to be integers greater or equal to
zero. The value of max should be greater then the value of min. If any of these
values are invalidate, it is treated as if they are not passed.

The default values of min, max are 0 and 140, respectively.

The implementation random algorthm based, thus it needs indefinite time to
generate the result. If it takes more then 1000 iterations, it aborts and return
the results anyway, regardless the length constraint. This can happen when the
lengths of phrases from corpus do no adds up to a value within the given range.

The returned scalar is the generate sentence string of wide characters. (Which
makes Encode::is_utf8 return true.)

=cut

sub random_sentence {
    my ($self, %options) = @_;

    for my $p (qw(min max)) {
        my $x = $options{$p};
        unless (defined($x) && int($x) eq $x && $x >= 0) {
            delete $options{$p}
        }
    }

    if (defined($options{max}) && defined($options{min}) && $options{max} < $options{min}) {
        delete $options{max};
        delete $options{min};
    }

    $options{min} ||= 0;
    $options{max} ||= 140;

    my $str = "";
    my @phrases;

    my $ending = $self->random_phrase(random(qw/。 ！ ？/)) || "…";

    while ( length($ending) > $options{max} ) {
        $ending = $self->random_phrase(random(qw/。 ！ ？/)) || "…";
    }

    unshift @phrases, $ending;

    my $l = length($ending);

    my $iterations = 0;
    my $max_iterations = 1000;
    my $average = ($options{min} + $options{max}) / 2;
    my $desired = int(rand($options{max} - $options{min}) + $options{min}) || $average || $options{max};

    while ($iterations++ < $max_iterations) {
        my $x;
        do {
            $x = random('，', '」', '）', '/')
        } while ($self->phrase_ratio($x) == 0);

        my $p = $self->random_phrase($x);

         if ($l + length($p) < $options{max}) {
            unshift @phrases, $p;
            $l += length($p);
        }

        my $r = abs(1 - $l/$desired);
        last if $r < 0.1;
        last if $r < 0.2 && $iterations >= $max_iterations/2;
    }

    $str = join "", @phrases;
    $str =~ s/，$//;
    $str =~ s/^「(.+)」$/$1/;

    if (rand > 0.5) {
        $str =~ s/(，)……/$1/gs;
    } else {
        $str =~ s/，(……)/$1/gs;
    }

    return $str;
}

1;

=head1 AUTHOR

Kang-min Liu

=head1 COPYRIGHT

Copyright 2010- by Kang-min Liu,

This program is free software; you can redistribute it a nd/or modify
it under the same terms as Perl itself.

See L

=cut

# Data coming from Wikisource
# http://zh.wikisource.org/zh-hant/%E5%BF%98%E4%B8%8D%E4%BA%86%E7%9A%84%E9%81%8E%E5%B9%B4

__DATA__