package Font::TTF::Scripts::GDL;

use Font::TTF::Font;
use Font::TTF::Scripts::AP;
use Unicode::Normalize;

use strict;
use vars qw($VERSION @ISA);
@ISA = qw(Font::TTF::Scripts::AP);

$VERSION = "0.04";  # MJPH   19-APR-2006     Add +left_right ap support for compounds
# $VERSION = "0.03";  # MJPH   9-AUG-2005     Support glyph alternates naming (A/u0410), normalization
# $VERSION = "0.02";  # MJPH  26-APR-2004     Add to Font::Scripts::AP hierarchy
# $VERSION = "0.01";  # MJPH   8-OCT-2002     Original based on existing code

*read_font = \&Font::TTF::Scripts::AP::read_font;

sub start_gdl
{
    my ($self, $fh) = @_;
    my ($fname) = $self->{'font'}{'name'}->find_name(4);

    $fh->print("/*\n    Glyph information for font $fname at " . localtime() . "\n*/\n\n");
    $fh->print("table(glyph) {MUnits = $self->{'font'}{'head'}{'unitsPerEm'}};\n");
    $self;
}

sub out_gdl
{
    my ($self, $fh, %opts) = @_;
    my ($f) = $self->{'font'};
    my (%lists, %glyph_names);
    my ($i, $sep, $p, $k, $glyph);

    for ($i = 0; $i < $f->{'maxp'}{'numGlyphs'}; $i++)
    {
        $glyph = $self->{'glyphs'}[$i];
        $fh->print("$glyph->{'name'} = ");
        if ($opts{'-psnames'} && $glyph->{'post'} && $glyph->{'post'} ne '.notdef')
        { $fh->print("postscript(\"$glyph->{'post'}\")"); }
        else
        { $fh->print("glyphid($i)"); }

        my ($ytop) = $f->{'hhea'}->read->{'Ascender'};
        my ($adv) = $f->{'hmtx'}->read->{'advance'}[$i];
        $sep = ' {';
        foreach $p (keys %{$glyph->{'points'}})
        {
            my ($pname) = $p;
            my ($pt) = $glyph->{'points'}{$p};

            if ($pname =~ s/^\+//o)
            {
                my ($pl, $pr) = ($pname =~ m/^([^_]+)(?:_([^_]+))/og);

                if ($opts{'-split_ligs'})
                {
                    if (defined $glyph->{'compunds'}{$pl})
                    { $glyph->{'compounds'}{$pl}[3] = $pt->{'x'}; }
                    else
                    { $glyph->{'compounds'}{$pl} = [0, 0, $pt->{'x'}, $ytop]; }
                    if ($pr)
                    {
                        if (defined $glyph->{'compounds'}{$pr})
                        { $glyph->{'compounds'}{$pr}[0] = $pt->{'x'}; }
                        else
                        { $glyph->{'compounds'}{$pr} = [$pt->{'x'}, 0, $adv, $ytop]; }
                    }
                }
                next;
            }
            $pname .= 'S' unless ($pname =~ s/^_(.*)/${1}M/o);
            $fh->print("$sep$pname = ");
            if (defined $pt->{'cont'})
            { $fh->print("gpath($pt->{'cont'})"); }
            else
            { $fh->print("point($pt->{'x'}m, $pt->{'y'}m)"); }
            $sep = '; ';
        }
        if ($opts{'-split_ligs'})
        {
            my ($oldx) = 0; my ($min) = 0;

            foreach $k (sort grep {m/^component\./o} keys %{$glyph->{'props'}})
            {
                my ($n) = $k;
                $n =~ s/^component\.//o;
                $glyph->{'compounds'}{$n} = [0, 0, $glyph->{'props'}{$k}, $ytop];
            }
            foreach $k (sort {$glyph->{'compounds'}{$a}[2] <=> $glyph->{'compounds'}{$b}[2]} keys %{$glyph->{'compounds'}})
            {
                $glyph->{'compounds'}{$k} = [$oldx, 0, $glyph->{'compounds'}{$k}[2], $glyph->{'compounds'}{$k}[3]];
                $oldx = $glyph->{'compounds'}{$k}[2];
                $min = $k if ($k > $min);
            }
            if (scalar %{$glyph->{'compounds'}} && $oldx < $adv)
            {
                my ($maxx) = $f->{'loca'}->read->{'glyphs'}[$i]{'xMax'};
                if ($oldx < $maxx)          # only add magic compound if some outline not covered
                {
                    $min++;
                    $glyph->{'compounds'}{$min} = [$oldx, 0, $adv, $ytop];
                }
            }
        }
        foreach $k (keys %{$glyph->{'compounds'}})
        {
            $fh->print("${sep}component.$k = box(" . join(", ", map {"${_}m"} @{$glyph->{'compounds'}{$k}}) . ")");
            $sep = '; ';
        }
        foreach $k (keys %{$glyph->{'props'}})
        {
            my ($n) = $k;
            next unless ($n =~ s/^GDL(?:_)?//o);
            $fh->print("$sep$n=$glyph->{'props'}{$k}");
            $sep = '; ';
        }
        $fh->print("}") if ($sep ne ' {');
        $fh->print(";\n");
    }
}

sub out_classes
{
    my ($self, $fh, %opts) = @_;
    my ($f) = $self->{'font'};
    my ($lists) = $self->{'lists'};
    my ($classes) = $self->{'classes'};
    my ($ligclasses) = $self->{'ligclasses'};
    my ($vecs) = $self->{'vecs'};
    my ($glyphs) = $self->{'glyphs'};
    my ($l, $name, $count, $sep, $psname, $cl, $i, $c);

    $fh->print("\n/* Classes */\n");

    foreach $l (sort keys %{$lists})
    {
        my ($name) = $l;

        if ($name !~ m/^_/o)
        { $name = "Takes$name"; }
        else
        { $name =~ s/^_//o; }

        $fh->print("#define HAS_c${name}Dia 1\n") if ($opts{'-defines'} && $name !~ m/^Takes/o);
        $fh->print("c${name}Dia = (");
        $count = 0; $sep = '';
        foreach $cl (@{$lists->{$l}})
        {
    #        next if ($l eq 'LS' && $cl =~ m/g101b.*_med/o);      # special since no - op in GDL
            $fh->print("$sep$glyphs->[$cl]{'name'}");
            if (++$count % 8 == 0)
            { $sep = ",\n    "; }
            else
            { $sep = ", "; }
        }
        $fh->print(");\n\n");

        next unless defined $vecs->{$l};

        $fh->print("cn${name}Dia = (");
        $count = 0; $sep = '';
        for ($c = 0; $c < $f->{'maxp'}{'numGlyphs'}; $c++)
        {
            $psname = $f->{'post'}{'VAL'}[$c];
            next if ($psname eq '' || $psname eq '.notdef');
            next if (vec($vecs->{$l}, $c, 1));
            next if (defined $glyphs->[$c]{'props'}{'GDL_order'} && $glyphs->[$c]{'props'}{'GDL_order'} <= 1);
            next unless (vec($self->{'ismarks'}, $c, 1));
            $fh->print("$sep$glyphs->[$c]{'name'}");
            if (++$count % 8 == 0)
            { $sep = ",\n    "; }
            else
            { $sep = ", "; }
        }
        $fh->print(");\n\n");
    }


    foreach $cl (sort {classcmp($a, $b)} keys %{$classes})
    {
        $fh->print("#define HAS_c$cl 1\n") if ($opts{'-defines'} && $cl !~ m/^no_/o);
        $fh->print("c$cl = ($glyphs->[$classes->{$cl}[0]]{'name'}");
        for ($i = 1; $i <= $#{$classes->{$cl}}; $i++)
        { $fh->print($i % 8 ? ", $glyphs->[$classes->{$cl}[$i]]{'name'}" : ",\n    $glyphs->[$classes->{$cl}[$i]]{'name'}"); }
        $fh->print(");\n\n");
    }

    foreach $cl (sort {classcmp($a, $b)} keys %{$ligclasses})
    {
        $fh->print("#define HAS_clig$cl 1\n") if ($opts{'-defines'} && $cl !~ m/^no_/o);
        $fh->print("clig$cl = ($glyphs->[$ligclasses->{$cl}[0]]{'name'}");
        for ($i = 1; $i <= $#{$ligclasses->{$cl}}; $i++)
        { $fh->print($i % 8 ? ", $glyphs->[$ligclasses->{$cl}[$i]]{'name'}" : ",\n    $glyphs->[$ligclasses->{$cl}[$i]]{'name'}"); }
        $fh->print(");\n\n");
    }

    $self;
}

sub classcmp
{
    my ($x, $y) = @_;
    my ($v, $w) = ($x, $y);
    $v =~ s/^no_//o;
    $w =~ s/^no_//o;
    return ($v cmp $w || $x cmp $y);
}

sub endtable
{
    my ($self, $fh) = @_;

    $fh->print("endtable;\n");
}


sub end_gdl
{
    my ($self, $fh, $include, $defines) = @_;
    my ($k, $v);

    while (($k, $v) = each %$defines)
    {
        $fh->print("\n#define $k $v");
    }
    $fh->print("\n#define MAXGLYPH " . ($self->{'font'}{'maxp'}{'numGlyphs'} - 1) . "\n");
    foreach (@$include)
    {
        $fh->print("\n#include \"$_\"\n");
    }
}

sub make_name
{
    my ($self, $gname, $uni, $glyph) = @_;
    $gname =~ s/[:\(\)\{\}]//g;
    $gname =~ s{/.*$}{}o;
    $gname =~ s/\.(.)/'_'.lc($1)/oge;
    if ($gname =~ m/^u(?:[0-9A-Fa-f]{4,6})/oi)
    { 
        $gname = "g" . lc($gname);
        $gname =~ s/^gu/g/o;
        $gname =~ s/_u/_/og;
    }
    elsif ($gname =~ s/^uni(?=[0-9A-Fa-f]{4})//oi)
    {
        my (@nums) = $gname =~ m/([0-9A-Fa-f]{4})/og;
        $gname =~ s/[0-9A-Fa-f]{4}//og;
        $gname = 'g' . join('_', map {lc($_)} @nums) . $gname;
    }
    else
    {
        $gname = "g_" . $gname;
        $gname =~ s/([A-Z])/"_".lc($1)/oge;
    }
    $gname;
}

sub make_point
{
    my ($self, $p, $glyph) = @_;

    if ($p =~ m/^%([a-z0-9]+)_([a-z0-9]+)$/oi)
    {
        my ($left, $right) = ($1, $2);
        my ($top) = $self->{'font'}{'head'}{'ascent'};
        my ($bot) = $self->{'font'}{'head'}{'descent'};
        my ($adv) = $self->{'font'}{'hmtx'}->read->{'advances'}[$glyph->{'gnum'}];
        my ($split) = $glyph->{'points'}{$p}{'x'};

        $glyph->{'compounds'}{$left} = [0, $bot, $split, $top];
        $glyph->{'compounds'}{$right} = [$split, $bot, $adv, $top];
        return undef;
    }

    return $p;
}

sub normal_rules
{
    my ($self, $fh, $pnum, $ndrawn) = @_;
    my ($g, $struni, $seq, $dseq, $dcomb, @decomp, $d);
    my ($c) = $self->{'cmap'};
    my ($glyphs) = $self->{'glyphs'};

    $fh->print("\ntable(substitution);\npass($pnum);\n");
    foreach $g (@{$self->{'glyphs'}})
    {
        next unless ($ndrawn || $g->{'props'}{'drawn'});
# TODO: should really handle multiple unicode values correctly
        next unless ($c->{$g->{'uni'}[0]} == $g->{'gnum'});
        $struni = pack('U', $g->{'uni'}[0]);
        $seq = NFD($struni);
        next if ($seq eq $struni);
        @decomp = unpack('U*', $seq);
        my ($dok) = 1;
        foreach $d (@decomp)
        { $dok = 0 unless $c->{$d}; }
        next unless $dok;

        $fh->print(join(' ', map {$glyphs->[$c->{$_}]{'name'}} @decomp) . " > $g->{'name'}:(" . join(' ', 1 .. scalar @decomp) . ") " . ("_ " x (scalar @decomp - 1)) . ";\n");

        if (scalar @decomp > 2)
        {
            $fh->print(join(' ', map {$glyphs->[$c->{$_}]{'name'}} @decomp[0, 2, 1]) . " > $g->{'name'}:(1 2 3) _ _;\n");
            $dseq = pack('U*', @decomp[0, 1]);
            $dcomb = NFC($dseq);
            if ($dcomb ne $dseq)
            { $fh->print($glyphs->[$c->{unpack('U', $dcomb)}]{'name'} . " " . $glyphs->[$c->{$decomp[2]}]{'name'} . " > $g->{'name'}:(1 2) _;\n"); }

            $dseq = pack('U*', @decomp[0, 2]);
            $dcomb = NFC($dseq);
            if ($dcomb ne $dseq)
            { $fh->print($glyphs->[$c->{unpack('U', $dcomb)}]{'name'} . " " . $glyphs->[$c->{$decomp[1]}]{'name'} . " > $g->{'name'}:(1 2) _;\n"); }
        }
    }
    $fh->print("endpass;\nendtable;\n");
}

sub lig_rules
{
    my ($self, $fh, $pnum, $type) = @_;
    my ($ligclasses) = $self->{'ligclasses'};
    my ($c, %namemap, $glyph, $name);

    return unless (defined $pnum);
    $fh->print("\ntable(substitution);\npass($pnum);\n");
    if (scalar %$ligclasses)
    {
        foreach $c (grep {!m/^no_/o} keys %{$ligclasses})
        {
            my ($gnum) = $self->{'ligmap'}{$c};
            my ($gname) = $self->{'glyphs'}[$gnum]{'name'};
            my ($compstr);

            if ($self->{'glyphs'}[$ligclasses->{$c}[0]]{'compounds'}{'0'})
            { $compstr = ' {component.0.reference = @1; component.1.reference = @2}'; }

            if ($type eq 'first')
            { $fh->print("$gname cligno_$c > _ clig$c:(1 2)$compstr / _ ^ _;\n"); }
            else
            { $fh->print("cligno_$c $gname > clig$c:(1 2)$compstr _ / ^ _ _;\n"); }

        }
    }

    foreach $glyph (@{$self->{'glyphs'}})
    {
        foreach $name (split('/', $glyph->{'post'}))
        { $namemap{$name} = $glyph; }
    }
    foreach $glyph (@{$self->{'glyphs'}})
    {
        foreach $name (split('/', $glyph->{'post'}))
        {
            my ($ext, $base, @elem) = $self->split_lig($name, $type, '');
            next if ($ext || scalar @elem < 3);
            my ($islig) = 1;
            my (@parts, $e, $g);
            my ($class, $oglyph);
            if ($type eq 'first')
            { $class = $elem[0]; }
            else
            {
                $class = $elem[-1];
                $class =~ s/^_//g;
            }
            $class =~ s/\./_/g;
            $oglyph = $namemap{$base};

            foreach $e (@elem)
            {
                my ($n) = $e;
                my ($g);
                $n =~ s/_//g;
                foreach ($n, "uni$n", "u$n")
                {
                    if ($g = $namemap{$_})
                    { last; }
                }
                if (!$g)
                {
                    $islig = 0;
                    last;
                }
                else
                {
                    push(@parts, $g->{'name'});
                }
            }
            next if (!$islig);
            $fh->print(join(" ", @parts) . " > " . $glyph->{'name'} . ":(" . join(" ", 1 .. ($#parts + 1)) . ") " . join(" ", ("_") x (@parts - 1)) . ";\n");
        }
    }
    $fh->print("endpass;\nendtable;\n");
}

sub pos_rules
{
    my ($self, $fh, $pnum) = @_;
    my ($lists) = $self->{'lists'};
    my ($p);

    return unless (keys %$lists);
    $fh->print(<<'EOT');

#ifndef opt2
#define opt(x)      [x]?
#define opt2(x)     [opt(x) x]?
#define opt3(x)     [opt2(x) x]?
#define opt4(x)     [opt3(x) x]?
#endif
EOT
    $fh->print("\ntable(positioning);\npass($pnum);\n");
    foreach $p (keys %{$lists})
    {
        next if ($p =~ m/^_/o);
        $fh->print("cTakes${p}Dia c${p}Dia {attach {to = \@1; at = ${p}S; with = ${p}M}; user1 = 1} / ^ _ opt4(cnTakes${p}Dia) _ {user1 == 0};\n");
    }
    $fh->print("endpass;\nendtable;\n");
}

sub has
{
    my ($cls, $val) = @_;
    foreach (@{$cls})
    { return 1 if ($_ == $val); }
    return 0;
}