package Text::Document;

$Text::Document::VERSION = '1.05';

use strict;

use v5.6.0;

our @FIELDS = qw( lowercase );
our $COMPRESS_AVAILABLE;
our @KEYS_FOR_NEW = qw( compress lowercase );

BEGIN {
	eval "use Compress::Zlib;";
	if( $@ ){
		$COMPRESS_AVAILABLE = undef;
	} else {
		$COMPRESS_AVAILABLE = 1;
	}
}


sub new
{
	my $class = shift;
	my %self = @_;
	my $self = {
		lowercase	=> 1,
		compress	=> 1,
		terms		=> {},
	};
	foreach my $k ( @KEYS_FOR_NEW ){
		defined( $self{$k} )
			and ($self->{$k} = $self{$k});
	}

	bless $self, $class;
	return $self;
}

sub AddContent
{
	my $self = shift;
	my ($text) = @_;
# clear frequency cache
	$self->{freqs} and delete $self->{freqs};

# parse text fragment
	my @terms = $self->ScanV( $text );

# update word count
	foreach my $w (@terms){
		$self->{terms}->{$w} ++;
	}
	undef $self->{WeightedEuclideanNorm};
	undef $self->{EuclideanNorm};
	return scalar @terms;
}

# number of occurrences of a given term
sub Occurrences
{
	my $self = shift;
	my ($term) = @_;

	return $self->{terms}->{$term};
}

sub ScanV
{
	my $self =  shift;
	my ($text) = @_;
	my @words = split( /[^a-zA-Z0-9]+/, $text );
	@words = grep( /.+/, @words );
	if( $self->{lowercase} ){
		return map( lc($_), @words );
	} else {
		return @words;
	}
}

sub KeywordFrequency
{
	my $self = shift;

	return $self->{freqs} if $self->{freqs};

# all the distinct terms in the doc
	my @terms = $self->Terms();
# total number of terms
	my $sum = 0;
	foreach my $t (@terms) { $sum += $self->{terms}->{$t}; }
# if zero, frequency is not defined
	($sum > 0) or return undef;
# list of [term,frequency] pairs
	my @freqs = map( [$_, $self->{terms}->{$_}/$sum ] , @terms );
# sort by ascending frequency
	@freqs = sort { $a->[1] <=> $b->[1] } @freqs;

# return reference to result
	return $self->{freqs} = \@freqs;
}

# all distinct term names
sub Terms
{
	my $self = shift;
	return keys %{$self->{terms}};
}

# number of common terms divided by total number of terms
sub CommonTermsRatio
{
	my $self = shift;
	my ($other) = @_;
	my @terms = $self->Terms();
	my %terms;
	@terms{@terms} = 1 .. @terms;
	my @oTerms = $other->Terms();
	my (%union);
	@union{@terms} = 1 .. @terms;
	@union{@oTerms} = 1 .. @oTerms;
	my @intersection = map( ( $terms{$_} ? 1 : () ), @oTerms );
	my $unionCardinality = scalar( keys %union );
	($unionCardinality > 0) or return undef;
	return scalar(@intersection) /  $unionCardinality;
}

sub PureASCII
{
	my $self = shift;
	$self->{compress} = 1;
}

sub WriteToString
{
	my $self = shift;

	my $block = join( ',', %{$self->{terms}} );
	my $compressed = undef;
	if( $COMPRESS_AVAILABLE && $self->{compress} ){
		$block = Compress::Zlib::compress( $block );
#		$block = compress( $block );
		$compressed = 1;
	}
	my $header =
		'p='
		. __PACKAGE__
		. ' v='
		. $Text::Document::VERSION
		. ' l='
		. length( $block )
		. ' compress='
		. ($compressed?'1':'0')
		. ' '
		. join( ' ', map( "$_=$self->{$_}", @FIELDS))
		. "\n";

	my $str = $header . $block;

# add 8-char hex-encoded 4-byte checksum at the end of data
	return $str . sprintf( '%08x', unpack( '%32C*', $str ) );
}

sub NewFromString
{
	my ($str) = @_;

	my $self = {};

# verify checksum
# try to be compatible with version 1.03
	my $stored_checksum = unpack( 'N', substr( $str, -4 ));
	my $data_payload = substr( $str, 0, -4 );
	my $computed_checksum = unpack( '%32C*', $data_payload );

	if( $stored_checksum != $computed_checksum ){
		$stored_checksum = hex( substr( $str, -8 ));
		$data_payload = substr( $str, 0, -8 );
		$computed_checksum = unpack( '%32C*', $data_payload );
	}

	if( $stored_checksum != $computed_checksum ){
		die( __PACKAGE__ . '::NewFromString : '
			. 'checksum test failed '
			. $stored_checksum
			. ' != '
			. $computed_checksum
		);
	}

# split data in header and block
	my ($header,$block) = split( /\n/, $data_payload, 2 );

# parse header line
	my %header = split( /[ 	=]+/, $header );

# check that the reading package is the same as the one that wrote
	if( $header{p} ne __PACKAGE__ ){
		die( __PACKAGE__ . '::NewFromString : '
			. "file was not written by "
			. __PACKAGE__
		);
	}

# version must be identical
	if( $header{v} > $Text::Document::VERSION ){
		die( __PACKAGE__ . '::NewFromString : '
			. "Current version is $Text::Document::VERSION"
			. " and the file version is $header{v}"
		);
	}

# size of block must match
	if( $header{l} != length( $block ) ){
		die( __PACKAGE__ . '::NewFromString : '
			. "data size is "
			. length( $block )
			. "instead of $header{l} "
		);
	}

# compressed?
	if( $header{compress} and not($COMPRESS_AVAILABLE) ){
		die( __PACKAGE__ . '::NewFromString : '
			. 'header indicates that data is compressed, '
			. 'but Compress::Zlib is not available'
		);
	}

	if( $header{compress} ){
		$block = Compress::Zlib::uncompress( $block );
#		$block = uncompress( $block );
	}
	
	
	@{$self}{@FIELDS} = @header{ @FIELDS };

# retrieve terms and recurrence count
	%{$self->{terms}} = split( /,/, $block );

	bless $self, $header{p};

	return $self;
}

sub JaccardSimilarity
{
	my $self = shift;
	my ($e) = @_;

	my @inter = map(
		( $self->{terms}->{$_} ?  $_ : () ),
		keys %{$e->{terms}}
	);
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	if( (my $unionSize = scalar keys %union) > 0 ){
		return scalar(@inter) / $unionSize;
	} else {
		return undef;
	}
}

sub CosineSimilarity
{
	my $self = shift;
	my ($e) = @_;

	my ($Dv,$Ev) = ($self->{terms}, $e->{terms});
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	my $dotProduct = 0.0;
	map( $dotProduct += 
		(defined($Dv->{$_}) ? $Dv->{$_} : 0.0)
		* (defined($Ev->{$_}) ? $Ev->{$_} : 0.0 ),
		keys %union
	);

	my $nD = $self->EuclideanNorm();
	my $nE = $e->EuclideanNorm();

	if( ($nD==0) || ($nE==0) ){
		return undef;
	} else {
		return $dotProduct / $nD / $nE;
	}
}

sub EuclideanNorm
{
	my $self = shift;
	defined( $self->{EuclideanNorm} ) and return $self->{EuclideanNorm};
	my $sum = 0.0;
	map( $sum += $_*$_, values %{$self->{terms}} );
	return ($self->{EuclideanNorm} = sqrt( $sum ));
}

# this is rather rough
sub WeightedCosineSimilarity
{
	my $self = shift;
	my ($e,$weightFunction,$rock) = @_;

	my ($Dv,$Ev) = ($self->{terms}, $e->{terms});

# compute union
	my %union =  %{$self->{terms}};
	my @keyse = keys %{$e->{terms}};
	@union{@keyse} = @keyse;
	my @allkeys = keys %union;

# weighted D
	my @Dw = map(( defined( $Dv->{$_} )?
		&{$weightFunction}( $rock, $_ )*$Dv->{$_} : 0.0 ),
		@allkeys
	);

# weighted E
	my @Ew = map(( defined( $Ev->{$_} )?
		&{$weightFunction}( $rock, $_ )*$Ev->{$_} : 0.0 ),
		@allkeys
	);

# dot product of D and E
	my $dotProduct = 0.0;
	map( $dotProduct += $Dw[$_] * $Ew[$_] , 0..$#Dw );

# norm of D
	my $nD = 0.0;
	map( $nD += $Dw[$_] * $Dw[$_] , 0..$#Dw );
	$nD = sqrt( $nD );

# norm of E
	my $nE = 0.0;
	map( $nE += $Ew[$_] * $Ew[$_] , 0..$#Ew );
	$nE = sqrt( $nE );

# dot product scaled by norm
	if( ($nD==0) || ($nE==0) ){
		return undef;
	} else {
		return $dotProduct / $nD / $nE;
	}
}

1;


__END__

=head1 NAME

  Text::Document - a text document subject to statistical analysis

=head1 SYNOPSIS

  my $t = Text::Document->new();
  $t->AddContent( 'foo bar baz' );
  $t->AddContent( 'foo barbaz; ' );

  my @freqList = $t->KeywordFrequency();
  my $u = Text::Document->new();
  ...
  my $sj = $t->JaccardSimilarity( $u );
  my $sc = $t->CosineSimilarity( $u );
  my $wsc = $t->WeightedCosineSimilarity( $u, \&MyWeight, $rock );


=head1 DESCRIPTION

C<Text::Document> allows to perform simple
Information-Retrieval-oriented statistics on pure-text documents.

Text can be added in chunks, so that the document may be
incrementally built, for instance by a class like
C<HTML::Parser>.

A simple algorithm splits the text into terms; the algorithm
may be redefined by subclassing and redefining C<ScanV>.

The C<KeywordFrequency> function computes term frequency
over the whole document.

=head1 FORESEEN REUSE

The package may be {re}used either by simple instantiation,
or by subclassing (defining a descendant package).  In the
latter case the methods which are foreseen to be redefined are
those ending with a C<V> suffix.  Redefining other methods
will require greater attention.

=head1 CLASS METHODS

=head2 new

The creator method.  The optional arguments are in the
I<(key,value)> form and allow to specify whether
all keywords are trasformed to lowercase (default) and
whether the string representation (C<WriteToString>)
will be compressed (default).

  my $d = Text::Document->new();
  my $dNotCompressed = Text::Document( compressed => 0 );
  my $dPreserveCase = Text::Document( lowercase => 0 );

=head2 NewFromString

Take a string written by C<WriteToString> (see below)
and create a new C<Text::Document> with the same contents;
call C<die> whenever the restore is impossible or ill-advised,
for instance when the current version of the package is different
from the original one, or the compression library in unavailable.

  my $b = Text::Document::NewFromString( $str );

The return value is a blessed reference; put in another way,
this is an alternative contructor.

The string should have been written by C<WriteToString>; 
you may of course tweak the string contents, but
at this point you're entirely on you own.

=head1 INSTANCE METHODS

=head2 AddContent

Used as

  $d->AddContent( 'foo bar baz foo9' );
  $d->AddContent( 'mary had a little lamb' );

Successive calls accumulate content; there is currently no way
of resetting the content to zero.

=head2 Terms

Returns a list of all distinct terms in the document, in no
particular order.

=head2 Occurrences

Returns the number of occurrences of a given term.

  $d->AddContent( 'foo baz bar foo foo');
  my $n = $d->Occurrences( 'foo' ); # now $n is 3

=head2 ScanV

Scan a string and return a list of terms.

Called internally as:

  my @terms = $self->ScanV( $text );

=head2 KeywordFrequency

Returns a reference list of pairs I<[term,frequency]>, sorted by
ascending frequency.

  my $listRef = $d->KeywordFrequency();
  foreach my $pair (@{$listRef}){
  	my ($term,$frequency) = @{$pair};
	...
  }

Terms in the document are sampled and their frequencies of occurrency
are sorted in ascending order;
finally, the list is returned to the user.

=head2 WriteToString

Convert the document (actually, some parameters
and the term counters) into a string which can be saved and
later restored with C<NewFromString>.

  my $str = $d->WriteToString();

The string begins with a header which encodes the
originating package, its version, the parameters
of the current instance.

Whenever possible, C<Compress::Zlib> is used in order to
compress the bit vector in the most efficient way.
On systems without C<Compress::Zlib>, the bit string is
saved uncompressed.

This method is influenced by C<PureASCII>.

=head2 PureASCII

Ensure that the representation in WriteToString does not contain
characters with ASCII code >= 128. Needed to easily include document
representations into textual databases (e.g. XML files).

=head2 JaccardSimilarity

Compute the Jaccard measure of document similarity, which is defined
as follows: given two documents I<D> and I<E>, let I<Ds> and I<Es> be the set
of terms occurring in I<D> and  I<E>, respectively. Define I<S> as the
intersection of I<Ds> and I<Es>, and I<T> as their union. Then
the Jaccerd  similarity is the the number of  elements
of I<S> divided by the number of elements of I<T>.

It is called as follows:

  my $sim = $d->JaccardSimilarity( $e );

If neither document has any terms the result is undef (a rare evenience).
Otherwise the similarity is a real number between 0.0 (no terms in common)
and 1.0 (all terms in common).

=head2 CosineSimilarity

Compute the cosine similarity between two documents I<D> and
I<E>.

Let I<Ds> and I<Es> be the set
of terms occurring in I<D> and  I<E>, respectively. Define I<T> as the
union of I<Ds> and I<Es>, and let I<ti> be the I<i>-th element of I<T>.

Then the term vectors of I<D> and  I<E> are

  Dv = (nD(t1), nD(t2), ..., nD(tN))
  Ev = (nE(t1), nE(t2), ..., nE(tN))

where nD(ti) is the  number of occurrences of term ti in I<D>,
and nE(ti) the same for I<E>.

Now we are at last ready to define the cosine similarity I<CS>:

  CS = (Dv,Ev) / (Norm(Dv)*Norm(Ev))

Here (... , ...) is the scalar product and Norm is the Euclidean
norm (square root of the sum of squares).

C<CosineSimilarity> is called as

   $sim = $d->CosineSimilarity( $e );

It is C<undef> if either I<D> or I<E> have no occurrence of any term.
Otherwise, it is a number between 0.0 and 1.0. Since term occurrences
are always non-negative, the cosine is obviously always non-negative.

=head2 WeightedCosineSimilarity

Compute the weighted cosine similarity between two documents I<D> and
I<E>.

In the setting of C<CosineSimilarity>, the 
term vectors of I<D> and  I<E> are

  Dv = (nD(t1)*w1, nD(t2)*w2, ..., nD(tN)*wN)
  Ev = (nE(t1)*w1, nE(t2)*w2, ..., nE(tN)*wN)

The weights are nonnegative real values; each term has associated
a weight. To achieve generality, weights may be defined
using a function, like:

  my $wcs = $d->WeightedCosineSimilarity(
  	$e,
	\&function,
	$rock
  );

The C<function> will be called as follows:

  my $weight = function( $rock, 'foo' );

C<$rock> is a 'constant' object used for passing a I<context>
to the function.

For instance, a common way of defining weights is the IDF (inverse
document frequency), which is defined in L<Text::DocumentCollection>.
In this context, you can weigh terms with their IDF as
follows:

  $sim = $c->WeightedCosineSimilarity(
  	$d,
	\&Text::DocumentCollection::IDF,
	$collection
  );

C<WeightedCosineSimilarity> will call

  $collection->IDF( 'foo' );

which is what we expect.

Actually, we should return the square root of IDF, but this
detail is not necessary here.

=head1 AUTHORS

  spinellia@acm.org (Andrea Spinelli)
  walter@humans.net (Walter Vannini)

=head1 HISTORY

  2001-11-02 - initial revision

  2001-11-20 - added WeightedCosineSimilarity, suggested by JP Mc Gowan <jp.mcgowan@ucd.ie>

  2002-02-03 - changed representation of checksum. New method C<PureASCII>.

=head DISCARDED CHOICES

We did not use C<Storable>, because we wanted to fine-tune
compression and version compatibility.  However, this
choice may be easily reversed redefining WriteToString and
NewFromString.