#!/usr/bin/env perl
use v5.28;
use warnings;
use utf8;
use autodie qw(:all);
use experimental qw(signatures);
use IO::Uncompress::Unzip;

=encoding UTF-8

=head1 NAME

gen-guch-unicode-tables.pl - Generate gucharmap unicode header files

=head1 SYNOPSIS

    gen-guch-unicode-tables.pl [datadir]

=head1 ARGUMENTS

B<datadir>: should point to where the UCD data tables are on your system.
If omitted, defaults to C</usr/share/unicode-data>.

=head1 DESCRIPTION

This script parses Unicode data tables and generates gucharmap's header files.
The following files will be written (or overwritten) in the current working directory:

 - unicode-blocks.h
 - unicode-names.h
 - unicode-nameslist.h
 - unicode-unihan.h
 - unicode-categories.h
 - unicode-scripts.h
 - unicode-versions.h

The data directory needs to contain at least the following files:

 - Blocks.txt
 - DerivedAge.txt
 - NamesList.txt
 - Scripts.txt
 - UnicodeData.txt
 - Unihan.zip

=head1 DEPENDENCIES

L<IO::Uncompress::Unzip> is needed for Unihan.zip

=head1 COPYRIGHT

    Copyright © 2018 flussence <flussence+i7fOaGgE@flussence.eu>
    Derived from the gucharmap 10.0.0 gen-guch-unicode-tables.pl script
     - © the gucharmap authors

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.

=cut

sub MAIN {
    { my $oldfh = select(STDERR); $| = 1; select($oldfh); binmode(STDERR, ':utf8'); }

    my $data_dir = shift(@ARGV) // q{/usr/share/unicode-data};
    my %directory = (
        "$data_dir/Blocks.txt"      => \&process_blocks_txt,
        "$data_dir/NamesList.txt"   => \&process_nameslist_txt,
        "$data_dir/Scripts.txt"     => \&process_scripts_txt,
        "$data_dir/UnicodeData.txt" => \&process_unicode_data_txt,
        "$data_dir/DerivedAge.txt"  => \&process_derived_age_txt,
        "$data_dir/Unihan.zip"      => \&process_unihan_zip,
    );

    for ( keys %directory ) {
        next if -r;
        eval { require Pod::Usage; };
        if ($@) {
            sub pod2usage { die $_[1] };
        }
        pod2usage(-message => "File '$_' is missing or not readable", -exitval => 1);
    }

    while ( my ($filename, $func) = each(%directory) ) {
        print STDERR "Processing $filename… ";

        open(my $fh_in, q{<}, $filename);
        $func->($fh_in);
        close($fh_in);

        say STDERR 'done.';
    }
}

MAIN;
exit;

sub new_headerfile($filename, $extra_header = '') {
    print STDERR "creating $filename… ";

    open(my $fh_out, q{>}, $filename);
    my $guard_define = uc($filename =~ tr[a-z][_]cr);

    print $fh_out <<~"EOT", $extra_header;
    /* $filename
     * This file was generated by $0
     * Changes will be overwritten
     */

    #ifndef $guard_define
    #define $guard_define

    #include <glib.h>
    #include <glib/gi18n-lib.h>

    EOT

    return $fh_out, sub {
        print $fh_out <<~"EOT";
        };

        #endif  /* #ifndef $guard_define */
        EOT

        close($fh_out);
    }
}

#------------------------#

sub process_unicode_data_txt($fh_unicode_data_txt) {
    my ($fh_cats_h, $eof) = new_headerfile 'unicode-categories.h', <<~EOT;
    typedef struct _UnicodeCategory UnicodeCategory;

    static const struct _UnicodeCategory
    {
      gunichar start;
      gunichar end;
      GUnicodeType category;
    }
    unicode_categories[] =
    {
    EOT

    # Map general category code onto symbolic name.
    my %mappings = (
        # Normative.
        'Lu' => "G_UNICODE_UPPERCASE_LETTER",
        'Ll' => "G_UNICODE_LOWERCASE_LETTER",
        'Lt' => "G_UNICODE_TITLECASE_LETTER",
        'Mn' => "G_UNICODE_NON_SPACING_MARK",
        'Mc' => "G_UNICODE_SPACING_MARK",
        'Me' => "G_UNICODE_ENCLOSING_MARK",
        'Nd' => "G_UNICODE_DECIMAL_NUMBER",
        'Nl' => "G_UNICODE_LETTER_NUMBER",
        'No' => "G_UNICODE_OTHER_NUMBER",
        'Zs' => "G_UNICODE_SPACE_SEPARATOR",
        'Zl' => "G_UNICODE_LINE_SEPARATOR",
        'Zp' => "G_UNICODE_PARAGRAPH_SEPARATOR",
        'Cc' => "G_UNICODE_CONTROL",
        'Cf' => "G_UNICODE_FORMAT",
        'Cs' => "G_UNICODE_SURROGATE",
        'Co' => "G_UNICODE_PRIVATE_USE",
        'Cn' => "G_UNICODE_UNASSIGNED",

        # Informative.
        'Lm' => "G_UNICODE_MODIFIER_LETTER",
        'Lo' => "G_UNICODE_OTHER_LETTER",
        'Pc' => "G_UNICODE_CONNECT_PUNCTUATION",
        'Pd' => "G_UNICODE_DASH_PUNCTUATION",
        'Ps' => "G_UNICODE_OPEN_PUNCTUATION",
        'Pe' => "G_UNICODE_CLOSE_PUNCTUATION",
        'Pi' => "G_UNICODE_INITIAL_PUNCTUATION",
        'Pf' => "G_UNICODE_FINAL_PUNCTUATION",
        'Po' => "G_UNICODE_OTHER_PUNCTUATION",
        'Sm' => "G_UNICODE_MATH_SYMBOL",
        'Sc' => "G_UNICODE_CURRENCY_SYMBOL",
        'Sk' => "G_UNICODE_MODIFIER_SYMBOL",
        'So' => "G_UNICODE_OTHER_SYMBOL",
    );

    # State vars for unicode-categories.h
    my %cat_range = (category => '');

    # Accumulators for unicode-names.h
    my @unicode_pairs;
    my %names;

    while ( <$fh_unicode_data_txt> ) {
        /(?^nx)
        ^ (?<codepoint>[[:xdigit:]]{4,6})
        ; (?<name>[^;]+)
        ; (?<category>[^;]+)
        ; / or die 'Malformed input';
        $_ = $+{name}; # preserve for bottom of block

        # Fill unicode-categories.h with contiguous spans of a given category
        # This file is binary searched to look up a letter's category
        if ( $+{category} ne $cat_range{category} ) {
            if ( $cat_range{prev} ) {
                say $fh_cats_h sprintf('0x%s, %s },',
                    $cat_range{prev}, $mappings{$cat_range{category}});
            }

            print $fh_cats_h "  { 0x$+{codepoint}, ";
            %cat_range = (start => $+{codepoint}, category => $+{category});
        }

        $cat_range{prev} = $+{codepoint};

        # Accumulate lookup table for unicode-names.h, skipping items where:
        # - The names are programmatically generated to begin with
        #   (The program reconstructs these at runtime)
        # - Unwanted lines
        unless (
            /(?^nx) ^
            ( ( CJK \s (UNIFIED|COMPATIBILITY)
              | TANGUT
              ) \s IDEOGRAPH-[[:xdigit:]]{4,6}
            | TANGUT \s COMPONENT-[0-9]+
            | <.+, \s (First|Last)>
            ) $ /
        ) {
            $names{$_}++;
            push @unicode_pairs, [@+{qw{codepoint name}}];
        }
    }
    say $fh_cats_h sprintf('0x%s, %s },', $cat_range{prev}, $mappings{$cat_range{category}});

    $eof->();

    write_unicode_names(\%names, \@unicode_pairs);
}

sub write_unicode_names($names, $unicode_pairs) {
    my ($fh_names_h, undef) = new_headerfile 'unicode-names.h', <<~EOT;
    static const char unicode_names_strings[] =
    EOT

    my $offset = 0;
    for ( sort keys %$names ) {
        say $fh_names_h qq{  "$_\\0"};
        $names->{$_} = $offset;
        $offset += 1 + length($_);
    }

    print $fh_names_h <<~EOT;
    ;
    typedef struct _UnicodeName UnicodeName;

    static const struct _UnicodeName
    {
      gunichar index;
      guint32 name_offset;
    }
    unicode_names[] =
    {
    EOT

    say $fh_names_h "  {0x$_->[0], $names->{$_->[1]}},"
        for @$unicode_pairs;

    print $fh_names_h <<~EOT;
    };

    static inline const char * unicode_name_get_name(const UnicodeName *entry)
    {
      guint32 offset = entry->name_offset;
      return unicode_names_strings + offset;
    }

    #endif  /* #ifndef UNICODE_NAMES_H */
    EOT
}

#------------------------#

sub process_nameslist_txt($fh_nameslist_txt) {
    my %counters = do { no warnings 'qw'; map { $_ => 0 } qw(= * # : x) };
    my $nameslist_hash;

    LINE: while ( <$fh_nameslist_txt> ) {
        state $wc = 0;

        if ( /^@\+/ ) {
            # multiline comment continuation
            while ( <$fh_nameslist_txt> ) {
                next if /^\t/;
                redo LINE;
            }
        }
        elsif ( /^@/ ) {
            next;
        }
        elsif ( /(?^nx) ^ (?<value>[[:xdigit:]]{4,6}) / ) {
            $wc = hex($+{value});
        }
        elsif (
            /(?^nx) ^
            ( \s+ (?<token>[=*#:]) \s+     (?<value>.+)
            | \s+ (?<token>x)      \s+ .*? (?<value>[[:xdigit:]]{4,6}) \)
            ) $ /
        ) {
              my $hash = $nameslist_hash->{$wc}{$+{token}} //= {};
                 $hash->{index} //= $counters{$+{token}};
            push $hash->{values}->@*, ($+{token} eq 'x' ? hex($+{value}) : $+{value});
            $counters{$+{token}}++;
        }
    }

    my ($fh_names_h, $eof) = new_headerfile 'unicode-nameslist.h', <<~EOT;
    typedef struct _UnicharStringIndex UnicharStringIndex;
    typedef struct _UnicharUnichar UnicharUnichar;
    typedef struct _NamesList NamesList;

    struct _UnicharStringIndex
    {
      gunichar index;
      guint32 string_index;
    };

    struct _UnicharUnichar
    {
      gunichar index;
      gunichar value;
    };

    struct _NamesList
    {
      gunichar index;
      gint16 equals_index;  /* -1 means */
      gint16 stars_index;   /* this character */
      gint16 exes_index;    /* doesn't */
      gint16 pounds_index;  /* have any */
      gint16 colons_index;
    };

    EOT

    print_names_list($fh_names_h, $nameslist_hash, @$_)
        for ( [equals => '='], [stars  => '*'], [pounds => '#'], [colons => ':'] );

    print $fh_names_h <<~EOT;
    static const UnicharUnichar names_list_exes[] =
    {
    EOT

    for my $wc ( sort {$a <=> $b} keys %$nameslist_hash ) {
        my $hash = $nameslist_hash->{$wc};
        next if not exists $hash->{x};
        for ( $hash->{x}{values}->@* ) {
            say $fh_names_h sprintf('  { 0x%04X, 0x%04X },', $wc, $_);
        }
    }

    print $fh_names_h <<~EOT;
      { (gunichar)(-1), 0 }
    };

    static const NamesList names_list[] =
    {
    EOT

    for my $wc ( sort {$a <=> $b} keys %$nameslist_hash ) {
        my $hash = $nameslist_hash->{$wc};
        say $fh_names_h sprintf('  { 0x%04X, %d, %d, %d, %d, %d },',
            $wc, do { no warnings 'qw'; map { $hash->{$_}{index} // -1 } qw(= * x # :) });
    }

    $eof->();
}

sub print_names_list($fh_names_h, $nameslist_hash, $variable_name, $token) {
    print $fh_names_h <<~"EOT";
    static const char names_list_${variable_name}_strings[] =
    EOT

    my @names_pairs;
    my %names_offsets;
    my $offset = 0;
    for my $wc ( sort { $a <=> $b } keys %$nameslist_hash ) {
        my $hash = $nameslist_hash->{$wc};
        next unless exists $hash->{$token};

        for my $value ( $hash->{$token}{values}->@* ) {
            push @names_pairs, [sprintf('%04X', $wc), $value];
            next if exists $names_offsets{$value};

            my $print_value = $value =~ s/\\/\\\\/gr =~ s/\"/\\"/gr;

            say $fh_names_h qq{  "$print_value\\0"};
            $names_offsets{$value} = $offset;
            $offset += 1 + length($value);
        }
    }

    print $fh_names_h <<~"EOT";
      ;

    static const UnicharStringIndex names_list_${variable_name}[] =
    {
    EOT

    say $fh_names_h "  { 0x$_->[0], $names_offsets{$_->[1]} },"
        for @names_pairs;

    say $fh_names_h <<~EOT;
      { (gunichar)(-1), 0 } /* end marker */
    };
    EOT
}

#------------------------#

sub process_blocks_txt($fh_blocks_txt) {
    my ($fh_blocks_h, $eof) = new_headerfile 'unicode-blocks.h', <<~EOT;
    static const char unicode_blocks_strings[] =
    EOT

    my @blocks;
    my %block_renames = (
      NKo => q{N'Ko}
    );

    my $offset = 0;
    while ( <$fh_blocks_txt> ) {
        next unless /(?^nx)
            ^ (?<start>[[:xdigit:]]{4,6}) \.\. (?<end>[[:xdigit:]]{4,6})
            ; \s (?<block>.+)
            $ /;

        my $block_name = $block_renames{$+{block}} // $+{block};

        say $fh_blocks_h qq{  "$block_name\\0"};
        push @blocks, [@+{qw{start end}}, $offset];
        $offset += 1 + length($block_name);
    }

    print $fh_blocks_h <<~EOT;
      ;

    typedef struct _UnicodeBlock UnicodeBlock;

    static const struct _UnicodeBlock
    {
      gunichar start;
      gunichar end;
      guint16 block_name_index;
    }
    unicode_blocks[] =
    {
    EOT

    say $fh_blocks_h sprintf('  { 0x%s, 0x%s, %d },', @$_) for @blocks;

    $eof->();
}

#------------------------#

sub process_scripts_txt($fh_scriptstxt) {
    my @script_list;
    my %scripts;
    my %script_renames = (
      Nko => q{N'Ko}
    );

    while ( <$fh_scriptstxt> ) {
        next unless /(?^nx)
            ^ (?<start>[[:xdigit:]]{4,6})
              ( \.\. (?<end>[[:xdigit:]]{4,6}) )? \s+
            ; \s+ (?<raw_script>\S+) /;

        my @values = @+{qw{start end raw_script}};
        push @script_list, \@values;
        $values[1] //= $+{start};

        # Format for display: underscores to spaces and titlecase, then apply renames
        my $mangled = $values[2] =~ tr[_][ ]r =~ s/(\w+)/\u\L$1/gr;
        $values[2] = $script_renames{$mangled} // $mangled;

        $scripts{$values[2]}++;
    }

    my ($fh_scripts, $eof) = new_headerfile 'unicode-scripts.h', <<~EOT;
    typedef struct _UnicodeScript UnicodeScript;

    static const gchar unicode_script_list_strings[] =
    EOT

    # Write alphabetised list of scripts
    my $offset = 0;
    for ( sort keys %scripts ) {
        say $fh_scripts qq{  "$_\\0"};
        $scripts{$_} = [$offset, (state $i++)];
        $offset += 1 + length($_);
    }

    print $fh_scripts <<~EOT;
      ;

    static const guint16 unicode_script_list_offsets[] =
    {
    EOT

    say $fh_scripts sprintf('  %d,', $scripts{$_}[0])
        for sort keys %scripts;

    print $fh_scripts <<~EOT;
    };

    static const struct _UnicodeScript
    {
      gunichar start;
      gunichar end;
      guint8 script_index;   /* index into unicode_script_list_offsets */
    }
    unicode_scripts[] =
    {
    EOT

    say $fh_scripts sprintf('  { 0x%s, 0x%s, %2d },',
        $_->@[0,1], $scripts{$_->[2]}[1])
        for sort { hex $a->[0] <=> hex $b->[0] } @script_list;

    $eof->();
}

#------------------------#

sub process_derived_age_txt($fh_derived_age_txt) {
    my @version_list;
    my %versions;

    while ( <$fh_derived_age_txt> ) {
        next unless /(?^nx)
            ^ (?<start>[[:xdigit:]]{4,6})
              ( \.\. (?<end>[[:xdigit:]]{4,6}) )? \s+
            ; \s+ (?<version>[0-9.]+) /;

        push @version_list, my $tail = [@+{qw{start end version}}];
        $tail->[1] //= $+{start};
        $versions{$+{version}}++;
    }

    my ($fh_versions_h, $eof) = new_headerfile 'unicode-versions.h', <<~EOT;
    typedef struct {
      gunichar start;
      gunichar end;
      GucharmapUnicodeVersion version;
    } UnicodeVersion;

    static const UnicodeVersion unicode_versions[] =
    {
    EOT

    say $fh_versions_h sprintf('  { 0x%s, 0x%s, GUCHARMAP_UNICODE_VERSION_%s },',
        $_->@[0,1], $_->[2] =~ tr[.][_]r)
        for sort { hex $a->[0] <=> hex $b->[0] } @version_list;

    print $fh_versions_h  <<~EOT;
    };

    static const gchar unicode_version_strings[] =
    EOT

    my $offset = 0;
    for ( sort { $a <=> $b } keys %versions ) {
        say $fh_versions_h qq{  "$_\\0"};
        $versions{$_} = [$offset, (state $i++)];
        $offset += 1 + length($_);
    }

    print $fh_versions_h <<~EOT;
      ;

    static const guint16 unicode_version_string_offsets[] =
    {
    EOT

    say $fh_versions_h sprintf('  %d,', $versions{$_}[0])
        for sort { $a <=> $b } keys %versions;

    $eof->();
}

#------------------------#

# XXX should do kFrequency too
sub process_unihan_zip($fh_unihan_zip) {
    print STDERR '(please be patient, this step will take a while) ';

    my @keys = qw<
        kDefinition
        kCantonese kMandarin kTang kKorean
        kJapaneseKun kJapaneseOn kHangul kVietnamese
    >;
    my $keys_regex   = join(q{|}, map { quotemeta } @keys);
    my $stats_format = q[  { 0x%s].(q[, %d] x @keys).q[ },];

    my ($fh_unihan_h, $eof) = new_headerfile 'unicode-unihan.h', <<~EOT;
    typedef struct _Unihan Unihan;

    static const struct _Unihan
    {
      gunichar index;
    EOT

    say $fh_unihan_h "  gint32 $_;" for @keys;

    print $fh_unihan_h <<~EOT;
    }
    unihan[] =
    {
    EOT

    my @strings;
    my $offset = 0;
    my $wc = 0;
    my %stats;

    my $zip = IO::Uncompress::Unzip->new($fh_unihan_zip, MultiStream => 1);

    while ( <$zip> ) {
        next unless /(?^nx)
                    ^ U\+(?<codepoint>[[:xdigit:]]{4,6})
                    \s+ (?<field>$keys_regex)
                    \s+ (?<value>.+)
                    $ / or $zip->eof;

        if ( $zip->eof or $+{codepoint} ne $wc ) {
            say $fh_unihan_h sprintf($stats_format, $wc, (map { $stats{$_} // -1 } @keys))
                if %stats;

            last if $zip->eof;

            $wc = $+{codepoint};
            %stats = ();
        }

        push @strings, $+{value};
        my $last_offset = $offset;
        $offset += 1 + length($+{value});
        $stats{$+{field}} = $last_offset;
    }

    print $fh_unihan_h <<~EOT;
    };

    static const char unihan_strings[] =
    EOT

    say $fh_unihan_h qq{  "$_\\0"} for @strings;

    print $fh_unihan_h <<~EOT;
    ;

    static const Unihan *_get_unihan (gunichar uc)
    ;
    EOT

    for my $name ( @keys ) {
        say $fh_unihan_h <<~"EOT";
        static inline const char * unihan_get_$name (const Unihan *uh)
        {
            gint32 offset = uh->$name;
            if (offset == -1)
              return NULL;
            return unihan_strings + offset;
        }

        const gchar * 
        gucharmap_get_unicode_$name (gunichar uc)
        {
          const Unihan *uh = _get_unihan (uc);
          if (uh == NULL)
            return NULL;
          else
            return unihan_get_$name (uh);
        }
        EOT
    }

    print $fh_unihan_h <<~EOT;
    #endif  /* #ifndef UNICODE_UNIHAN_H */
    EOT
}
