File Coverage

blib/lib/Compress/LZW/Progressive/Dict.pm

Criterion	Covered	Total	%
statement	109	131	83.2
branch	32	46	69.5
condition	20	27	74.0
subroutine	23	27	85.1
pod	0	15	0.0
total	184	246	74.8

package Compress::LZW::Progressive::Dict;

use strict;
use warnings;
use bytes;

our $VERSION = '0.1';

sub new {
	my ($class) = @_;

	my %self = (
		tree => Compress::LZW::Progressive::Dict::Tree->new(),
	#	hash => {},
		array => [],
		next_code => 0,
		reuse_codes => [],
		codes_used => [],
		code_counter => 0,
	);

	my $self = bless \%self, $class;

	$self->add($_) foreach map { chr } 0..255;

	return $self;
}

## Adding and deleting from the dict

sub add {
	my ($self, $phrase, $code) = @_;

	return 0 unless defined $phrase;
	return 1 if $self->code($phrase); #defined $self->{hash}{$phrase};

	if (! defined $code) {
		$code = int @{ $self->{reuse_codes} } ? shift @{ $self->{reuse_codes} } : $self->{next_code}++;
	}

	my @chars = split //, $phrase;
	$self->{tree}->add(\@chars, $code);

#	$self->{hash}{$phrase} = $code;
	$self->{array}[$code] = $phrase;

	return $code;
}

sub delete {
	my ($self, $phrase, $code) = @_;

	return 0 unless defined $phrase && defined $code;
#	return 0 unless defined $self->{hash}{$phrase};
	return 0 unless defined $self->{array}[$code];

	my @chars = split //, $phrase;
	$self->{tree}->delete(\@chars);

#	delete $self->{hash}{$phrase};
	$self->{array}[$code] = undef;

	$self->{codes_used}[$code] = undef;

	push @{ $self->{reuse_codes} }, $code;

	return 1;
}

sub delete_phrase {
	my ($self, $phrase) = @_;

	my $code = $self->{hash}{$phrase};
	return $self->delete($phrase, $code);
}

sub delete_code {
	my ($self, $code) = @_;

	my $phrase = $self->{array}[$code];
	return $self->delete($phrase, $code);
}

sub delete_codes {
	my ($self, @codes) = @_;
	while (my $code = shift @codes) {
		my $phrase = $self->{array}[$code];
		return 0 unless $self->delete($phrase, $code);
	}
	return 1;
}

## Accessors

sub code_matching_str {
	my ($self, $str) = @_;
	return $self->code_matching_array([ split //, $str ]);
}
sub code_matching_array {
	my ($self, $arr) = @_;
	return $self->{tree}->search(0, $arr);
}

sub increment_code_usage_count {
	my ($self, $code) = @_;
	$self->{codes_used}[$code] = $self->{code_counter}++;
	return undef;
}

sub next_code {
	return $_[0]->{next_code};
}

sub codes_used {
	my $self = shift;
	return $self->{next_code} - int @{ $self->{reuse_codes} };
}

# Given a count, return that many codes which haven't been used lately

sub least_used_codes {
	my ($self, $count) = @_;

	my $codes_used = $self->{codes_used};
	my @delete =
		sort { $codes_used->[$a] <=> $codes_used->[$b] }
		grep { defined $codes_used->[$_] }
		256..$#{ $codes_used };

	$count = int(@delete) if int(@delete) < $count;

#	print join ', ', map { "$_ => $codes_used->[$_]" } @delete[0..($count-1)];
#	print "\n";

	return @delete[0..($count - 1)];
}

sub phrase {
	my ($self, $code) = @_;

	return $self->{array}[$code];
}

sub code {
	my ($self, $phrase) = @_;

#	return $self->{hash}{$phrase};
	my $code = $self->code_matching_str($phrase);
	if ($code && $self->phrase($code) eq $phrase) {
		return $code;
	}
	else {
		return undef;
	}
}

sub dump {
	my ($self) = shift;

#	print "Phrase Hash\n";
#	foreach my $phrase (keys %{ $self->{hash} }) {
#		printf "%6d : %20s\n", $self->{hash}{$phrase}, $phrase;
#	}

	print "Code Array\n";
	foreach my $code (0..$#{ $self->{array} }) {
		next unless defined $self->{array}[$code];
		printf "%6d : %20s (%8d)\n", $code, $self->{array}[$code], $self->{codes_used}[$code];
	}

	print "Next Code: ".$self->{next_code}."\n";
	print "Reuse Codes:\n" . join(", ", @{ $self->{reuse_codes} }) . "\n";

#	return;
	print "Tree\n";
	$self->{tree}->print(0);
}

package Compress::LZW::Progressive::Dict::Tree;

use strict;
use warnings;
no warnings 'recursion';
use bytes;

our $VERSION = '0.11';

sub new {
	my ($class) = @_;
	$class = ref $class if ref $class;

	my @self = (
		{},
		undef,
	);

	return bless \@self, $class;
}

# Given an array of characters and a code, create children for each character and finally
# set the value of the final node

sub add {
	my ($self, $chars, $code) = @_;

	my $char = shift @$chars;
	if (defined $char) {
		$char = 'null' if ord($char) == 0;
		$self->[0]{$char} ||= $self->new();
		$self->[0]{$char}->add($chars, $code);
	}
	else {
		$self->[1] = $code;
	}
}

# Given an array and an index on that array, recursively delete all nodes from that point on and
# backwards while such nodes have no value

sub delete {
	my ($self, $chars) = @_;

	my $char = shift @$chars;
	$char = 'null' if defined $char && ord($char) == 0;

	# Descend to the last char
	if (defined $char && (my $child = $self->[0]{$char})) {
		if ($child->delete($chars)) {
			delete $self->[0]{$char};
		}
	}
	elsif (! defined $char) {
		$self->[1] = undef;
	}

	# Now, delete backwards unless I have children or a value
	return (%{ $self->[0] } || defined $self->[1]) ? 0 : 1;
}

# Given an array and an index on that array, recursively search for a defined node that matches
# as many as possible of the characters

sub search {
	my ($self, $index, $arr) = @_;

	my $found_desc;

	my $char = $arr->[$index];
	$char = 'null' if defined $char && ord($char) == 0;

	if (defined $char && (my $child = $self->[0]{$char})) {
		$found_desc = $child->search($index + 1, $arr);
		return $found_desc if defined $found_desc;
	}

	if (! defined $found_desc && defined $self->[1]) {
		return $self->[1];
	}

	return undef;
}

sub print {
	my ($self, $level) = @_;

	print ' ' . (' 'x$level) . ' => ' . $self->[1] . "\n" if defined $self->[1];
	foreach my $char (sort keys %{ $self->[0] }) {
		print ' ' . (' 'x$level) . $char . "\n";
		$self->[0]{$char}->print($level + 1);
	}
}

1;