#!/usr/bin/perl -w
# Author: I.Plisco (igor at plisco dot ru)
# Aim: Recodes HIP 2 TXT in a directory recursively
# $Id$

use strict;

use File::Find;
use IO::Handle;

# Locale - for case insensitive comparisons
use locale;
use POSIX qw(locale_h);
setlocale(LC_CTYPE, "ru_RU.cp1251");

use Data::Dumper;

# Define parameters
my $dict = "dic.txt";
my $dict_uc = "dic_uc.txt";
my $dict_num = "dic_num.txt";

my $do_unlink = 1;

my $pwd = $ENV{'PWD'};
my $dir_in = "$pwd/txt";
my $dir_test = "$pwd/test";
#$dir_in = $dir_test;

my (@dict_lines, @post_dict_lines);
my ($subst, %is_uc, %nums, $num_letts);

read_codes();
STDOUT->autoflush(1);
undef $/;

# Test or work
if(0) {
#  chdir $dir_test;
#  recode_file('example.hip');
  find(\&recode_file, $dir_test);
} else {
  find(\&recode_file, $dir_in);
}


#============================================================
sub recode_file {
#============================================================

=head2 recode_file

 Purpose   : Recodes one file.
 Arguments :
	1 - filename
 Returns   : Nothing.
 Throws    : No.
 Comments  : None.

See Also   : N/A.

=cut

#------------------------------------------------------------
  my ($file) = @_;
  my ($file_out);

  $file ||= $File::Find::name;
  return unless $file;

  if ($file =~ /(.*)\.hip$/) {
    $file_out = "$1.txt";
  } else {
    return;
#    $file_out = "$file.txt";
  }

  print "File: $file -> ";

  open (IN, $file) or die;
  open (OUT, ">$file_out") or die;

  while (<IN>) {
    foreach $subst (@dict_lines) {
      s/$subst->[0]/$subst->[1]/g;
    }
    s/\b_?($num_letts{1,2})~_?($num_letts*)/join('+',map{$nums{$_}}split('',"$1$2"))/gee;
#    s/\b_?(${num_letts}{1,2})~_?($num_letts*)/======= $1+$2 =======/g;
    foreach $subst (@post_dict_lines) {
      s/$subst->[0]/$subst->[1]/g;
    }
    print OUT;
  }

  close IN;
  close OUT;

  if ($do_unlink) {
    unlink($file);
  }

  print "$file_out\n";

}


#============================================================
sub read_codes {
#============================================================

=head2 read_codes

 Purpose   : Reads letter codes.
 Arguments :
	None.
 Returns   : Codes as plain hash.
 Throws    : No.
 Comments  : None.

See Also   : N/A.

=cut

#------------------------------------------------------------
#  my () = @_;
  my ($lett, $num, $temp);

# Clear dictionary
  @dict_lines = @post_dict_lines = ();

# Read numbers
  %nums = ();
  if (-f $dict_num) {
    open(DICT, $dict_num) || die;
    while (<DICT>) {
      ($lett, $num, $temp) = split;
      $lett =~ s/~//;
      if ($temp) {
	$nums{$temp} = $num;
	push(@dict_lines, [$lett, $temp]);
	push(@post_dict_lines, [$temp, $lett]);
      } else {
	$nums{$lett} = $num;
      }
    }
    close DICT;
    $num_letts = '['. join('', keys %nums). ']';
  }

# Read uppercase words from dictionary
  %is_uc = ();
  if (-f $dict_uc) {
    open(DICT, $dict_uc) || die;
    while (<DICT>) {
      $is_uc{(split())[0]} = 1;
    }
    close DICT;
  }

# Read dictionary
  open(DICT, $dict) || die;
  while (<DICT>) {
    my @arr = (split())[0,2];

# Skip slavonic numbers
    next if ($arr[0] =~ /^.~$/);

# Add word
    $arr[1] = "" unless (defined $arr[1]);
    if ($is_uc{$arr[0]}) {
      $arr[1] = ucfirst($arr[1]);
    }
    $arr[0] =~ s/([\\\$^.*?])/\\$1/g;
#  $arr[0] = qr/$arr[0]/;

# Other cases of the same words
    my @arr_ucf = map {ucfirst} @arr;
    my @arr_uc = map {uc} @arr;

    if ($nums{$arr[0]}) {
      push(@post_dict_lines, \@arr);
      push(@post_dict_lines, \@arr_ucf);
      push(@post_dict_lines, \@arr_uc);
    } else {
      push(@dict_lines, \@arr);
      push(@dict_lines, \@arr_ucf);
      push(@dict_lines, \@arr_uc);
    }

  }

  close DICT;

# Add some special
  push(@dict_lines, ['%<', '']);
  push(@dict_lines, ['%>', '']);

#  print STDERR "dict_lines: ", Dumper(\@dict_lines);

}

