#!/usr/bin/env perl
use strict;
use warnings;
use 5.020;
use utf8;
use open ':std',':locale';
use List::AllUtils qw(uniq natatime);
use HTML::Tiny;
use HTML::Entities;
use Unicode::UCD qw(charinfo);
use Unicode::Normalize;

my $COLUMNS = 5;

sub parse_compose_file {
    my ($fn) = @_;
    $fn //= $ENV{HOME}.'/.XCompose';

    open my $fh, '<:utf8', $fn;
    my @ret;
    while (my $line = <$fh>) {
        $line =~ s{#.*\z}{}sm;

        if ($line =~ m{^include \s* "(.+?)"}x) {
            my $file = $1;
            $file =~ s{%L}{/usr/share/X11/locale/$ENV{LC_ALL}/Compose}g;
            push @ret, parse_compose_file($file);
        }
        elsif ($line =~ m{<Multi_key>}) {
            my ($keys,$output) = split /:/,$line;
            unless ($keys && $output) {
                warn "<$line>";
                next;
            }
            my @keys = $keys =~ m{<(.+?)>}g;
            $output =~ s{\A \s* "(.+?)" .* \z}{$1}smx;
            $output = NFC($output);
            warn sprintf "%s %d <%s> [%s] %d %s\n",
                $fn, $.,
                join(' ',@keys),
                $output,length($output),
                join(' ',map { sprintf 'U+%04X', ord($_) } split //,$output);
            push @ret, [$output,@keys];
        }
    }
    return @ret;
}

sub sort_it {
    sort { $a->[0] cmp $b->[0] } @_
}

sub extract_collisions {
    my %same_output;
    my %same_input;
    for my $mapping (@_) {
        my ($input,$output) = @{$mapping};
        push @{$same_input{$input}},$output;
        push @{$same_output{$output}},$input;
    }
    for my $h (\%same_input,\%same_output) {
        for my $i (keys %$h) {
            @{$h->{$i}} = uniq @{$h->{$i}};
            delete $h->{$i} if @{$h->{$i}} < 2;
        }
    }
    return (\%same_input,\%same_output);
}

my %glyph = (
    acute => '`',
    ampersand => '&',
    apostrophe => q{'},
    asciicircum => '^',
    asciitilde => '~',
    asterisk => '*',
    at => '@',
    backslash => '\\',
    BackSpace => '␈',
    bar => '|',
    braceleft => '{',
    braceright => '}',
    bracketleft => '[',
    bracketright => ']',
    colon => ':',
    comma => ',',
    division => '/',
    dollar => '$',
    Down => '↓',
    equal => '=',
    exclam => '!',
    grave => q{'},
    greater => '>',
    Left => '←',
    less => '<',
    minus => '-',
    Multi_key => '⌥',
    numbersign => '#',
    parenleft => '(',
    parenright => ')',
    percent => '%',
    period => '.',
    plus => '+',
    question => '?',
    quotedbl => '"',
    Right => '→',
    semicolon => ';',
    slash => '/',
    space => '␣',
    tilde => '~',
    underscore => '_',
    Up => '↑',
    KP_1 => '1⃣',
    KP_2 => '2⃣',
    KP_3 => '3⃣',
    KP_4 => '4⃣',
    KP_5 => '5⃣',
    KP_6 => '6⃣',
    KP_7 => '7⃣',
    KP_8 => '8⃣',
    KP_9 => '9⃣',
    KP_0 => '0⃣',
    #KP_Space => '␣⃣', # this seems to be used as equivalent to KP_2
    KP_Equal => '=⃣',
    KP_Divide => '/⃣',
    KP_Add => '+⃣',
    KP_Multiply => '*⃣',
);

sub to_presentation_form {
    map {
        my ($output, @keys) = @$_;
        my $unmapped=0;
        @keys = map {
            length($_)==1
                ? $_
                : ($glyph{$_} // do { warn "What's a <$_>??";++$unmapped });
        } @keys;
        if ($unmapped) {
            ();
        }
        else {
            [(join '',@keys),$output];
        }
    } @_;
}

sub fill_table {
    my @rows;
    my $it = natatime $COLUMNS,@_;
    while (my @row_data = $it->()) {
        push @rows,[ \'tr', [
            map {
                my ($sequence, $output) = @{$_};
                my @infos;
                if ($output =~ /\s|\P{Print}/) {
                    my @points = split //,$output;
                    for my $p (@points) {
                        my $info = charinfo(ord($p));
                        if ($info) {
                            push @infos, lc($info->{name});
                        }
                        else {
                            warn sprintf 'no charinfo for %s (%04X)',
                                $p,ord($p);
                        }
                    }
                }

                (
                    [ \'th', {class=>'key'}, encode_entities($sequence), ],
                    [ \'td', {class=>'out'}, [
                        [\'span', {class=>'out'}, encode_entities($output), ],
                        (@infos
                             ? [ \'span',{class=>'info'}, encode_entities("(@infos)") ]
                             : ()
                         ),
                    ] ],
                );
            } @row_data
        ] ];
    }

    return [ \'table', [
        @rows,
    ] ];
}

sub show_collisions {
    my @kind = qw(input output);
    my %same; @same{@kind} = @_;
    map {
        my $kind = $_;
        [ \'div', [
            [ \'h2', "\u$kind collisions" ],
            [ \'dl', [
                map {
                    [ \'dt', $_ ],
                        map { [ \'dd', $_ ] } sort @{$same{$kind}->{$_}}
                    } sort keys %{$same{$kind}}
                ] ],
        ] ];
    } @kind;
}

my $css = <<'CSS';
table {
 width: 100%;
 border-collapse: collapse;
 font-size: x-large;
}
td, th {
 text-align: left;
 border-top: solid thin black;
 vertical-align: baseline;
}
td {
 border-right: solid thin black;
 padding: 0.2em;
}
th {
 font-weight: normal;
 font-family: monospace;
 white-space: pre-line;
}
span.out {
 border: dotted thin black;
 padding: 0.1em;
}
span.info {
  margin-left: 0.5em;
  font-size: 50%;
}
CSS

my @data = to_presentation_form sort_it parse_compose_file;

print HTML::Tiny->new->html([
    [\'head',[
        [\'meta', {'http-equiv'=>'Content-Type',content=>'text/html;charset=utf-8'}],
        [\'style',$css],
        [\'title','Compose mappings']
    ] ],
    [ \'body', [
        (fill_table @data),
        (show_collisions extract_collisions @data),
    ] ],
]);