#!/usr/bin/perl
$| = 1;

use warnings;
use strict;
use lib 'lib';

use Getopt::Long;
use Pod::Usage;

use CWB;
use CWB::CQP;
use CWB::Encoder;

our $VERSION = "0.9.2";

=head1 NAME

BNCweb/MakeFreqTables.perl - Create BNCweb frequency tables and databases for BNC (XML edition)


=head1 SYNOPSIS

  MakeFreqTables.perl [<options>]

  ## Type 'perl MakeFreqTables.perl -h' for a description of options and arguments.
  ## Type 'perldoc MakeFreqTables.perl' for full documentation.

=head1 IMPORTANT NOTE

This script extracts frequency information from a CWB-encoded version of the British
National Corpus (XML edition), which has to be created with B<EncodeBNC.perl> first!

=head1 DESCRIPTION

TODO

=head1 OPTIONS

=cut

our @opt_specs = (); # list of option specifications for Getopt::Long collected below 

=over 4

=item --name=I<name>, -n I<name> (default: C<BNCWEB>)

CWB name of the encoded BNC corpus, from which frequency information will be extracted.
The CWB frequency databases created by B<MakeFreqTables.perl> will have CWB names
C<I<name>_FREQ_TEXT> and C<I<name>_FREQ_SPKR>, respectively (default names are thus
C<BNCWEB_FREQ_TEXT> and C<BNCWEB_FREQ_SPKR>).

=cut

our $Opt_Name = "BNCWEB";
push @opt_specs, "name|n=s" => \$Opt_Name;

=item --registry=I<dir>, -r I<dir>

CWB registry directory where the registry entry for the CWB-encoded BNC corpus is located.
Only required if it cannot be found automatically.  The registry entries for the two 
frequency database corpora will be stored in the same directory.

=cut

our $Opt_Registry = undef;
push @opt_specs, "registry|r=s" => \$Opt_Registry;

=item --tables=I<prefix>, -t I<prefix> (default: F<tables/bnc>)

File prefix for frequency data tables.  Note that this prefix B<must> be the same as 
used in B<EncodeBNC.perl> (since the text and speaker metadata tables created during
the encoding process will be modified).

=cut

our $Opt_Tables = "tables/bnc";
push @opt_specs, "tables|t=s" => \$Opt_Tables;

=item --force, -f

Overwrite an existing data directory and/or registry entry for the CWB frequency
databases created by this script.  By default, B<MakeFreqTables.perl> will abort
if there is a conflict with an existing file.

=cut

our $Opt_Force = 0;
push @opt_specs, "force|f" => \$Opt_Force;

=item --memory=I<n>, -M I<n> (default: 200)

Use approx. I<n> MiB of memory during indexing of the frequency databases.
default should work well on computers that have at least 512 MiB of RAM installed
(provided that they are not heavily used by other processes).
Specify a higher value of I<n> to speed up indexing, but make sure that it fits
conveniently within physical RAM (as any swapping will impair performance considerably).

=cut

our $Opt_Memory = 200;
push @opt_specs, "memory|M=i" => \$Opt_Memory;

=item --group=I<s>, -g I<s>

=item --perm=I<mode>, -p I<mode>

Specify group membership and access permissions for the CWB frequency databases created
by this script.  The permissions should be given as a 3-digit code I<mode> for regular
files (e.g. C<644>), from whch the code for directories will automatically be derived.
By default, the standard group membership and permissions assigned by the operating
system will not be changed.

=cut

our $Opt_Group = undef;
our $Opt_Perm = undef;
push @opt_specs,
  "group|g=s" => \$Opt_Group,
  "permissions|perm|p=s" => \$Opt_Perm;

=item --verbose, -v

Display progress information and some status messages.

=item --help, -h

Display a short usage message and options summary.

=cut

our $Opt_Verbose = 0;
our $Opt_Help = 0;
push @opt_specs,
  "verbose|v" => \$Opt_Verbose,
  "help|h" => \$Opt_Help;

=back

=cut

my $ok = GetOptions(@opt_specs);

pod2usage(-exitval => 0, -verbose => 1) if $Opt_Help;
pod2usage(-exitval => 1, -verbose => 0) unless $ok and @ARGV == 0;

##
## Locate CWB-encoded BNC corpus and frequency tables to be modified
##

our $bnc_reg;
if ($Opt_Registry) {
  my $registry_file = $Opt_Registry."/".lc($Opt_Name);
  $bnc_reg = new CWB::RegistryFile $registry_file;
  die "Can't read registry file $registry_file -- aborted.\n"
    unless defined $bnc_reg;
}
else {
  $bnc_reg = new CWB::RegistryFile $Opt_Name;
  die "Can't find corpus $Opt_Name in standard registry path. Please use -r option.\n"
    unless defined $bnc_reg;
}

our $registry_dir = $bnc_reg->filename; # registry directory to use for frequency databases
$registry_dir =~ s{/[^/]+$}{};

our $data_dir = $bnc_reg->home; # directory tree for CWB index data
$data_dir =~ s{/+BNC/*$}{}
  or die "Nonstandard data directory $data_dir/ -- is $Opt_Name the corpus created by EncodeBNC.perl?\n";

our $data_dir_text = "$data_dir/BNC_freq_text";
our $data_dir_spkr = "$data_dir/BNC_freq_spkr";

our $name_freq_text = $Opt_Name."_FREQ_TEXT";
our $name_freq_spkr = $Opt_Name."_FREQ_SPKR";

our $index_table_text = $Opt_Tables."_freqdb_index_text.tbl";
our $index_table_spkr = $Opt_Tables."_freqdb_index_spkr.tbl";

unless ($Opt_Force) {
  die "Data directory $data_dir_text/ exists, won't overwrite without --force.\n"
    if -d $data_dir_text;
  die "Data directory $data_dir_spkr/ exists, won't overwrite without --force.\n"
    if -d $data_dir_spkr;
  die "Registry entry for $name_freq_text exists in registry directory $registry_dir/, won't overwrite without --force.\n"
    if -f $registry_dir."/".lc($name_freq_text);
  die "Registry entry for $name_freq_spkr exists in registry directory $registry_dir/, won't overwrite without --force.\n"
    if -f $registry_dir."/".lc($name_freq_spkr);
}

our $text_metadata = $Opt_Tables."_metadata.tbl";
our $spkr_metadata = $Opt_Tables."_speaker.tbl";
our $settings_metadata = $Opt_Tables."_settings.tbl";
die "Can't find text metadata table $text_metadata -- perhaps you need the -t option?\n"
  unless -f $text_metadata;
die "Can't find speaker metadata table $spkr_metadata -- perhaps you need the -t option?\n"
  unless -f $spkr_metadata;
die "Can't find settings information table $settings_metadata -- perhaps you need the -t option?\n"
  unless -f $settings_metadata;

##
## Print welcome message after setup has been validated
##

print "BNCweb/CQP frequency tables for BNC (XML edition), version $VERSION.\n";

if ($Opt_Verbose) {
  print "\n";
  print "  CWB name of corpus:      $Opt_Name\n";
  print "  Registry directory:      $registry_dir\n";
  print "  CWB index data tree:     $data_dir\n";
  print "  Frequency DB (texts):    $name_freq_text\n";
  print "    data directory:        $data_dir_text\n";
  print "  Frequency DB (speakers): $name_freq_spkr\n";
  print "    data directory:        $data_dir_spkr\n";
  print "  Text metadata table:     $text_metadata\n";
  print "  Speaker metadata table:  $spkr_metadata\n";
  print "\n";
}

## Uncomment the following line (with appropriate target) for quick testing:
# goto MAKE_INDICES;

##
## Update metadata tables
##

=head1 UPDATED METADATA TABLES

The metadata tables C<tables/bnc_metadata.tbl> for texts, C<tables/bnc_speaker.tbl> for speakers and 
C<tables/bnc_settings.tbl> for conversation settings (the name prefix can be changed with the C<-t> option, see above),
which have been created by B<EncodeBNC.perl>, are updated with corpus positions for texts, speakers and settings,
respectively.  Start and end corpus positions are added as two additional columns.  They are appended as rightmost
columns for the text and speaker tables, and inserted as fourth and fifth column in the settings table (after
text ID, setting ID and setting number, and before the list of speaker IDs participating in the setting).
In C<tables/bnc_metadata.tbl> and C<tables/bnc_settings.tbl>, these columns contain single integer
numbers (for some settings that are not found in the corpus, both numbers are -1).  
In C<tables/bnc_speaker.tbl>, they contain whitespace-separated lists of numbers giving the
start positions (in the first new column) and end positions (in the second column) of all C<< <u> >>-units
for each speaker.

If the metadata tables already contain start and end corpus positions (because B<MakeFreqTables.perl>
has already been run before), the values in these columns will be overwritten (rather than adding further
columns).

=cut

print "Updating metadata tables ...\n";

print " + text metadata .." if $Opt_Verbose;
UPDATE_TEXT_METADATA:
{
  my ($text_table, $n_row, $n_col) = load_tab_table($text_metadata);
  if ($text_table->[$n_col-1]->[$n_row-1] =~ /^[0-9]{6,}$/
      and $text_table->[$n_col-2]->[$n_row-2]  =~ /^[0-9]{6,}$/) {
    $n_col -= 2; # text metadata table has probably been extended already -> overwrite cpos columns 
  }
  print "..." if $Opt_Verbose;

  my %regions = (); # store in hash in case metadata table has different ordering
  my $pipe = CWB::OpenFile "$CWB::SDecode -r $registry_dir $Opt_Name -S text_id |";
  while (<$pipe>) {
    chomp;
    my ($start, $end, $id) = split /\t/;
    $regions{$id} = [$start, $end];
  }
  $pipe->close;
  print ".." if $Opt_Verbose;
  
  foreach my $i (0 .. $n_row-1) {
    my $id = $text_table->[0]->[$i]; # first column should be text ID
    die "Error: can't find text '$id' in corpus $Opt_Name -- aborted.\n"
      unless exists $regions{$id};
    $text_table->[$n_col]->[$i] = $regions{$id}[0];
    $text_table->[$n_col+1]->[$i] = $regions{$id}[1];
  }
  print ".." if $Opt_Verbose;

  save_tab_table($text_table, $text_metadata);
  print ". updated\n" if $Opt_Verbose;
}

print " + speaker metadata .." if $Opt_Verbose;
UPDATE_SPKR_METADATA:
{
  my ($spkr_table, $n_row, $n_col) = load_tab_table($spkr_metadata);
  if ($spkr_table->[$n_col-1]->[$n_row-1] =~ /^[0-9]+(\s+[0-9]+)+$/
      and $spkr_table->[$n_col-2]->[$n_row-2] =~ /^[0-9]+(\s+[0-9]+)+$/) {
    $n_col -= 2; # speaker metadata table has probably been extended already -> overwrite cpos columns
  }
  print ".." if $Opt_Verbose;

  my %regions = (); # collect speaker regions in hash
  my $pipe = CWB::OpenFile "$CWB::SDecode -r $registry_dir $Opt_Name -S u_who |";
  while (<$pipe>) {
    chomp;
    my ($start, $end, $id) = split /\t/;
    if (exists $regions{$id}) {
      push @{ $regions{$id}[0] }, $start;
      push @{ $regions{$id}[1] }, $end;
    }
    else {
      $regions{$id} = [ [$start], [$end] ];
    }
  }
  $pipe->close;
  print "...." if $Opt_Verbose;
  
  foreach my $i (0 .. $n_row-1) {
    my $id = $spkr_table->[1]->[$i]; # second column should be speaker ID
    die "Error: can't find speaker '$id' in corpus $Opt_Name -- aborted.\n"
      unless exists $regions{$id};
    $spkr_table->[$n_col]->[$i] = join(" ", @{ $regions{$id}[0] });
    $spkr_table->[$n_col+1]->[$i] = join(" ", @{ $regions{$id}[1] });
  }
  print ".." if $Opt_Verbose;

  save_tab_table($spkr_table, $spkr_metadata);
  print ". updated\n" if $Opt_Verbose;
}

print " + setting information .." if $Opt_Verbose;
UPDATE_SETTING_INFO:
{
  my ($settings_table, $n_row, $n_col) = load_tab_table($settings_metadata);
  unless ($settings_table->[3]->[$n_row-1] =~ /^[0-9]{6,}$/   # check if fourth / fifth column already contain corpus positions
      and $settings_table->[4]->[$n_row-2]  =~ /^[0-9]{6,}$/) {
    splice @$settings_table, 3, 0, ([], []); # insert new columns for corpus positions after text ID, setting ID and setting number
  }

  my %settings_in_file = ();  # if there are multiple settings in a file, their numbers should appear in <div> elements
  foreach my $i (0 .. $n_row-1) {
    $settings_in_file{ $settings_table->[0]->[$i] }++; # = file ID
  }
  print "." if $Opt_Verbose;

  my %text_cpos = (); # $text_cpos{$text_id} = [$start, $end];
  my $pipe = CWB::OpenFile "$CWB::SDecode -r $registry_dir $Opt_Name -S text_id |";
  while (<$pipe>) {
    chomp;
    my ($start, $end, $id) = split /\t/;
    $text_cpos{$id} = [$start, $end];
  }
  $pipe->close;
  print ".." if $Opt_Verbose;

  my %div_cpos = (); # $div_cpos{$n} = [$start, $end];
  $pipe = CWB::OpenFile "$CWB::SDecode -r $registry_dir $Opt_Name -S div_n |";
  while (<$pipe>) {
    chomp;
    my ($start, $end, $n) = split /\t/;
    $div_cpos{$n} = [$start, $end]
      if $n ne "";
  }
  $pipe->close;
  print ".." if $Opt_Verbose;

  my $n_dropped = 0;
  foreach my $i (0 .. $n_row-1) {
    my $text_id = $settings_table->[0]->[$i];
    my $n = $settings_table->[2]->[$i];
    my ($start, $end) = @{ $text_cpos{$text_id} }; # default for single setting in file
    if (($settings_in_file{$text_id} || 0) > 1) {
      if ($div_cpos{$n}) {
        my ($div_start, $div_end) = @{ $div_cpos{$n} };
        if ($start <= $div_start and $div_end <= $end) {
          ($start, $end) = ($div_start, $div_end);
        }
        else {
          ## warn "\nWarning: <div n='$n'> element is not contained in <text id='$text_id'>, setting dropped.\n";
          $start = $end = -1;
          $n_dropped++;
        }
      }
      else {
        ## warn "\nWarning: no <div> element found for setting n=$n ($text_id), setting dropped.\n";
        $start = $end = -1;
        $n_dropped++;
      }
    }
    $settings_table->[3]->[$i] = $start;
    $settings_table->[4]->[$i] = $end;
  }
  print ".." if $Opt_Verbose;

  save_tab_table($settings_table, $settings_metadata);
  print ". updated\n" if $Opt_Verbose;

  print "Warning: $n_dropped settings not found in corpus (ignored).\n";
}

print "\n" if $Opt_Verbose;


##
## Extract lexical frequency tables
##

=head1 FREQUENCY TABLES

B<MakeFreqTables.perl> generates the following lexical and part-of-speech frequency tables from the encoded BNC corpus.
The default prefix C<tables/bnc> can be changed with the C<-t> option (see above).

=over 4

=item C<tables/bnc_freq_pos.tbl>

Frequency information for part-of-speech tags in the spoken and written parts of the BNC.
A TAB-delimited table with the fields C<f> (frequency), C<pos> (part-of-speech tag), and C<mode> 
(modality, with C<1> = written and C<2> = spoken texts; cf. C<tables/bnc_categories.tbl>).

=item C<tables/bnc_freq_lemma.tbl>

Frequency information for lemmata in the spoken and written parts of the BNC.
A TAB-delimited table with the fields C<f> (frequency), C<hw> (headword part of the lemma),
C<class> (word class of the lemma) and C<mode> (C<1> = written, C<2> = spoken).

=item C<tables/bnc_freq_word.tbl>

Frequency information for combinations of word form and part-of-speech tag in the spoken
and written parts of the BNC.
A TAB-delimited table with the fields C<f> (frequency), C<word> (word form), C<pos> (part-of-speech tag),
C<class> (word class of the lemma, calculated from POS tag) and C<mode> (C<1> = written, C<2> = spoken).

NB: Frequencies are given for (I<word>,I<pos>) combinations.  The overall frequency of a word form
can be obtained by summation over all POS tags for this word form (and over the written and spoken parts
of the corpus).

=back

Note that frequencies are given separately for written and spoken texts (but collected in the
same table).  In order to obtain the overall distribution, the written and spoken frequencies
have to be added up (e.g. by aggregation in a relational database).

=cut

print "Creating lexical frequency tables ...\n";

MAKE_POS_FREQ:
{
  my $filename = $Opt_Tables."_freq_pos.tbl";
  my $quiet_flag = "-q";
  if ($Opt_Verbose) {
    print " + POS tags ($filename)\n";
    $quiet_flag = "";
  }
  my $cmd = "$CWB::ScanCorpus -r $registry_dir -o $filename $quiet_flag $Opt_Name pos+0 text_spowri+0";
  my $status = system $cmd;
  die "FAILED (command: $cmd)\n" unless $status == 0;
}

MAKE_LEMMA_FREQ:
{
  my $filename = $Opt_Tables."_freq_lemma.tbl";
  my $quiet_flag = "-q";
  if ($Opt_Verbose) {
    print " + lemma \& word class ($filename)\n";
    $quiet_flag = "";
  }
  my $cmd = "$CWB::ScanCorpus -r $registry_dir -o $filename $quiet_flag $Opt_Name hw+0 class+0 text_spowri+0";
  my $status = system $cmd;
  die "FAILED (command: $cmd)\n" unless $status == 0;
}

MAKE_WORD_FREQ:
{
  my $filename = $Opt_Tables."_freq_word.tbl";
  my $quiet_flag = "-q";
  if ($Opt_Verbose) {
    print " + word form \& POS ($filename)\n";
    $quiet_flag = "";
  }
  my $cmd = "$CWB::ScanCorpus -r $registry_dir -o $filename $quiet_flag $Opt_Name word+0 pos+0 class+0 text_spowri+0";
  my $status = system $cmd;
  die "FAILED (command: $cmd)\n" unless $status == 0;
}

print "\n" if $Opt_Verbose;


##
## Generate some index tables (with corpus positions)
##

=head1 INDEX TABLES

B<MakeFreqTables.perl> generates an index table with the start and end B<corpus positions> of all s-units
in the BNC, which can be used to reconstruct arbitrary parts of the BNC through CQP (after B<undump>ing 
a table of appropriate corpus positions).

=over 4

=item C<tables/bnc_s_cpos.tbl>

Start and end corpus positions of all s-units in the BNC, indexed by text ID and s-unit number.
A TAB-delimited table with the fields C<text_id> (text ID), C<s_n> (s-unit number), C<n> (internal
numbering of s-units), C<start> (corpus position of first token) and C<end> (corpus position of last token).

=back

=cut

print "Creating index tables ...\n";

MAKE_INDICES:
{
  my $filename = $Opt_Tables."_s_cpos.tbl";
  my $fh = CWB::OpenFile "> $filename";
  print " - $filename .." if $Opt_Verbose;
  my $cqp = new CWB::CQP "-r $registry_dir";
  $cqp->exec($Opt_Name); # activate BNC base corpus
  $cqp->exec("S-Units = <s> [] expand to s"); # query result = all s-units in BNC
  print "..." if $Opt_Verbose;
  my $tab_cmd = "tabulate S-Units match text_id, match s_n, match, matchend"; # extract required information for each s-unit
  ## process tabulate output with callback because downloading all output lines to Perl wastes too much memory
  my $n = 0;
  $cqp->run($tab_cmd);
  while (my @F = $cqp->getrow) {
    my ($text_id, $s_n, $start, $end) = @F;
    print $fh join("\t", $text_id, $s_n, $n, $start, $end), "\n";
    $n++;
    print "." if $Opt_Verbose and ($n & 0x3ffff) == 0; # ca. 4 dots per million s-units
  }
  $fh->close;
  undef $cqp;
  print " ok\n" if $Opt_Verbose;
}


##
## Create CWB frequency databases for exact subcorpus frequencies
##

=head1 FREQUENCY DATABASES

B<MakeFreqTables.perl> creates two CWB corpora in a special format, containing lexical databases for all
texts and speakers in the BNC.  From these database corpora, lexical frequency tables for arbitrary written
and spoken subcorpora of the BNC can be generated efficiently with the B<cwb-scan-corpus> tool.  In addition,
index tables are generated with start and end corpus positions for each text and speaker in the database 
corpora (to allow efficient summation over an arbitrary set of texts or speakers).

=over 4

=item B<per-text frequencies>:

The database corpus is created under the name C<BNCWEB_FREQ_TEXT> (unless the CWB basename has been changed
with the C<-n> option) with p-attributes C<word>, C<pos>, C<lemma> (= I<headword>_I<class>), C<hw> (headword), C<class> and
C<f> (frequency of (I<word>, I<pos>, I<lemma>) combination in the respective text, and s-attribute C<text_id> specifying 
text IDs for the subparts of the frequency database.  An index table, corresponding to a dump of the C<text_id>
regions with columns C<start>, C<end> and C<id>, is written to the file C<tables/bnc_freqdb_index_text.tbl> 
(unless the file path and prefix have been changed with the C<-t> option).

=item B<per-speaker frequencies>:

The database corpus is created under the name C<BNCWEB_FREQ_SPKR> with p-attributes C<word>, C<pos>, C<lemma>
(= I<headword>_I<class>), C<hw> (headword), C<class>  and 
C<f> (frequency of (I<word>, I<pos>, I<lemma>) combination for the respective speaker, 
and s-attribute C<speaker_id> specifying unique speaker IDs for the subparts of the frequency database.  
An index table, corresponding to a dump of the C<speaker_id> regions with columns C<start>, C<end> and C<id>, 
is written to the file C<tables/bnc_freqdb_index_spkr.tbl>.

=back

=cut

MAKE_FREQDB_TEXT:
{
  print "Creating frequency database for text-level subcorpora ...\n";

  my %F = ();               # $F{$word_pos_lemma} = $f; ... within each BNC text
  my $cmd  = "$CWB::Decode -r $registry_dir -C $Opt_Name -P word -P pos -P lemma -P hw -P class -S text_id";
  my $pipe = CWB::OpenFile "$cmd |";
  my ($encoder, $enc_pipe) = open_encoder_pipe($name_freq_text, $data_dir_text, "text:0+id");
  my $current_id = undef;
  my $n_texts    = 0;
  while (<$pipe>) {
    chomp;
    if (/^<text_id\s+(.+)>$/) {
      $current_id = $1;
      $n_texts++;
      die "FORMAT ERROR: $_ (line #$.)\n" 
        unless $current_id =~ /^[A-Z][A-Z0-9]{2}$/;
      %F = ();
    } elsif (/^<\/text_id>/) {
      die "Unexpected </text> tag (line #$.) ... aborted.\n" 
        unless defined $current_id;
      printf "  > storing frequencies for text #%04d (%s)\r", $n_texts, $current_id
        if $Opt_Verbose;
      print $enc_pipe "<text id=\"$current_id\">\n";
      my @entries = sort { $F{$b} <=> $F{$a} or $a cmp $b } keys %F;
      foreach my $entry (@entries) {
        print $enc_pipe join("\t", $entry, $F{$entry}), "\n";
      }
      print $enc_pipe "</text>\n";
      undef $current_id;
    } else {
      die "Missing <text id='XXX'> tag (line #$.) [$_]\n"
        unless defined $current_id;
      my ($word, $pos, $lemma, $hw, $class) = split /\t/;
      $F{"$word\t$pos\t$lemma\t$hw\t$class"}++;
    }
  }
  $pipe->close;
  die "Missing </text> tag at end of corpus ... aborted.\n"
    if defined $current_id;
  print " + frequency data stored for all $n_texts documents in $Opt_Name\n"
    if $Opt_Verbose;
  $encoder->close_pipe;

  print " + saving index table to file $index_table_text\n"
    if $Opt_Verbose;
  CWB::Shell::Cmd("$CWB::SDecode -r $registry_dir $name_freq_text -S text_id > $index_table_text");
}

MAKE_FREQDB_SPKR:
{
  print "Creating frequency database for speaker-level subcorpora ...\n";

  my %F = ();                   # $F{$speaker}{$word_pos_lemma} = $f;
  print "\nCalculating per-speaker frequencies:\n";
  my $quiet_flag = ($Opt_Verbose) ? "" : "-q";
  my $cmd = "$CWB::ScanCorpus $quiet_flag -r $registry_dir $Opt_Name word+0 pos+0 lemma+0 hw+0 class+0 u_who+0=/.+/"; # =/.+/ restricts scan to <u> ... </u> regions
  my $pipe = CWB::OpenFile "$cmd |";
  while (<$pipe>) {
    chomp;
    my ($f, $word, $pos, $lemma, $hw, $class, $who) = split /\t/;
    $F{$who}{"$word\t$pos\t$lemma\t$hw\t$class"} += $f; # just to be on the safe side - there shouldn't be any duplicates
  }
  $pipe->close;
  my $n_who = keys %F;
  my ($encoder, $enc_pipe) = open_encoder_pipe($name_freq_spkr, $data_dir_spkr, "speaker:0+id");
  my $n = 0;
  foreach my $who (sort keys %F) {
    $n++;
    printf " > %4d/%4d - storing frequencies for speaker %s     \r", $n, $n_who, $who
      if $Opt_Verbose;
    print $enc_pipe "<speaker id=\"$who\">\n";
    my $hash = $F{$who};
    my @entries = sort { $hash->{$b} <=> $hash->{$a} or $a cmp $b } keys %$hash;
    foreach my $entry (@entries) {
      print $enc_pipe join("\t", $entry, $hash->{$entry}), "\n";
    }
    undef $hash;
    print $enc_pipe "</speaker>\n";
  }
  print " + frequency data stored for all $n_who speakers in $Opt_Name\n"
    if $Opt_Verbose;
  $encoder->close_pipe;

  print " + saving index table to file $index_table_spkr\n"
    if $Opt_Verbose;
  CWB::Shell::Cmd("$CWB::SDecode -r $registry_dir $name_freq_spkr -S speaker_id > $index_table_spkr");
}

##
## That's it.
##

print "Processing complete.\n";


##
## Subroutines
##

## load TAB-delimited file into column-major data structure
sub load_tab_table {
  my $filename = shift;
  my $fh = CWB::OpenFile $filename;
  $_ = <$fh>;
  chomp;
  my @F = split /\t/;
  my $n_fields = @F;
  my $matrix = [ map { [$_] } @F ]; # initialise column-major matrix
  my $n_rows = 1; # matrix has been initialised with the first row of data
  while (<$fh>) {
    chomp;
    @F = split /\t/;
    my $n = @F;
    die "Format error in table $filename: line #$. has $n fields instead of $n_fields.\n"
      unless $n == $n_fields;
    foreach my $i (0 .. $n-1) {
      push @{ $matrix->[$i] }, $F[$i];
    }
    $n_rows++;
  }
  $fh->close;
  return (wantarray) ? ($matrix, $n_rows, $n_fields) : $matrix;
}

## write column-major data structure to TAB-delimited file
sub save_tab_table {
  my ($matrix, $filename) = @_;
  my $n_col = @$matrix;
  my $n_row = undef;
  foreach my $column (@$matrix) {
    my $rows = @$column;
    $n_row = $rows unless defined $n_row;
    die "Internal error: can't save 'ragged' matrix to TAB-delimited table $filename\n"
      unless $rows == $n_row;
  }
  my $fh = CWB::OpenFile "> $filename";
  foreach my $i (0 .. $n_row-1) {
    my @rowdata = map { $_->[$i] } @$matrix; # extract row from matrix
    print $fh join("\t", @rowdata), "\n";
  }
  $fh->close;
}

# ($encoder, $fh) = open_db_encoder_pipe($id, $datadir, @s_attributs);
#   - open pipe to CWB::Encoder for specified corpus ID, data directory and s-attribute specifications
#   - p-attributes are hardcoded to (word, pos, lemma, f)
#   - all other settings are automatically read from global configuration variables
#   - returns CWB::Encoder object ($encoder) and open pipe ($fh)
sub open_encoder_pipe {
    my $id           = uc(shift);
    my $datadir      = shift;
    my @s_attributes = @_;

    my $encoder = new CWB::Encoder $id;
    $encoder->registry($registry_dir);
    $encoder->dir($datadir);
    $encoder->overwrite($Opt_Force);
    $encoder->longname("BNC (XML edition) Frequency Database ($id)");
    $encoder->info("Internal frequency tables for BNCweb corpus interface.");
    $encoder->charset("latin1");
    $encoder->language("en");
    $encoder->group($Opt_Group)   if $Opt_Group;
    $encoder->perm($Opt_Perm)     if $Opt_Perm;
    $encoder->memory($Opt_Memory) if $Opt_Memory;
    $encoder->verbose($Opt_Verbose);
    $encoder->p_attributes(qw(word pos lemma hw class f));
    $encoder->s_attributes(@s_attributes);

    return ($encoder, $encoder->encode_pipe);
}

=head1 AUTHOR

Stefan Evert E<lt>stefan.evert@uos.deE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007-2008 by Stefan Evert

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.
