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

use Font::TTF::Font;
use XML::Parser::Expat;

use strict;
use vars qw($VERSION);

$VERSION = "0.01";  # MJPH   8-OCT-2002     Original based on existing code

$Font::Post::base_set[2] = 'CR';

sub read_font
{
    my ($class, $fname, $xml_file, %opts) = @_;
    my (@glyphs, $f, $t, $xml, $cur_glyph, $cur_pt);
    my ($self) = {};
    bless $self, ref $class || $class;

    $f = Font::TTF::Font->open($fname) || die "Can't open font $fname";
    foreach $t (qw(post cmap loca name))
    { $f->{$t}->read; }

    $self->{'font'} = $f;
    $self->{'cmap'} = $f->{'cmap'}->find_ms->{'val'} || die "Can't find Unicode table in font $fname";

    $xml = XML::Parser::Expat->new();
    $xml->setHandlers('Start' => sub {
        my ($xml, $tag, %attrs) = @_;
    
        if ($tag eq 'glyph')
        {
            my ($ug, $pg, $ig, $glyph);
            $cur_glyph = {%attrs};
            undef $cur_pt;
    
            if (defined $attrs{'UID'})
            {
                my ($uni) = hex($attrs{'UID'});
                $ug = $self->{'cmap'}{$uni};
                error($xml, $cur_glyph, undef, "No glyph associated with UID $attrs{'UID'}") unless (defined $ug);
                $cur_glyph->{'gnum'} = $ug;
                $cur_glyph->{'uni'} = $uni;
                delete $attrs{'UID'};
            }
            if (defined $attrs{'PSName'})
            {
                $pg = $f->{'post'}{'STRINGS'}{$attrs{'PSName'}};
                error($xml, $cur_glyph, undef, "No glyph associated with postscript name $attrs{'PSName'}") unless (defined $pg);
                error($xml, $cur_glyph, undef, "Postscript name: $attrs{'PSName'} resolves to different glyph to Unicode ID: $attrs{'UID'}")
                        if (defined $attrs{'UID'} && $pg != $ug);
                $cur_glyph->{'gnum'} ||= $pg;
                delete $attrs{'PSName'};
            }
            if (defined $attrs{'GID'})
            {
                $ig = $attrs{'GID'};
                error($xml, $cur_glyph, undef, "Specified glyph id $attrs{'GID'} different to glyph of Unicode ID: $attrs{'UID'}")
                        if (defined $attrs{'UID'} && $ug != $ig);
                error($xml, $cur_glyph, undef, "Specified glyph id $attrs{'GID'} different to glyph of postscript name $attrs{'PSName'}")
                        if (defined $attrs{'PSName'} && $pg != $ig);
                $cur_glyph->{'gnum'} ||= $ig;
                delete $attrs{'GID'};
            }
    
            if ($glyph = $f->{'loca'}{'glyphs'}[$cur_glyph->{'gnum'}])
            {
                $cur_glyph->{'glyph'} = $glyph;
                $cur_glyph->{'glyph'}->read_dat;
                if ($cur_glyph->{'glyph'}{'numberOfContours'} > 0)
                { $cur_glyph->{'props'}{'drawn'} = 1; }
                $cur_glyph->{'glyph'}->get_points;
            }
            $cur_glyph->{'post'} = $f->{'post'}{'VAL'}[$cur_glyph->{'gnum'}];
            $self->{'glyphs'}[$cur_glyph->{'gnum'}] = $cur_glyph;
            foreach (keys %attrs)
            { $cur_glyph->{$_} = $attrs{$_}; }
        } elsif ($tag eq 'point')
        {
            $cur_pt = {'name' => $attrs{'type'}};
            $cur_glyph->{'points'}{$attrs{'type'}} = $cur_pt;
        } elsif ($tag eq 'contour')
        {
            my ($cont) = $attrs{'num'};
            my ($g) = $cur_glyph->{'glyph'} || return;
            
            error($xml, $cur_glyph, $cur_pt, "Specified contour of $cont different from calculated contour of $cur_pt->{'cont'}")
                    if (defined $cur_pt->{'cont'} && $cur_pt->{'cont'} != $attrs{'num'});
                 
            if (($cont == 0 && $g->{'endPoints'}[0] != 0)
                || ($cont > 0 && $g->{'endPoints'}[$cont-1] + 1 != $g->{'endPoints'}[$cont]))
            { error($xml, $cur_glyph, $cur_pt, "Contour $cont not a single point path"); }
            else
            { $cur_pt->{'cont'} = $cont; }
            
            $cur_pt->{'x'} = $g->{'x'}[$g->{'endPoints'}[$cont]];
            $cur_pt->{'y'} = $g->{'y'}[$g->{'endPoints'}[$cont]];
        } elsif ($tag eq 'location')
        {
            my ($x) = $attrs{'x'};
            my ($y) = $attrs{'y'};
            my ($g) = $cur_glyph->{'glyph'};
            my ($cont, $i);
    
            error($xml, $cur_glyph, $cur_pt, "Specified location of ($x, $y) different from calculated location ($cur_pt->{'x'}, $cur_pt->{'y'})")
                    if (defined $cur_pt->{'x'} && ($cur_pt->{'x'} != $x || $cur_pt->{'y'} != $y));
            
            if ($g)
            {
                for ($i = 0; $i < $g->{'numPoints'}; $i++)
                {
                    if ($g->{'x'}[$i] == $x && $g->{'y'}[$i] == $y)
                    {
                        for ($cont = 0; $cont <= $#{$g->{'endPoints'}}; $cont++)
                        {
                            last if ($g->{'endPoints'}[$cont] > $i);
                        }
                    }
                }
                if ($g->{'x'}[$i] != $x || $g->{'y'}[$i] != $y)
                { error($xml, $cur_glyph, $cur_pt, "No glyph point at specified location ($x, $y)") if ($opts{'-strictap'}); }
                if (($cont == 0 && $g->{'endPoints'}[0] != 0)
                    || $g->{'endPoints'}[$cont-1] + 1 != $g->{'endPoints'}[$cont])
                { error($xml, $cur_glyph, $cur_pt, "Calculated contour $cont not a single point path") if ($opts{'-strictap'}); }
                else
                { $cur_pt->{'cont'} = $cont; }
            }
            
            $cur_pt->{'x'} = $x unless defined $cur_pt->{'x'};
            $cur_pt->{'y'} = $y unless defined $cur_pt->{'y'};
        } elsif ($tag eq 'property')
        {
            $cur_glyph->{'props'}{$attrs{'name'}} = $attrs{'value'};
        }
    });

    $xml->parsefile($xml_file) || return warn "Can't open $xml_file";
    $self;
}

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) = @_;
    my ($f) = $self->{'font'};
    my ($glyphs) = $self->{'glyphs'};
    my (%lists, %glyph_names);
    my ($u, @revmap, $gname, $i, $sep, $p, $pname, $pt, $k);
    
#    foreach $u (keys %{$c})
#    { @revmap[$c->{$u}] = $u; }

    for ($i = 0; $i < $f->{'maxp'}{'numGlyphs'}; $i++)
    {
        $gname = make_name($f->{'post'}{'VAL'}[$i]);
    
    #    while (defined $glyph_names{$gname})
    #    { $gname =~ s/(?:_(\d{3})|)$/sprintf("%03d", $1)/oe; }
        $glyph_names{$gname} = $i;
        $fh->print("$gname = ");
    #    if ($revmap[$i])
    #    { printf OUT "unicode(0x%04X)", $revmap[$i]; }
    #    elsif ($i > 1)
    #    if ($i > 1)
    #    { $fh->print("postscript(\"$psname\")"; }
    #    else
        { $fh->print("glyphid($i)"); }
        
        $glyphs->[$i]{'gdl_name'} = $gname;
    
        $sep = ' {';
        foreach $p (keys %{$glyphs->[$i]{'points'}})
        {
            my ($pname) = $p;
            $pname .= 'S' unless ($pname =~ s/^_(.*)/${1}M/o);
            
            $pt = $glyphs->[$i]{'points'}{$p};
            $fh->print("$sep$pname = ");
            push (@{$lists{$p}}, $gname);
            vec($self->{'vecs'}{$p}, $i, 1) = 1 if ($self->{'vecs'});
            if (defined $pt->{'cont'})
            { $fh->print("gpath($pt->{'cont'})"); }
            else
            { $fh->print("point($pt->{'x'}m, $pt->{'y'}m)"); }
            $sep = '; ';
        }
    #    printf OUT ("%sorder=%d", $sep, $glyphs[$i]->{'props'}{'order'});
        foreach $k (keys %{$glyphs->[$i]{'props'}})
        {
            my ($n) = $k;
            next unless ($n =~ s/^GDL(?:_)?//o);
            $fh->print("$sep$n=$glyphs->[$i]{'props'}{$k}");
            $sep = '; ';
        }
        $fh->print("}") if ($sep ne ' {');
        $fh->print(";\n");
    }
    $self->{'lists'} = \%lists;
    $self;
}

sub make_classes
{
    my ($self) = @_;
    my ($glyphs) = $self->{'glyphs'};
    my ($f) = $self->{'font'};
    my (%classes);
    my ($g, $gname, $i);
    
    foreach $g (@{$glyphs})
    {
        $gname = $g->{'post'};
        if ($gname =~ m/\.([^_.]+)$/o)
        {
            my ($base, $ext) = ($` , $1);
            next unless ($i = $f->{'post'}{'STRINGS'}{$base});
            push (@{$classes{$ext}}, $g->{'gdl_name'});
            push (@{$classes{"no_$ext"}}, $glyphs->[$i]{'gdl_name'});
        }
    }
    $self->{'classes'} = \%classes;
}

sub out_classes
{
    my ($self, $fh) = @_;
    my ($f) = $self->{'font'};
    my ($lists) = $self->{'lists'};
    my ($classes) = $self->{'classes'};
    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("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$cl");
            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);
            $fh->print("$sep$glyphs->[$c]{'gdl_name'}");
            if (++$count % 8 == 0)
            { $sep = ",\n    "; }
            else
            { $sep = ", "; }
        }
        $fh->print(");\n\n");
    }
    

    foreach $cl (sort keys %{$classes})
    {
        $fh->print("c$cl = ($classes->{$cl}[0]");
        for ($i = 1; $i <= $#{$classes->{$cl}}; $i++)
        { $fh->print($i % 8 ? ", $classes->{$cl}[$i]" : ",\n    $classes->{$cl}[$i]"); }
        $fh->print(");\n\n");
    }
    $self;
}

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

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


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

    $fh->print("\n#define MAXGLYPH " . ($self->{'font'}{'maxp'}{'numGlyphs'} - 1) . "\n");
    $fh->print("\n#include \"$include\"\n") if ($include);
}

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

sub error
{
    my ($xml, $cur_glyph, $cur_pt, $str) = @_;

    if (defined $cur_glyph->{'UID'})
    { print "U+$cur_glyph->{'UID'}: "; }
    elsif (defined $cur_glyph->{'PSName'})
    { print "$cur_glyph->{'PSName'}: "; }
    elsif (defined $cur_glyph->{'GID'})
    { print "$cur_glyph->{'GID'}: "; }
    else
    { print "Undefined: "; }

    print $str;

    if (defined $cur_pt)
    { print " in point $cur_pt->{'name'}"; }

    print " at line " . $xml->current_line . ".\n";
}