#!/usr/bin/perl

use Font::TTF::Scripts::Volt;
use Data::Dumper;
use Pod::Usage;
use Getopt::Std;

# don't forget Font::TTF::GDEF

our $DEBUG = 0;
my %opts;
my $VERSION;
our $CHAIN_CALL;
our ($if, $of);

$VERSION = 0.01;    # MJPH      11-OCT-2007     First release

unless ($CHAIN_CALL)
{
    getopts('a:d:ht:', \%opts);

    unless (defined $ARGV[1] || defined $opts{h})
    {
        pod2usage(1);
        exit;
    }

    if ($opts{h})
    {
        pod2usage( -verbose => 2, -noperldoc => 1);
        exit;
    }

    $if = Font::TTF::Scripts::Volt->read_font($ARGV[0], $opt_a) || die "Can't read font $ARGV[0]";
}

Font::TTF::Scripts::Volt::main($if, %opts);

unless ($CHAIN_CALL)
{ $if->{'font'}->out($ARGV[1]) || die "Can't write to font file $ARGV[1]. Do you have it installed?" unless ($DEBUG > 1); }

if ($opts{'d'} || $DEBUG)
{
    foreach (qw(GSUB GPOS))
    {
        delete $if->{'font'}{$_}{' PARENT'};
        print Dumper($if->{'font'}{$_});
    }
    print Dumper($if->{'voltdat'});
}

package Font::TTF::Scripts::Volt;

use Font::TTF::Coverage;
use Font::TTF::GSUB;
use Font::TTF::GPOS;
use Font::TTF::GDEF;
use IO::File;

sub main
{
    my ($f, %opts) = @_;

    if ($opts{'t'})
    {
        my ($inf) = IO::File->new("< $opts{'t'}") || die "Can't open file $opts{'t'}";
        while (<$inf>)
        { $volt_text .= $_; }
        $inf->close;
    }
    elsif (defined $f->{'font'}{'TSIV'})
    { $volt_text = $f->{'font'}{'TSIV'}->read->{' dat'}; }
    else
    { die "No VOLT table in the font, nothing to do"; }
    delete $f->{'font'}{'TSIV'};        # remove the volt source

    if ($opts{'d'})
    {
        $::RD_HINT = 1;
        $::RD_TRACE = $opts{'d'} if ($opts{'d'} > 1);
    }

    $f->{'voltdat'} = $f->parse_volt($volt_text);

    $f->{'font'}{'GSUB'} = Font::TTF::GSUB->new(PARENT => $font, read => 1) unless (defined $font->{'GSUB'});
    $f->{'font'}{'GSUB'}{'Version'} = 1;
    $f->{'font'}{'GPOS'} = Font::TTF::GPOS->new(PARENT => $font, read => 1) unless (defined $font->{'GPOS'});
    $f->{'font'}{'GPOS'}{'Version'} = 1;
    $f->features_ttf;
    foreach my $t (qw(GSUB GPOS))
    {
        $f->{'font'}{$t}{'FEATURES'}{'FEAT_TAGS'} = [sort {$f->{'featmap'}{$a} cmp $f->{'featmap'}{$b}} @{$f->{'font'}{$t}{'FEATURES'}{'FEAT_TAGS'}}];
        $f->lookups_ttf($t);
    }
    $f->add_gdef();
    $f->{'font'}{'OS/2'}->read->{'maxLookups'} = $f->{'maxcontext'};
#    print STDERR "maxcontext=$f->{'maxcontext'}\n";
}

sub features_ttf
{
    my ($self) = @_;
    my ($dat) = $self->{'voltdat'};
    my ($font) = $self->{'font'};
    my (%multis);

    $dat->{'lookuptags'} = {map {$_->{'id'} => $_} @{$dat->{'lookups'}}} unless (defined $dat->{'lookuptags'});
    foreach $s (sort keys %{$dat->{'scripts'}})
    {
        my ($t) = $dat->{'scripts'}{$s};
        foreach $l (@{$t->{'lang'}})
        {
            foreach $f (sort grep {$_ ne 'name' && $_ ne 'tag'} keys %{$l})
            {
                foreach $k (@{$l->{$f}{'lookups'}})
                { $dat->{'lookuptags'}{$k}{' include'} = 1; }
            }
        }
    }

    foreach $l (@{$dat->{'lookups'}})
    {
        next unless ($l->{' include'});
        my ($multi);
        if ($l->{'id'} =~ m/^([^\\]+)\\/o)
        { $multi = $1; }
        if (defined $multi && defined $multis{$multi})
        {
            $l->{' index'} = $multis{$multi};
            $l->{' sub'} = 1;
        }
        else
        {
            if ($l->{'lookup'}[0] eq 'sub')
            { $l->{' index'} = $dat->{'GSUB_counters'}++; }
            else
            { $l->{' index'} = $dat->{'GPOS_counters'}++; }
            $multis{$multi} = $l->{' index'} if (defined $multi);
        }
    }
    foreach $s (sort keys %{$dat->{'scripts'}})
    {
        my ($t) = $dat->{'scripts'}{$s};
        foreach $l (@{$t->{'lang'}})
        {
            foreach $f (sort grep {$_ ne 'name' && $_ ne 'tag'} keys %{$l})
            {
                my ($type);
                foreach $k (@{$l->{$f}{'lookups'}})
                {
                    if ($dat->{'lookuptags'}{$k}{'lookup'}[0] eq 'sub')
                    { $type = 'GSUB'; }
                    else
                    { $type = 'GPOS'; }
                    $self->append_feat($font, $t->{'tag'}, $l->{'tag'}, $l->{$f}{'tag'}, $dat->{'lookuptags'}{$k}{' index'}, $type) unless ($dat->{'lookuptags'}{$k}{' sub'});
                }
            }
        }
    }
}

sub append_feat
{
    my ($self, $font, $script, $lang, $feat, $lindex, $type) = @_;
    my ($fname) = "${feat}_${script}_${lang}";

    $self->{'featmap'}{$fname} = $feat;
    if ($lang eq 'dflt')
    { $font->{$type}{'SCRIPTS'}{$script}{'DEFAULT'} = {' REFTAG' => 'dflt'}; }

    unless (defined $font->{$type}{'SCRIPTS'}{$script}{$lang})
    {
        push (@{$font->{$type}{'SCRIPTS'}{$script}{'LANG_TAGS'}}, $lang);
    }

    unless (defined $font->{$type}{'FEATURES'}{$fname})
    {
        push (@{$font->{$type}{'FEATURES'}{'FEAT_TAGS'}}, $fname);
    }

    unless (grep {$_ eq $fname} @{$font->{$type}{'SCRIPTS'}{$script}{$lang}{'FEATURES'}})
    {
        push (@{$font->{$type}{'SCRIPTS'}{$script}{$lang}{'FEATURES'}}, $fname);
    }
    
    push (@{$font->{$type}{'FEATURES'}{$fname}{'LOOKUPS'}}, $lindex);
}

sub lookups_ttf
{
    my ($self, $type) = @_;
    my ($dat) = $self->{'voltdat'};
    my ($font) = $self->{'font'};
    my ($ltype) = lc($type);
    my ($clr, @clr);
    $ltype =~ s/^g//o;

    foreach $l (sort {$a->{' index'} <=> $b->{' index'}}
            grep {$_->{'lookup'}[0] eq $ltype && defined $_->{' index'} && $_->{' include'}}
            @{$dat->{'lookups'}})
    {
        my ($flags);
        $flags |= 1 if ($l->{'dir'} =~ /RTL/oi);
        $flags |= 2 if (!$l->{'base'});
        $flags |= 8 if ($l->{'marks'} =~ m/SKIP/oi);

        if ($l->{'all'} and $l->{'all'} ne 'ALL')
        {
            if (!defined $self->{'alls'}{$l->{'all'}})
            {
                $self->{'alls'}{$l->{'all'}} = ++$self->{'max_all'};
                foreach $g (@{$self->or_context_glyphs(@{$dat->{'groups'}{$l->{'all'}}})})
                { $dat->{'glyphs'}[$g]{'mark_class'} = $self->{'alls'}{$l->{'all'}}; }
            }
            $flags |= $self->{'alls'}{$l->{'all'}} << 8;
        }

        $font->{$type}{'LOOKUP'}[$l->{' index'}]{'FLAG'} = $flags;
        $font->{$type}{'LOOKUP'}[$l->{' index'}]{' index'} = $l->{' index'};
        if (defined $l->{'contexts'}[0][1])
        {
            $font->{$type}{'LOOKUP'}[$l->{' index'}]{'TYPE'} = $type eq 'GSUB' ? 6 : 8;
# use a context chaining subrule and then add a new lookup for the action
# always use format 3, it's simpler (same as VOLT does)
            if ($type eq 'GSUB')
            {
                $clr = {'MATCH' => [],
                        'ACTION' => [[0, $dat->{"${type}_counters"}]]};
                @clr = ({%$clr});
                foreach $lk (@{$l->{'lookup'}[1]})
                {
                    for ($i = 0; $i < @{$lk->[0]}; $i++)
                    {
                        my ($glyphs) = $self->scon_glyphs($lk->[0][$i]);
                        if (!defined $clr->{'MATCH'}[$i])
                        { $clr->{'MATCH'}[$i] = Font::TTF::Coverage->new(1); }
                        foreach (@{$glyphs})
                        { $clr->{'MATCH'}[$i]->add($_); }
                        $clr->{'MATCH'}[$i]->sort;
                    }
                }
            }
            else
            {
                @clr = ();
                foreach $lk (@{$l->{'lookup'}[1]})
                {
                    my (@match);
                    if ($lk->{'type'} eq 'ATTACH')
                    {
                        push (@match, $self->make_coverage(@{$lk->{'context'}}),
                                $self->make_coverage(@{$lk->{'to'}}));
                    }
                    elsif ($lk->{'type'} eq 'ADJUST_PAIR')
                    {
                        push (@match, $self->make_coverage(@{$lk->{'context1'}}),
                                $self->make_coverage(@{$lk->{'context2'}}));
                    }
                    elsif ($lk->{'type'} eq 'ATTACH_CURSIVE')
                    {
                        push (@match, $self->make_coverage(@{$lk->{'exits'}}),
                                $self->make_coverage(@{$lk->{'enters'}}));
                    }
                    else        # ADJUST_SINGLE
                    {
                        push (@match, $self->make_coverage(@{$lk->{'context'}}));
                    }
                    push (@clr, {MATCH => [@match], ACTION => [[0, $dat->{"${type}_counters"}]]});
                }
            }
            foreach $c (@{$l->{'contexts'}})        # multiple context subrules
            {
                my ($contlength);
                my ($clr1) = {};
                foreach $e (@{$c}[1..$#{$c}])
                { push (@{$clr1->{$e->[0] eq 'LEFT' ? 'PRE' : 'POST'}}, $self->make_coverage(@{$e}[1..$#{$e}])); }
                if (@{$clr1->{'PRE'}})
                {
                    $clr1->{'PRE'} = [reverse (@{$clr1->{'PRE'}})];
#                    $contlength = scalar @{$clr1->{'PRE'}};
                }
                $contlength += scalar @{$clr1->{'POST'}};

                foreach (@clr)
                {
                    if ($c->[0] =~ m/^EXCEPT/o)
                    {
                        # first the full context match that does nothing
                        push (@{$font->{$type}{'LOOKUP'}[$l->{' index'}]{'SUB'}}, {'FORMAT' => 3,
                            'MATCH_TYPE' => 'o',
                            'ACTION_TYPE' => 'l',
                            'RULES' => [[{'MATCH' => $_->{'MATCH'}, 'ACTION' => [], %$clr1}]]});
                        # then just match the core string and do the lookup
                        push (@{$font->{$type}{'LOOKUP'}[$l->{' index'}]{'SUB'}}, {'FORMAT' => 3,
                            'MATCH_TYPE' => 'o',
                            'ACTION_TYPE' => 'l',
                            'RULES' => [[{%$_}]]});
                    }
                    else
                    {
                        push (@{$font->{$type}{'LOOKUP'}[$l->{' index'}]{'SUB'}}, {'FORMAT' => 3,
                            'MATCH_TYPE' => 'o',
                            'ACTION_TYPE' => 'l',
                            'RULES' => [[{%$_, %$clr1}]]});
                    }
                }
                $contlength += scalar @{$clr->{'MATCH'}};
                $self->{'maxcontext'} = $contlength if ($contlength > $self->{'maxcontext'});
            }
            $index = $dat->{"${type}_counters"}++;
        }
        else
        { $index = $l->{' index'}; }

        if ($type eq 'GSUB')
        { $self->add_gsub_lookup($index, $l); }
        else
        { $self->add_gpos_lookup($index, $l); }
    }
}

sub add_gsub_lookup
{
    my ($self, $index, $l) = @_;
    my ($dat) = $self->{'voltdat'};
    my ($font) = $self->{'font'};
    my ($s, $maxi, $maxo, @map, $sub);

# which of the 3 types of subst are we? 1:1, 1:many, many:1
    foreach $s (@{$l->{'lookup'}[1]})
    {
        my ($sm) = scalar @{$s->[1]};
        $maxo = $sm if ($sm > $maxo);
        my ($m) = scalar @{$s->[0]};
        $maxi = $m if ($m > $maxi);
    }
    $self->{'maxcontext'} = $maxi if ($maxi > $self->{'maxcontext'});

    if ($maxi == 1 && $maxo == 1)
    {
        $sub = {'ACTION_TYPE' => 'g', 'FORMAT' => 2, ' index' => $index};
        $font->{'GSUB'}{'LOOKUP'}[$index]{'TYPE'} = 1;
        $sub->{'COVERAGE'} = Font::TTF::Coverage->new(1);
        foreach $s (@{$l->{'lookup'}[1]})
        {
            my (@input) = @{$self->scon_glyphs($s->[0][0])};
            my (@output) = @{$self->scon_glyphs($s->[1][0])};
            for ($i = 0; $i < @input; $i++)
            {
                my ($j) = $sub->{'COVERAGE'}->add($input[$i]);
                push (@{$sub->{'RULES'}[$j][0]{'ACTION'}}, $output[$i]);
                if ($sub->{'ACTION_TYPE'} eq 'g' && scalar @{$sub->{'RULES'}[$j][0]{'ACTION'}} > 1)
                {
                    $font->{'GSUB'}{'LOOKUP'}[$index]{'TYPE'} = 3;
                    $sub->{'ACTION_TYPE'} = 'a';
                    $sub->{'FORMAT'} = 1;
                }
            }
        }
    }
    elsif ($maxi == 1)
    {
        $sub = {'ACTION_TYPE' => 'g', 'FORMAT' => 1, ' index' => $index};
        my ($i);
        $font->{'GSUB'}{'LOOKUP'}[$index]{'TYPE'} = 2;
        $sub->{'COVERAGE'} = Font::TTF::Coverage->new(1);

        foreach $s (@{$l->{'lookup'}[1]})
        {
            my ($input) = $self->scon_glyphs($s->[0][0]);
            my (@output) = $self->context_glyphs(@{$s->[1]});
            for ($i = 0; $i < @{$input}; $i++)
            { $sub->{'RULES'}[$sub->{'COVERAGE'}->add($input->[$i])][0]{'ACTION'} = $output[$i]; }
        }
    }
    else        # ligature - many:1
    {
        $sub = {'ACTION_TYPE' => 'g', 'MATCH_TYPE' => 'g', 'FORMAT' => 1, ' index' => $index};
        my (@input, @new_input);
        $font->{'GSUB'}{'LOOKUP'}[$index]{'TYPE'} = 4;
        $sub->{'COVERAGE'} = Font::TTF::Coverage->new(1);

        foreach $s (@{$l->{'lookup'}[1]})
        {
            my ($first) = $self->scon_glyphs($s->[0][0]);
            my (@all) = $self->context_glyphs(@{$s->[0]});
            my (@output) = $self->context_glyphs(@{$s->[1]});
            for ($i = 0; $i < @{$first}; $i++)
            {
                my (@i) = grep {$all[$_][0] == $first->[$i]}(0 .. $#all);
                foreach $j (@i)
                {
                    push (@{$sub->{'RULES'}[$sub->{'COVERAGE'}->add($first->[$i])]}, {'ACTION' => $output[$j], 'MATCH' => [@{$all[$j]}[1..$#{$all[$j]}]]});
                }
            }
        }
    }
    @map = $sub->{'COVERAGE'}->sort;
    $sub->{'RULES'} = [map {$sub->{'RULES'}[$map[$_]]} (0 .. @map-1)];
    push (@{$font->{'GSUB'}{'LOOKUP'}[$index]{'SUB'}}, $sub);
    return;
}


sub add_gpos_lookup
{
    my ($self, $index, $l) = @_;
    my ($dat) = $self->{'voltdat'};
    my ($font) = $self->{'font'};
    my ($s, $contlength, @map);

    foreach $s (@{$l->{'lookup'}[1]})
    {
        if ($s->{'type'} eq 'ADJUST_SINGLE')
        {
            my ($cover) = Font::TTF::Coverage->new(1);
            my (@rules);
            $font->{'GPOS'}{'LOOKUP'}[$index]{'TYPE'} = 1;
            my ($sub) = {
                'FORMAT' => 2,
                'ACTION_TYPE' => 'v',
                'COVERAGE' => $cover};
            for ($i = 0; $i < @{$s->{'context'}}; $i++)
            {
                foreach $g (@{$self->scon_glyphs($s->{'context'}[$i])})
                {
                    next unless ($cover->add($g) > $#rules);
                    push (@rules, [{'ACTION' => [{make_value(%{$s->{'adj'}[$i]})}]}]);
                }
            }
            @map = $sub->{'COVERAGE'}->sort;
            $sub->{'RULES'} = [map {$rules[$map[$_]]} (0 .. @map-1)];
            push (@{$font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'}}, $sub);
            $contlength = 1;
        }
        elsif ($TYPE2 && $s->{'type'} eq 'ADJUST_PAIR')
        {
            my ($cover1) = Font::TTF::Coverage->new(0);
            my ($cover2) = Font::TTF::Coverage->new(0);
            my ($cover) = Font::TTF::Coverage->new(1);
            my (@rules, @firsts, @seconds);
            $font->{'GPOS'}{'LOOKUP'}[$index]{'TYPE'} = 2;
            my ($sub) = {
                'FORMAT' => 2,
                'ACTION_TYPE' => 'p',
                'MATCH_TYPE' => 'g',
                'COVERAGE' => $cover,
                'CLASS' => $cover1,
                'MATCH' => [$cover2]};
            my ($c, $g, $count);
            for ($i = 0; $i < @{$s->{'context1'}}; $i++)
            {
                foreach $g (@{$self->scon_glyphs($s->{'context1'}[$i])})
                { $cover1->add($g, $i+1); }
            }
            foreach $g (sort {$a <=> $b} keys %{$cover1->{'val'}})
            { $cover->add($g); }
            for ($i = 0; $i < @{$s->{'context2'}}; $i++)
            {
                foreach $g (@{$self->scon_glyphs($s->{'context2'}[$i])})
                { $cover2->add($g, $i+1); }
            }
            foreach $r (@{$s->{'adj'}})
            {
                $sub->{'RULES'}[$r->[0]][$r->[1]]{'ACTION'} = 
                    [{make_value(%{$r->[2][0]})}, {make_value(%{$r->[2][1]})}];
            }
            push (@{$font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'}}, $sub);
            $contlength = 2;
        }
        elsif ($s->{'type'} eq 'ADJUST_PAIR')
        {
            my (@rules);
            my ($cover) = Font::TTF::Coverage->new(1);
            $font->{'GPOS'}{'LOOKUP'}[$index]{'TYPE'} = 2;
            $font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'} = [{
                'FORMAT' => 1,
                'ACTION_TYPE' => 'p',
                'MATCH_TYPE' => 'g',
                'COVERAGE' => $cover}];
            foreach $r (@{$s->{'adj'}})
            {
                my (@seconds) = @{$self->scon_glyphs($s->{'context2'}[$r->[1]-1])};
                my ($action) = [{make_value(%{$r->[2][0]})}, {make_value(%{$r->[2][1]})}];
                foreach (@seconds)
                { push (@{$rules[$r->[0]-1]}, {'MATCH' => [$_], 'ACTION' => $action}); }
            }
            for ($i = 0; $i < @{$s->{'context1'}}; $i++)
            {
                $rules[$i] = [sort {$a->{'MATCH'}[0] <=> $b->{'MATCH'}[0]} @{$rules[$i]}];
                foreach $g (@{$self->scon_glyphs($s->{'context1'}[$i])})
                { $font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'}[0]{'RULES'}[$cover->add($g)] = $rules[$i]; }
            }
            $contlength = 2;
        }
        elsif ($s->{'type'} eq 'ATTACH_CURSIVE')
        {
            my ($cover) = Font::TTF::Coverage->new(1);
            $font->{'GPOS'}{'LOOKUP'}[$index]{'TYPE'} = 3;
            my ($sub) = {
                    'FORMAT' => 1,
                    'ACTION_TYPE' => 'e',
                    'COVERAGE' => $cover};
            foreach $g (@{$self->or_context_glyphs(@{$s->{'enters'}})})
            { $sub->{'RULES'}[$cover->add($g)][0]{'ACTION'}[0] = make_anchor($dat->{'glyphs'}[$g]{'anchors'}{'entry'}); }
            foreach $g (@{$self->or_context_glyphs(@{$s->{'exits'}})})
            { $sub->{'RULES'}[$cover->add($g)][0]{'ACTION'}[1] = make_anchor($dat->{'glyphs'}[$g]{'anchors'}{'exit'}); }
            push (@{$font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'}}, $sub);
            $contlength = 2;
        }
        elsif ($s->{'type'} eq 'ATTACH')
        {
            my ($basec) = Font::TTF::Coverage->new(1);
            my ($markc) = Font::TTF::Coverage->new(1);
            my ($acount, %anchors, @marks, @rules, $ismark);
            foreach $c (@{$s->{'to'}})
            {
                $anchors{$c->[1]} = $acount++ unless (defined $anchors{$c->[1]});
                foreach $g (@{$self->scon_glyphs($c->[0])})
                { $marks[$markc->add($g)] = [$anchors{$c->[1]}, make_anchor($dat->{'glyphs'}[$g]{'anchors'}{"MARK_$c->[1]"})]; }
            }
            foreach $g (sort {$a <=> $b} @{$self->or_context_glyphs(@{$s->{'context'}})})
            {
                my ($i) = $basec->add($g);
                $ismark = ($dat->{'glyphs'}[$g]{'type'} eq 'MARK') ? 2 : 1 unless ($ismark);
                foreach $k (sort {$anchors{$a} <=> $anchors{$b}} keys %anchors)
                {
                    if (defined $dat->{'glyphs'}[$g]{'anchors'}{$k})
                    { $rules[$i][0]{'ACTION'}[$anchors{$k}] = make_anchor($dat->{'glyphs'}[$g]{'anchors'}{$k}); }
                }
            }
            $font->{'GPOS'}{'LOOKUP'}[$index]{'TYPE'} = $ismark == 2 ? '6' : '4';
            push (@{$font->{'GPOS'}{'LOOKUP'}[$index]{'SUB'}}, {
                    'FORMAT' => 1,
                    'COVERAGE' => $basec,
                    'MATCH' => [$markc],
                    'MARKS' => [@marks],
                    'RULES' => [@rules]});
            $contlength = 2;
        }
    }
    $self->{'maxcontext'} = $contlength if ($contlength > $self->{'maxcontext'});
}


sub add_gdef
{
    my ($self) = @_;
    my ($font) = $self->{'font'};
    my ($dat) = $self->{'voltdat'};
    my ($gdc) = Font::TTF::Coverage->new(0);       # glyph types
    my ($gdm) = Font::TTF::Coverage->new(0);
    my %types = (
        'BASE' => 1, 'LIGATURE' => 2, 'MARK' => 3, 'COMPONENT' => 4
    );
    my ($g);

    foreach $g (@{$dat->{'glyphs'}})
    {
        $gdc->add($g->{'gnum'}, $types{$g->{'type'}});
        $gdm->add($g->{'gnum'}, $g->{'mark_class'}) if (defined $g->{'mark_class'});
    }

    $font->{'GDEF'} = Font::TTF::GDEF->new('parent' => $font, 'read' => 1);
    $font->{'GDEF'}{'Version'} = 1.0;
    $font->{'GDEF'}{'GLYPH'} = $gdc;
    $font->{'GDEF'}{'MARKS'} = $gdm if ($gdm->{'max'} > 0);
}


=comment

takes a context list and returns an array ref of flattened arrays of glyph ids that
map to the context list.

=cut

sub context_glyphs
{
    my ($dat, @list) = @_;
    my (@input, @new_input, $l, $g);

    foreach $l (@list)
    {
        my ($glyphs) = $dat->scon_glyphs($l);
        my (@new_input) = ();
        foreach $g (@$glyphs)
        { push (@new_input, @input ? (map {[@$_, $g]} @input) : [$g]); }
        @input = @new_input;
    }
    return @input;
}

sub or_context_glyphs
{
    my ($dat, @list) = @_;
    my ($l, %res, $c);

    foreach $l (@list)
    {
        my ($glyphs) = $dat->scon_glyphs($l);
        foreach $g (@{$glyphs})
        { $res{$g} = ++$c unless (defined $res{$g}); }
    }
    return [sort {$res{$a} <=> $res{$b}} keys %res];
}

sub scon_glyphs
{
    my ($dat, $context) = @_;

    if ($context->[0] eq 'GLYPH')
    { return defined $context->[1] ? [$context->[1]] : warn("Undefined glyph"); }
    elsif ($context->[0] eq 'GROUP')
    { return defined $dat->{'voltdat'}{'groups'}{$context->[1]} ? [sort {$a <=> $b} @{$dat->or_context_glyphs(@{$dat->{'voltdat'}{'groups'}{$context->[1]}})}] : warn "Unknown glyph group $context->[1]"; }
    elsif ($context->[0] eq 'RANGE')
    { return [$context->[1] .. $context->[2]]; }
    elsif ($context->[0] eq 'ENUM')
    { return $dat->or_context_glyphs($context->[1]); }
    return [];
}

sub make_coverage
{
    my ($self, @contexts) = @_;
    my ($cover) = Font::TTF::Coverage->new(1);
    my ($c);

    foreach $c (@contexts)
    {
        my ($glyphs) = $self->scon_glyphs($c);

        foreach (@{$glyphs})
        { $cover->add($_); }
    }
    $cover->sort;
    return $cover;
}

sub make_value
{
    my (%pos) = @_;
    my (%res, $s);
    my %map = (
        'x' => ['XPlacement', 'XPlaDevice'],
        'y' => ['YPlacement', 'YPlaDevice'],
        'adv' => ['XAdvance', 'XAdvDevice']);

    foreach $s (qw(x y adv))
    {
        if (defined $pos{$s})
        {
            $res{$map{$s}[0]} = $pos{$s}[0];
            if (defined $pos{$s}[1])
            {
#                $res{$map{$s}[1]} = make_delta($pos{$s}[1]);
            }           
        }
    }
    %res
}

sub make_anchor
{
    my ($point) = @_;
    my (%res, $s, $r);
    
    return undef unless (defined $point->{'pos'});
    return ($point->{'anchor'}) if defined ($point->{'anchor'});

    foreach $s (qw(x y))
    { $res{$s} = $point->{'pos'}{$s}[0]; }
    $r = Font::TTF::Anchor->new(%res);
    $point->{'anchor'} = $r;
    return $r;
}


__END__

=head1 TITLE

volt2ttf - compiles volt code into OT tables in a font

=head1 SYNOPSIS

  volt2ttf [-a attach.xml] [-t volt.txt] infile.ttf outfile.ttf

Compiles volt source into OT tables in the font.

=head1 OPTIONS

  -a file     Attachment point database
  -t file     Volt source as text file to use instead of what is in the font
  -h          Help
    
=head1 DESCRIPTION

volt2ttf is like loading a font into VOLT and hitting compile and saving the
result. Note that it doesn't compile a new cmap, though. Just the OT tables
are built.

=cut
