File Coverage

blib/lib/String/Markov.pm

Criterion	Covered	Total	%
statement	96	96	100.0
branch	24	24	100.0
condition	11	12	91.6
subroutine	13	13	100.0
pod	4	8	50.0
total	148	153	96.7

package String::Markov;

# ABSTRACT: A Moo-based, text-oriented Markov Chain module

our $VERSION = 0.009;

use 5.010;
use Moo;
use namespace::autoclean;

use Unicode::Normalize qw(normalize);
use List::Util qw(sum);

has normalize => (is => 'rw', default => sub { 'C' });
has do_chomp  => (is => 'rw', default => sub { 1 });
has null      => (is => 'ro', default => sub { "\0" });
has stable    => (is => 'ro', default => sub { 1 });
has order     => (is => 'ro', isa => sub {
	die "Need an integer greater than zero" if !$_[0] || $_[0] =~ /\D/;
}, default => sub { 2 });

has ['split_sep','join_sep'] => (
	is => 'rw',
	default => sub { undef }
);

has ['transition_count','row_sum'] => (
	is => 'ro',
	isa => sub { die "Need a hash ref" if ref $_[0] ne 'HASH'; },
	default => sub { {} }
);

around BUILDARGS => sub {
	my ($orig, $class, @arg) = @_;
	my %ahash;

	%ahash = @arg == 1 ? %{$arg[0]} : @arg;

	my $sep = delete $ahash{sep} // '';
	die "ERR: sep argument must be scalar; did you mean to set split_sep instead?" if ref $sep;
	$ahash{split_sep} //= $sep;
	$ahash{join_sep}  //= $sep;

	return $class->$orig(\%ahash);
};

sub join_prob {
	my ($self, $orig_prob) = @_;
	my %p;

	@p{@{$orig_prob->[0]}} = @{$orig_prob->[1]};

	return \%p;
}

sub split_prob {
	my ($self, $orig_prob) = @_;

	if ($self->stable) {
		my @k = sort keys %$orig_prob;
		return [
			\@k,
			[@{$orig_prob}{@k}],
		];
	} else {
		return [
			[keys %$orig_prob],
			[values %$orig_prob],
		];
	}
}

sub split_all_prob {
	my $self = shift;
	my $tc = $self->transition_count;
	my $nt = {};

	while (my ($state, $prob) = each %$tc) {
		$nt->{$state} = $self->split_prob($prob);
	}

	%$tc = %$nt;
}

sub split_line {
	my ($self, $sample) = @_;
	if (my $norm = $self->normalize) {
		$sample = normalize($norm, $sample);
	}
	return split($self->split_sep, $sample);
}

sub add_sample {
	my ($self, $sample) = @_;
	my $n     = $self->order;
	my $null  = $self->null;

	my $sref  = ref $sample;
	my @nms = ($null,) x $n;

	if ($sref eq 'ARRAY') {
		push @nms, @$sample;
	} elsif (!$sref) {
		die 'ERR: missing split separator,' if !defined $self->split_sep;
		push @nms, $self->split_line($sample);
	} else {
		die "ERR: bad sample type $sref";
	}

	push @nms, $null;

	my $sep   = $self->join_sep // '';
	my $count = $self->transition_count;
	my $sum   = $self->row_sum;
	for my $i (0 .. ($#nms - $n)) {
		my $cur = join($sep, @nms[$i .. ($i + $n - 1)]);
		my $nxt = $nms[$i + $n];
		my $prob = $count->{$cur};
		if ($prob && ref $prob ne 'HASH') {
			$count->{$cur} = $self->join_prob($prob);
		}
		++$count->{$cur}{$nxt};
		++$sum->{$cur};
	}

	return $self;
}

sub add_files {
	my ($self, @files) = @_;
	my $do_chomp = $self->do_chomp;

	local @ARGV = @files;
	while(my $sample = <>) {
		chomp $sample if $do_chomp;
		$self->add_sample($sample);
	}

	$self->split_all_prob();

	return $self;
}

sub sample_next_state {
	my ($self, @cur_state) = @_;
	die "ERR: wrong amount of state" if @cur_state != $self->order;

	my $count = $self->transition_count;
	my $sum   = $self->row_sum;

	my $cur = join($self->join_sep // '', @cur_state);
	my $thresh = $sum->{$cur};
	return undef if !$thresh;

	$thresh *= rand();

	my $prob = $count->{$cur};
	if (ref $prob ne 'ARRAY') {
		$prob = $self->split_prob($prob);
		$count->{$cur} = $prob;
	}

	my $s = 0;
	my $i = 0;
	my ($k, $v) = @{$prob};
	do {
		$s += $v->[$i];
	} while ($thresh > $s && ++$i);
	return $k->[$i];
}

sub generate_sample {
	my ($self) = @_;

	my $null = $self->null;
	my $n  = $self->order;
	my $sep = $self->join_sep // '';
	my @nm = ($null,) x $n;

	do {
		push @nm, $self->sample_next_state(@nm[-$n .. -1]);
	} while ($nm[-1] ne $null);

	@nm = @nm[$n .. ($#nm-1)];

	return wantarray ?
		@nm :
		defined $self->join_sep ?
			join($sep, @nm) :
			\@nm;

}

__PACKAGE__->meta->make_immutable;

1;

__END__