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

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

use FileHandle;
use File::Basename;
use File::Path;
use Getopt::Long;
use Pod::Usage;

use BNC::Doc;
use BNC::Meta;

use CWB;
use CWB::Encoder;

our $VERSION = "0.9.2";

=head1 NAME

BNCweb/EncodeBNC.perl - Index the British National Corpus (XML edition) for use with BNCweb (CQP edition)


=head1 SYNOPSIS

  EncodeBNC.perl [<options>] <data_dir> <bnc_source_dir>

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

=head1 IMPORTANT NOTE

During the encoding procedure, a large number of data files will be created simultaneously. 
Some operating systems, notably S<Mac OS X>, do not allow a sufficient number of files to be open 
at the same time.  Please check with C<ulimit -a> whether your system allows at least 512 open
files.  If this is not the case, increase the specified value with C<ulimit -n 512> (a value around
400 might also be enough).  If you are not allowed to set this limit, please contact your system
administrator.

The encoding script relies on the external B<xsltproc> program (part of the LibXML/LibXSLT distribution),
which has to be installed separately.  If you cannot find B<xsltproc> on your computer, ask your
system administrator to install it.

=head1 DESCRIPTION

TODO

=head1 ARGUMENTS

=over 4

=item I<data_dir>

Directory for binary CWB index files.  This directory must not exist already, unless the C<--force>
option is specified.  During the encoding process, several subdirectories of I<data_dir> will be created,
viz. I<data_dir>/BNC, I<data_dir>/BNCFREQ_TEXT and I<data_dir>/BNCFREQ_SPKR.

=cut

our $DataTree = undef;
our $DataDir = undef; # = $DataTree/BNC

=item I<bnc_source_dir>

Directory tree containing the original BNC source files in XML format (usually a subdirectory F<Texts/>
in the BNC distribution).  All filenames must have the form F<XXX.xml>, where XXX is the uppercase ID of
the respective text.  Optionally, the XML may be gzipped to save space (with filenames F<XXX.xml.gz>).

Multiple source directories can be given.  In this case, all suitable source files found in the directory
trees will be concatenated and sorted alphabetically.

=cut

our @SourceDirs = ();

=back

=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 corpus (which will be available under this name in CQP and other tools).

=cut

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

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

CWB registry directory to use.  If unspecified, the encoder script uses the system default
(or the directory given by the C<CORPUS_REGISTRY> environment variable).  It will abort
unless a unique registry directories can be found.

=cut

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

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

Various tables with text and speaker metadata summaries, category codes and other meta-information
are written to TAB-delimited files during the encoding process.  All these files use the common
prefix I<prefix>, which can be changed with the C<--tables> option (e.g. for testing runs).

=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 corpus.
Without the C<--force> option, the encoder script will abort if the specified 
data directory already exists, or if there is a
conflicting entry in the selected registry directory.

=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.  The 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 files and
directories created by the encoder script.  The permissions should be 
specified 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 --sink=I<file.vrt>, -s I<file.vrt>

With this option, the encoded corpus is also written to I<file.vrt>
in the "verticalised text" CWB input format.  Useful for debugging,
or for distributing the converted corpus as a single file.

=cut

our $Opt_Sinkfile = undef;
push @opt_specs, "sink|s=s" => \$Opt_Sinkfile;

=item --verbose, -v

Display progress information and some status messages during encoding process.

=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 >= 2;

$DataTree = shift @ARGV;
@SourceDirs = @ARGV;

##
## Validate command-line arguments and options.
##

foreach my $dir (@SourceDirs) {
  $dir .= "/" unless $dir =~ /\/$/; # normalise directory names (helps to recognise directories behind symbolic links)
  die "Cannot find input directory $dir -- aborted.\n" 
    unless -d $dir;
}

$DataTree .= "/" unless $DataTree =~ /\/$/;
if (-d $DataTree) {
  die "Error: will not modify existing data directory $DataTree without --force\n"
    unless $Opt_Force;
}
else {
  print "[creating data directory $DataTree]\n" if $Opt_Verbose;
  my @dirs_created = mkpath($DataTree, 0);
  if ($Opt_Perm) {
    my $dir_perm = $Opt_Perm;
    $dir_perm =~ tr[6420][7531];
    my $n_ok = chmod oct($dir_perm), @dirs_created;
    die "Error: can't change directory permissions for $DataTree to 0$dir_perm\n"
      unless $n_ok == @dirs_created;
  }
  if ($Opt_Group) {
    my $retval = system "chgrp", $Opt_Group, @dirs_created;
    die "Error: can't set group membership of $DataTree to '$Opt_Group'\n"
      unless $retval == 0;
  }
}

$DataDir = $DataTree."BNC"; # this is the hard-coded standard


##
## Find all input files in the specified directory or directories, then sort them alphabetically.
##

our %SourceFile = ();		# avoid duplicates
my $duplicates = 0;
foreach my $dir (@SourceDirs) {
  my @lines = ();
  CWB::Shell::Cmd("find $dir \\( -name '*.xml.gz' -or -name '*.xml' \\) -type f", \@lines); 
  foreach my $filename (@lines) {
    my $basename = basename($filename, ".xml", ".xml.gz");
    if (exists $SourceFile{$basename}) {
      $duplicates++;		# ignore duplicate documents
    }
    else {
      $SourceFile{$basename} = $filename;
    }
  }
}
warn "[warning: $duplicates duplicate documents have been ignored]\n"
  if $duplicates > 0;
our @TextIDs = sort keys %SourceFile;
our $n_texts = @TextIDs;

die "Error: no input file found (in: @SourceDirs).\n"
  unless $n_texts > 0;

##
## Print welcome message after options and arguments have been validated
##

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

=head1 METADATA TABLES

B<EncodeBNC.perl> creates TAB-delimited metadata tables, which are later loaded into
the MySQL database used by BNCweb.  These tables are saved to the F<tables/>
subdirectory with common file prefix F<bnc_> (unless the default has been changed
with the C<--tables> option).  The following tables will be created:

=over 4

=item F<tables/bnc_metadata.tbl>

Metadata for BNC documents with one row for each document and the columns:
C<<
id title n_words n_tokens n_w n_c n_s
alltim alltyp scgdom sdeage sdecla sdesex spolog sporeg
wriaag wriad wriase wriaty wriaud wridom wrilev wrimed wripp wrisam wrista writas
allava spowri derivedTextType DLee
>>.

=item F<tables/bnc_speaker.tbl>

Speaker metadata for files in the spoken part of the BNC, with one row for each
document and speaker, and the columns:
C<<
file_id speaker_id
ageGroup dialect educ firstLang sex soc
age name occupation role n_words n_tokens n_w n_c n_u n_s
>>.

=item F<tables/bnc_settings.tbl>

Optional information about settings in spoken texts, with one row for each
settings description, and the columns:
C<<
file_id setting_id setting_number
speaker_list
date locale activity placeName
>>.

Setting numbers (attribute C<n> in the original markup) seem to match the
numbering of C<< <div> >> elements in some (but not all) files.  The attribute
C<speaker_list> (C<who> in the original markup) is a whitespace-separated list
of speaker IDs.  Note that setting IDs may be empty in some cases (which, 
apparently, is Lou's quaint idea of a unique identifier).

=item F<tables/bnc_keywords.tbl>

COPAC and other keywords for BNC documents (where available).  Multiple keywords
for the same document are entered as separate rows with the columns
C<<
file_id type keyword
>>
(where I<type> is C<COPAC> or C<other>, and I<keyword> contains the whitespace-normalised
keyword string).

=item F<tables/bnc_taxonomies.tbl>

List of text and speaker taxonomies (controlled vocabulary metadata) in the BNC,
with columns:
C<<
type bnc_name short_name description
>>.

I<type> has values C<text> for a text taxonomy and C<speaker> for a speaker taxonomy,
and BNC taxonomy names (I<bnc_name>) are converted to all lowercase.

=item F<tables/bnc_categories.tbl>

Full list of categories in the controlled vocabulary metadata (i.e. the text and
speaker taxonomies) in the BNC, with columns:
C<<
type bnc_taxonomy taxonomy_name category_code category_name description
>>.

I<type> has values C<text> and C<speaker> as above; I<bnc_taxonomy> and I<taxonomy_name>
correspond to I<bnc_name> and I<short_name> above; I<category_code> is a numeric code
for the category (as used in the metadata tables) and I<category_name> a short descriptive
name.

=back

=cut

##
## Make lists of metadata attributes & open metadata table files
##

## controlled vocabulary metadata categories for texts and speakers
our @text_cat = qw(ALLTIM ALLTYP SCGDOM SDEAGE SDECLA SDESEX SPOLOG SPOREG WRIAAG WRIAD WRIASE WRIATY WRIAUD WRIDOM WRILEV WRIMED WRIPP WRISAM WRISTA WRITAS allava textMode derivedTextType DLee);
our @spkr_cat = qw(ageGroup dialect educ firstLang sex soc);

## free-form metadata for texts and speakers
our @text_meta = qw(id title n_words n_tokens n_w n_c n_s);
our @spkr_meta = qw(age name occupation role n_words n_tokens n_w n_c n_u n_s);

## create informational tables with attribute and category descriptions
my $Table_Taxonomies = CWB::OpenFile "> ${Opt_Tables}_taxonomies.tbl"; # format: text/speaker lc(bnc_name) short_name description
my $Table_Categories = CWB::OpenFile "> ${Opt_Tables}_categories.tbl"; # format: text/speaker lc(bnc_taxonomy) taxonomy_name cat_code cat_name description
foreach my $taxonomy ((sort keys %TextCat), (sort keys %SpkrCat)) {
  my $tax_info = $TextCat{$taxonomy};
  my $type = "text";
  if (not defined $tax_info) {
    $tax_info = $SpkrCat{$taxonomy};
    $type = "speaker";
  }
  print $Table_Taxonomies join("\t", $type, lc($taxonomy), $tax_info->{NAME}, $tax_info->{DESC}), "\n";
  foreach my $cat_info (@{ $tax_info->{CATS} }) {
    next unless defined $cat_info;
    print $Table_Categories join("\t", $type, lc($taxonomy), $tax_info->{NAME}, $cat_info->{NUM}, $cat_info->{NAME}, $cat_info->{DESC}), "\n";
  }
}
$Table_Taxonomies->close;
$Table_Categories->close;
print "Writing metadata tables ${Opt_Tables}_*.tbl ...\n";

our $Table_Speaker = CWB::OpenFile "> ${Opt_Tables}_speaker.tbl"; # format: @text_meta @text_cat
our $Table_Meta = CWB::OpenFile "> ${Opt_Tables}_metadata.tbl";   # format: text_id spkr_id @spkr_cat @spkr_meta
our $Table_Keywords = CWB::OpenFile "> ${Opt_Tables}_keywords.tbl"; # format: text_id type keyword_string
our $Table_Settings = CWB::OpenFile "> ${Opt_Tables}_settings.tbl"; # format: text_id setting_id n who date locale activity placeName

##
## Set up CWB::Encoder
##

our $Encoder = new CWB::Encoder $Opt_Name;
$Encoder->registry($Opt_Registry)
  if $Opt_Registry;
$Encoder->dir($DataDir);
$Encoder->overwrite($Opt_Force);

$Encoder->longname("British National Corpus (XML edition)");
$Encoder->charset("latin1");
$Encoder->language("en");
my $info_text = <<'STOP';
Encoded for use with BNCweb (CQP edition).

For interactive use with CQP, please run the standard BNC encoder script.
STOP
$Encoder->info($info_text);

$Encoder->group($Opt_Group)
  if $Opt_Group;
$Encoder->perm($Opt_Perm)
  if $Opt_Perm;

$Encoder->p_attributes(qw(word pos lemma hw class type flags_before space_after tags_before tags_after offset));

$Encoder->s_attributes(qw(text:0+id+spowri u:0+who));
$Encoder->s_attributes(qw(div:3+n+level+type head:0+type+rend quote:1+rend sp:0+who speaker:0),
		       qw(stage:0+rend lg:0 l:0+rend list:2+rend label:0+rend item:2+rend note:0+place+n),
		       qw(bibl:0+rend corr:0+sic+rend hi:1+rend trunc:0));
$Encoder->s_attributes(qw(p:2+type+rend s:0+n));
$Encoder->s_attributes(qw(mw:0+pos+lemma+hw+class));

$Encoder->decode_entities(0);	# because we store strings with HTML entities for non-ASCII characters (and & < > ")

$Encoder->memory($Opt_Memory);
$Encoder->verbose($Opt_Verbose);

our $EncoderPipe = $Encoder->encode_pipe;

##
##   === Start of main loop ===
##

print "Converting source files to CWB format ...\n";

our $sink = ($Opt_Sinkfile) ? CWB::OpenFile "> $Opt_Sinkfile" : undef;

my $start_time = time;
my $total_tokens = 0;
my $total_words = 0;
my $n = 0;
foreach my $ID (@TextIDs) {
  ## parse BNC source file
  my $filename = $SourceFile{$ID};
  my $doc = new BNC::Doc $filename, "html"; # BNCweb uses the Latin1/HTML encoding
  $n++;

  my $real_id = $doc->text_meta("id");
  if ($real_id ne "$ID") {
    warn "Warning: document ID '$real_id' does not match filename '$filename' (skipped)\n";
    next;
  }

  ## calculate some statistics
  my $total_time = time - $start_time + .5; # avoid division by zero error if first doc is processed extremely fast
  my $n_words = $doc->text_meta("n_words");
  my $n_tokens = $doc->text_meta("n_tokens");
  $total_words += $n_words;
  $total_tokens += $n_tokens;

  my $doc_text_cat = $doc->text_cat_numeric;
  my $text_mode = $doc_text_cat->{"textMode"};
  my @doc_text_cat = map { $doc_text_cat->{$_} } @text_cat;
  my @doc_text_meta = map { $doc->text_meta($_, "N/A") } @text_meta;
  print $Table_Meta join("\t", @doc_text_meta, @doc_text_cat), "\n";

  foreach my $spkr_id ($doc->speakers) {
    unless ($doc->speaker_meta($spkr_id, "n_tokens", 0) > 0) {
      warn "Warning: speaker '$spkr_id' declared in header of file '$real_id', but doesn't say anything.\n";
      next; # don't store metadata for speakers that do not appear in text body
    }
    my $doc_spkr_cat = $doc->speaker_cat_numeric($spkr_id);
    my @doc_spkr_cat = map { $doc_spkr_cat->{$_} } @spkr_cat;
    my @doc_spkr_meta = map { $doc->speaker_meta($spkr_id, $_, "N/A") } @spkr_meta;
    print $Table_Speaker join("\t", $ID, $spkr_id, @doc_spkr_cat, @doc_spkr_meta), "\n";
  }

  my $doc_keywords = $doc->text_meta("keywords", []);
  foreach my $pair (@$doc_keywords) {
    print $Table_Keywords join("\t", $ID, @$pair), "\n";
  }

  my $settings = $doc->text_meta("settings", {});
  foreach my $s_id (sort keys %$settings) {
    print $Table_Settings join("\t", $ID, @{ $settings->{$s_id} }), "\n";
  }

  print $EncoderPipe "<text id=\"$ID\" spowri=\"$text_mode\">\n";
  print $sink "<text id=\"$ID\" spowri=\"$text_mode\">\n"
    if $sink;

  foreach my $line (@{$doc->body}) {
    if (ref $line) {
      $line->[7] = ($line->[7] eq "") ? "/\x{A0}" : "/\x{A0}\x{A0}"; # special encoding of no space / space expected by BNCweb
      $line->[8] =~ tr[ ][\x{a0}];				     # blanks in tags_before and tags_after are protected as non-breaking spaces
      $line->[9] =~ tr[ ][\x{a0}];
      $line->[8] = "/\x{A0}" . $line->[8];			     # special prefix for tags_before and tags_after attributes
      $line->[9] = "/\x{A0}" . $line->[9];
      print $EncoderPipe join("\t", @$line), "\n";
      print $sink join("\t", @$line), "\n"
	if $sink;
    }
    else {
      ## no special processing required for <u> tags (since speaker metadata doesn't have to be inserted)
      print $EncoderPipe $line, "\n";
      print $sink $line, "\n"
	if $sink;
    }
  }

  print $EncoderPipe "</text>\n";
  print $sink "</text>\n"
    if $sink;

  ## print progress information and ETA (with -v option)
  if ($Opt_Verbose) {
    my $eta = ($n_texts - $n) * ($total_time / $n); # ETA in seconds
    my $eta_h = int($eta / 3600);
    my $eta_m = int(($eta - 3600 * $eta_h) / 60);
    my $eta_s = int($eta - 3600 * $eta_h - 60 * $eta_m + .4);
    printf "%4d/%d [%3s] %5.1fk words  -- %5.1fM words \@ %3.1fk words/s  --  ETA: %02d:%02d:%02d     \r",
      $n, $n_texts, $ID, 
	($n_words/1000), ($total_words/1e6), ($total_words/1000)/$total_time,
	  $eta_h, $eta_m, $eta_s;
  }
}
$sink->close if $sink;
print "\n" if $Opt_Verbose;

##
##   === End of main loop ===
##

$Table_Speaker->close;
$Table_Meta->close;
$Table_Keywords->close;
$Table_Settings->close;

##
## Finish indexing & compression
##
print "Building indices and compressing data ... \n";
$Encoder->close_pipe;

printf "Encoding complete (corpus size: %.1fM tokens, %.1fM words).\n", $total_tokens / 1e6, $total_words / 1e6;


=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.
