#!/usr/bin/perl

use Font::TTF::Font;
use Font::TTF::Scripts::Name;
use Getopt::Std;
use IO::File;
use Pod::Usage;

use strict;
our $VERSION = 0.1;     #   

our $CHAIN_CALL;
our %opts;
our $f;

our $DEBUG = 0;

unless($CHAIN_CALL)
{
    pod2usage(-verbose => 1) unless (getopts('d:g:hl:n:s:', \%opts) && $#ARGV == 1) || $opts{'h'};
    pod2usage(-verbose => 2, -noperldoc => 1) if $opts{'h'};
    $f = Font::TTF::Font->open($ARGV[0]) || die "Can't open file '$ARGV[0]'";
}

$opts{'d'} = 'default' unless (defined $opts{'d'});
if ($opts{'d'})
{
    # expand magic words.
    $opts{'d'} =~ s/\bdefault\b/ hdmx vdmx aat kern /oi;        # shame about kern, we should support that.
    $opts{'d'} =~ s/\bgraphite\b/ Silf Feat Gloc Glat Sill Sile /oi; 
    $opts{'d'} =~ s/\bvolt\b/ TSIV TSID TSIP TSIS /oi;
    $opts{'d'} =~ s/\bopentype\b/ GDEF GSUB GPOS /oi;
    $opts{'d'} =~ s/\baat\b/ morx feat /oi;
    # Split generously (spaces, comma, colon, semicolon)
    foreach my $tag (grep {length($_) == 4} split(/[\s,:;]+/, $opts{'d'}))
    {
        delete $f->{$tag} if exists $f->{$tag};
    }
}

my $cmap = $f->{'cmap'}->read->find_ms;
my $post = $f->{'post'}->read;
my $numg = $f->{'maxp'}{'numGlyphs'};
my $subsetter = Font::TTF::Scripts::SubSetter->new($numg);
if ($opts{'g'})
{
    my ($fh) = IO::File->new($opts{'g'}, "<:utf8") || die "Can't open $opts{'g'} for reading";
    while (<$fh>)
    {
        s/[\r\n]+$//o;
        s/^\x{FEFF}?\s*//o;
        foreach my $g (split)
        {
            my ($n1, $n2, $u);
            ($n1, $n2, $u) = ($g =~ m/^([^=]+?)(?:\.\.([^=]+?))?(?:=([a-f0-9]{4,6}))?$/oi);
            $u = hex($u);
            if ($n1 =~ m/^U\+/oi)
            {
                # Process Unicode or Unicode range
                $n1 = hex($');  #'
                $n2 = defined($n2) ? hex($n2) : $n1;
                if ($n1 == 0 || $n1 > $n2)
                { warn "Can't parse $g"; next;}
                while ($n1 <= $n2)
                {
                    my $n = $cmap->{'val'}{$n1};
                    $subsetter->add_glyph($n);
                    if ($u)
                    { $subsetter->remap($u++, $n); }
                    $n1++;
                }
                next;
            }
            # Process postscript or GID range
            $n1 = $post->{'STRINGS'}{$n1} unless $n1 =~ m/^\d+$/o;
            if (!defined $n1 || $n1 >= $numg)
            { warn "Can't parse $g"; next;}
            if (defined $n2)
            {
                $n2 = $post->{'STRINGS'}{$n1} unless $n2 =~ m/^\d+$/o;
                if ($n1 > $n2 || $n2 >= $numg)
                { warn "Can't parse $g"; next;}
            }
            else
            {
                $n2 = $n1;
            }
            while ($n1 <= $n2)
            {
                $subsetter->add_glyph($n1);
                if ($u)
                { $subsetter->remap($u++, $n1); }
                $n1++;
            }
        }
    }
    $fh->close();
}

if ($opts{'l'})
{ $subsetter->langlist(split(' ', $opts{'l'})); }

if ($opts{'s'})
{ $subsetter->scriptlist(split(' ', $opts{'s'})); }

my ($canchangegids) = 1;
$f->tables_do(sub {$canchangegids &= $_[0]->canchangegids();});
$numg = $subsetter->creategidmap() if ($canchangegids);

$f->{'loca'}->subset($subsetter);
$f->tables_do(sub {$_[0]->subset($subsetter);});
$f->{'maxp'}{'numGlyphs'} = $subsetter->{'gcount'};
$f->tables_do(sub {$_[0]->update;});
ttfname($f, "q" => 1, "n" => $opts{'n'}) if ($opts{'n'});
$f->out($ARGV[1]);

package Font::TTF::Scripts::SubSetter;

sub new
{
    my ($class, $numg) = @_;
    my ($self) = {};
    $self->{'glyphs'} = '';
    $self->{'remaps'} = {};
    $self->{'numg'} = $numg;
    bless $self, $class || ref $class;
    foreach (0..2) { $self->add_glyph($_); }
    return $self;
}

sub add_glyph
{
    my ($self, $n, $private) = @_;
    if (($private && !$self->{'gidmap'}[$n]) || (!$private && !vec($self->{'glyphs'}, $n, 1)))
    {
        vec($self->{'glyphs'}, $n, 1) = 1; # unless ($private);
        $self->{'gidmap'}[$n] = $self->{'gcount'}++ if (defined $self->{'gidmap'});
        return 1;
    }
    else
    { return 0; }
}

sub keep_glyph
{
    my ($self, $n) = @_;
    return vec($self->{'glyphs'}, $n, 1);
}

sub remap
{
    my ($self, $u, $n) = @_;
    $self->{'remaps'}{$u} = $n;
}

sub langlist
{
    my ($self, @dat) = @_;
    $self->{'langs'} = { map {$_=>1} @dat };
}

sub scriptlist
{
    my ($self, @dat) = @_;
    $self->{'scripts'} = { map {$_=>1} @dat };
}

sub creategidmap
{
    my ($self) = @_;
    my ($numg) = $self->{'numg'};
    my ($count) = 0;

    $self->{'gidmap'} = [];
    $self->{'gcount'} = 0;
    foreach my $i (0 .. $numg - 1)
    { push (@{$self->{'gidmap'}}, vec($self->{'glyphs'}, $i, 1) ? $self->{'gcount'}++ : 0); }
    if ($DEBUG)
    {
        my (@list);
        foreach (0 .. $#{$self->{'gidmap'}})
        { push (@list, "$_=$self->{'gidmap'}[$_]") if ($self->{'gidmap'}[$_] > 0); }
        print join(", ", @list) . "\n";
    }
    return $self->{'gcount'};
}

sub map_glyph
{
    my ($self, $g) = @_;
    # no glyph remapping yet
    if ($self->{'gidmap'})
    { return $self->{'gidmap'}[$g]; }
    else
    { return -1; }
}

package Font::TTF::Table;

sub canchangegids
{ 1; }

sub subset
{
    my ($self, $subsetter) = @_;
    return 0 if ($self->{' subsetdone'});
    $self->{' subsetdone'} = 1;
    $self->read;
    $self->dirty;
    return 1;
}

package Font::TTF::Loca;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];
    my ($i, $vec);

    return unless ($self->SUPER::subset($subsetter));
    for ($i = 0; $i < @{$self->{'glyphs'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        { $self->outglyph($subsetter, $res, $i); }
    }
    $self->{'glyphs'} = $res;
}

sub outglyph
{
    my ($self, $subsetter, $res, $n) = @_;

    $res->[$subsetter->map_glyph($n)] = $self->{'glyphs'}[$n];
    if (defined $self->{'glyphs'}[$n] && $self->{'glyphs'}[$n]->read()->{'numberOfContours'} < 0)
    {
        my ($g) = $self->{'glyphs'}[$n]->read_dat();
        foreach my $c (@{$g->{'comps'}})
        {
            if ($subsetter->add_glyph($c->{'glyph'}, 1))
            { $self->outglyph($subsetter, $res, $c->{'glyph'}); }
            $c->{'glyph'} = $subsetter->map_glyph($c->{'glyph'});
        }
        $g->{' isDirty'} = 1;
    }
}

package Font::TTF::Ttopen;

sub subset
{
    my ($self, $subsetter) = @_;
    return unless ($self->SUPER::subset($subsetter));

    my ($l, $count, @lmap, @lookups, $lkvec, $res, $nlookup);
    $lkvec = "";
    $nlookup = $#{$self->{'LOOKUP'}};
    # process non-contextual lookups
    foreach $l (0 .. $nlookup)
    {
        my ($type) = $self->{'LOOKUP'}[$l]{'TYPE'};
        next if ($type >= $self->extension() - 2 && $type < $self->extension());
        $res = $self->subset_lookup($self->{'LOOKUP'}[$l]);

        if (!@{$res})
        {
            delete $self->{'LOOKUP'}[$l];
            vec($lkvec, $l, 1) = 0;
        }
        else
        {
            $self->{'LOOKUP'}[$l]{'SUB'} = $res;
            vec($lkvec, $l, 1) = 1;
        }
    }
    # now process contextual lookups knowing whether the other lookup is there
    # also collect the complete lookup list now
    foreach $l (0 .. $nlookup)
    {
        if (defined $self->{'LOOKUP'}[$l])
        {
            my ($type) = $self->{'LOOKUP'}[$l]{'TYPE'};
            if ($type >= $self->extension() - 2 && $type < $self->extension())
            {
                $res = $self->subset_lookup($self->{'LOOKUP'}[$l], $lkvec);
                if (!@{$res})
                {
                    delete $self->{'LOOKUP'}[$l];
                    vec($lkvec, $l, 1) = 0;
                }
                else
                {
                    $self->{'LOOKUP'}[$l]{'SUB'} = $res;
                    vec($lkvec, $l, 1) = 1;
                }
            }
        }
        if (vec($lkvec, $l, 1))
        {
            push (@lookups, $self->{'LOOKUP'}[$l]);
            push (@lmap, $count++);
        }
        else
        { push (@lmap, -1); }
    }
    
    $self->{'LOOKUP'} = \@lookups;
    foreach $l (@lookups)
    { $self->fixcontext($l, \@lmap); }

    foreach my $t (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
    {
        my $f = $self->{'FEATURES'}{$t};
        foreach $l (0 .. $#{$f->{'LOOKUPS'}})
        {
            my ($v) = $lmap[$f->{'LOOKUPS'}[$l]];
            if ($v < 0)
            { delete $f->{'LOOKUPS'}[$l]; }
            else
            { $f->{'LOOKUPS'}[$l] = $v; }
        }
        if (!@{$f->{'LOOKUPS'}})
        { delete $self->{'FEATURES'}{$t}; }
        else
        { $f->{'LOOKUPS'} = [grep {defined $_} @{$f->{'LOOKUPS'}}]; }
    }
    $self->{'FEATURES'}{'FEAT_TAGS'} = [grep {defined $self->{'FEATURES'}{$_}} @{$self->{'FEATURES'}{'FEAT_TAGS'}}];

    my ($isEmpty) = 1;
    foreach my $s (keys %{$self->{'SCRIPTS'}})
    {
        foreach $l (-1 .. $#{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}})
        {
            my $lang;
            if ($l < 0)
            { $lang = $self->{'SCRIPTS'}{$s}{'DEFAULT'}; }
            else
            { $lang = $self->{'SCRIPTS'}{$s}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]}; }

            if (defined $lang->{'FEATURES'})
            {
                foreach my $i (0 .. @{$lang->{'FEATURES'}})
                {
                    if (!defined $self->{'FEATURES'}{$lang->{'FEATURES'}[$i]})
                    { delete $lang->{'FEATURES'}[$i]; }
                }
                $lang->{'FEATURES'} = [grep {$_} @{$lang->{'FEATURES'}}];
            }
            if (defined $lang->{'DEFAULT'} && $lang->{'DEFAULT'} >= 0)
            {
                my ($found) = 0;
                foreach my $f (@{$self->{'FEATURES'}{'FEAT_TAGS'}})
                {
                    if ($self->{'FEATURES'}{$f}{'INDEX'} == $lang->{'DEFAULT'})
                    {
                        $found = 1;
                        last;
                    }
                }
                if (!$found)
                { $lang->{'DEFAULT'} = -1; }
            }
            if (($l >= 0 && defined $subsetter->{'langs'}
                && !defined $subsetter->{'langs'}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]})
                    || ((!defined $lang->{'FEATURES'} || !@{$lang->{'FEATURES'}})
                        && (!defined $lang->{'DEFAULT'} || $lang->{'DEFAULT'} < 0)))
            {
                if ($l < 0)
                { delete $self->{'SCRIPTS'}{$s}{'DEFAULT'}; }
                else
                {
                    delete $self->{'SCRIPTS'}{$s}{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l]};
                    delete $self->{'SCRIPTS'}{$s}{'LANG_TAGS'}[$l];
                }
            }
        }
        if ((defined $subsetter->{'scripts'} && !defined $subsetter->{'scripts'}{$s})
                || (!@{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}} && !defined $self->{'SCRIPTS'}{$s}{'DEFAULT'}))
        {
            delete $self->{'SCRIPTS'}{$s};
            next;
        }
        else
        { $isEmpty = 0; }
    }
    if ($isEmpty)
    {
        my ($k, $v);
        while (($k, $v) = each %{$self->{' PARENT'}})
        {
            if ($v eq $self)
            {
                delete $self->{' PARENT'}{$k};
                last;
            }
        }
    }
}

sub subset_lookup
{
    my ($self, $lookup, $lkvec) = @_;
    my ($s, $l);
    my ($res) = [];

    foreach $s (@{$lookup->{'SUB'}})
    {
        if (!$self->subset_subtable($subsetter, $s, $lookup, $lkvec)
            || !defined $s->{'RULES'} || !@{$s->{'RULES'}})
        { next; }
        $s->{'RULES'} = [grep {$_} @{$s->{'RULES'}}];
        # remove unused coverage indices
        if ($s->{'COVERAGE'})
        {
            my $c = $s->{'COVERAGE'}{'val'};
            my $i = 0;
            foreach my $k (sort {$c->{$a} <=> $c->{$b}} keys %{$c})
            { $c->{$k} = $i++; }
        }
        push (@{$res}, $s);
    }
    return $res;
}


sub subset_class
{
    my ($self, $subsetter, $classdef, $noremap) = @_;
    my ($res) = [];
    my ($count) = 0;
    my ($class) = $classdef->{'val'};

    foreach (sort {$a <=> $b} keys %{$class})
    {
        if (!$subsetter->keep_glyph($_))
        { delete $class->{$_}; }
        else
        {
            my $g = $subsetter->map_glyph($_);
            $class->{$g} = delete $class->{$_};
            $res->[$class->{$g}] = ++$count unless (defined $res->[$class->{$g}])
        }
    }
    # remap the class
    unless ($noremap)
    {
        foreach (keys %{$class})
        { $class->{$_} = $res->[$class->{$_}]; }
    }
    if (@{$res})
    { return $res; }
    else
    { return undef; }
}

sub subset_cover
{
    my ($self, $subsetter, $coverage, $rules) = @_;
    return $coverage if (defined $coverage->{'isremapped'});
    my $isEmpty = 1;
    my $cover = $coverage->{'val'};
    foreach (sort {$a <=> $b} keys %{$cover})
    {
        if (!$subsetter->keep_glyph($_))
        {
            delete $rules->[$cover->{$_}] if $rules;
            delete $cover->{$_};
        }
        else
        {
            $cover->{$subsetter->map_glyph($_)} = delete $cover->{$_};
            $isEmpty = 0;
        }
    }
    if ($isEmpty)
    { return undef; }
    else
    {
        $coverage->{'isremapped'} = 1;
        return $coverage;
    }
}

sub subset_string
{
    my ($self, $subsetter, $string, $fmt, $classvals) = @_;
    my ($test) = 1;

    return 0 if ($fmt == 2 && !$classvals);
    foreach (@{$string})
    {
        if ($fmt == 1 && $subsetter->keep_glyph($_))
        { $_ = $subsetter->map_glyph($_); }
        elsif ($fmt == 2 && defined $classvals->[$_])
        { $_ = $classvals->[$_]; }
        elsif ($fmt == 3 && $self->subset_cover($subsetter, $_, undef))
        { }
        else
        {
            $test = 0;
            last;
        }
    }
    return $test;
}

sub subset_context
{
    my ($self, $subsetter, $sub, $type, $lkvec) = @_;
    my ($fmt) = $sub->{'FORMAT'};
    my ($classvals, $prevals, $postvals, $i, $j, @gids);

    return 0 if (defined $sub->{'COVERAGE'} && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $fmt < 2 ? $sub->{'RULES'} : undef));
    while (my ($k, $v) = each %{$sub->{'COVERAGE'}{'val'}})
    { $gids[$v] = $k; }
    return 0 if (defined $sub->{'CLASS'} && !($classvals = $self->subset_class($subsetter, $sub->{'CLASS'})));
    return 0 if (defined $sub->{'PRE_CLASS'} && !($prevals = $self->subset_class($subsetter, $sub->{'PRE_CLASS'})));
    return 0 if (defined $sub->{'POST_CLASS'} && !($postvals = $self->subset_class($subsetter, $sub->{'POST_CLASS'})));
    # tidy up coverage tables that contain glyphs not in the matching class
#    if (defined $sub->{'CLASS'})
#    {
#        foreach $i (0 .. $#gids)
#        {
#            if (defined $gids[$i] && !defined $sub->{'CLASS'}{'val'}{$gids[$i]})
#            {
#                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};
#                delete $gids[$i];
#            }
#        }
#        @gids = grep {defined $_} @gids;
#    }
#    return 0 unless (@gids);


    foreach $i (0 .. @{$sub->{'RULES'}})
    {
        my ($isEmpty) = 1;
        if ($sub->{'RULES'}[$i])
        {
            foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
            {
                my ($r) = $sub->{'RULES'}[$i][$j];
                my ($test) = 1;
                if ($type == 4)
                {
                    if ($subsetter->keep_glyph($r->{'ACTION'}[0]))
                    { $r->{'ACTION'}[0] = $subsetter->map_glyph($r->{'ACTION'}[0]); }
                    else
                    { $test = 0; }
                }
                else
                {
                    foreach my $k (0 .. $#{$sub->{'RULES'}[$i][$j]{'ACTION'}})
                    {
                        my $a = $sub->{'RULES'}[$i][$j]{'ACTION'}[$k];
                        if (!vec($lkvec, $a->[1], 1))
                        { delete $sub->{'RULES'}[$i][$j]{'ACTION'}[$k]; }
                    }
                    $test = (@{$sub->{'RULES'}[$i][$j]{'ACTION'}} != 0);
                }
                if ($test && $type == 6 && defined $r->{'PRE'})
                { $test = $self->subset_string($subsetter, $r->{'PRE'}, $fmt, $prevals); }
                if ($test && $type == 6 && defined $r->{'POST'})
                { $test = $self->subset_string($subsetter, $r->{'POST'}, $fmt, $postvals); }
                if ($test)
                { $test = $self->subset_string($subsetter, $r->{'MATCH'}, $fmt, $classvals); }
                if (!$test)
                { delete $sub->{'RULES'}[$i][$j]; }
                else
                { $isEmpty = 0; }
            }
            $sub->{'RULES'}[$i] = [grep {$_} @{$sub->{'RULES'}[$i]}];
        }
        if ($isEmpty)
        {
            delete $sub->{'RULES'}[$i];
            delete $sub->{'COVERAGE'}{'val'}{$gids[$i]} if ($fmt < 2);  # already remapped
        }
    }
    return 1;
}

sub fixcontext
{
    my ($self, $l, $lmap) = @_;

    return if ($l->{'TYPE'} < $self->extension() - 2 || $l->{'TYPE'} >= $self->extension());
    foreach my $s (@{$l->{'SUB'}})
    {
        foreach my $r (@{$s->{'RULES'}})
        {
            foreach my $p (@{$r})
            {
                foreach my $b (@{$p->{'ACTION'}})
                { $b->[1] = $lmap->[$b->[1]]; }
            }
        }
    }
}


package Font::TTF::GSUB;

sub subset_subtable
{
    my ($self, $subsetter, $sub, $lookup, $lkvec) = @_;
    my ($type) = $lookup->{'TYPE'};
    my ($fmt) = $sub->{'FORMAT'};
    my ($r, $i, $j, @gids, $k, $v);

    return 0 if ($type < 4 && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'}));

    while (($k, $v) = each %{$sub->{'COVERAGE'}{'val'}})
    { $gids[$v] = $k; }

    if (($type == 1 && $fmt > 1) || $type == 2)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            next unless (defined $sub->{'RULES'}[$i]);
            foreach my $k (0 .. $#{$sub->{'RULES'}[$i][0]{'ACTION'}})
            {
                $j = $sub->{'RULES'}[$i][0]{'ACTION'}[$k];
                if (!$subsetter->keep_glyph($j))
                {
                    delete $sub->{'RULES'}[$i];
                    delete $sub->{'COVERAGE'}{'val'}{$gids[$i]}; # already remapped
                    last;
                }
                else
                { $sub->{'RULES'}[$i][0]{'ACTION'}[$k] = $subsetter->map_glyph($j); }
            }
        }
    }
    elsif ($type == 3)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            if (!defined $sub->{'RULES'}[$i])
            {
                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};
                next;
            }
            my $res = [];
            foreach $j (@{$sub->{'RULES'}[$i][0]{'ACTION'}})
            {
                if ($subsetter->keep_glyph($j))
                { push (@{$res}, $subsetter->map_glyph($j)); }
            }
            if (@{$res})
            { $sub->{'RULES'}[$i][0]{'ACTION'} = $res; }
            else
            {
                delete $sub->{'RULES'}[$i];
                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};  # already remapped
            }
        }
    }
    elsif ($type >=4 && $type <= 6)
    { return $self->subset_context($subsetter, $sub, $type, $lkvec); }
    return 1;
}

package Font::TTF::GPOS;

sub subset_subtable
{
    my ($self, $subsetter, $sub, $lookup, $lkvec) = @_;
    my ($type) = $lookup->{'TYPE'};
    my ($fmt) = $sub->{'FORMAT'};
    my (@gids) = sort { $a <=> $b} keys %{$sub->{'COVERAGE'}{'val'}};
    my ($i, $j, $k);

    return 0 if ($type <= 6 && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'}));
    if ($type == 2 && $fmt == 1)
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
            {
                my ($r) = $sub->{'RULES'}[$i][$j];
                if (!$subsetter->keep_glyph($r->{'MATCH'}[0]))
                { delete $sub->{'RULES'}[$i][$j]; }
                else
                { $r->{'MATCH'}[0] = $subsetter->map_glyph($r->{'MATCH'}[0]); }
            }
            if (!@{$sub->{'RULES'}[$i]})
            { delete $sub->{'RULES'}[$i]; }
            else
            { $sub->{'RULES'}[$i] = [grep {$_} @{$sub->{'RULES'}[$i]}]; }
        }
    }
    elsif ($type == 2 && $fmt == 2)
    {
        my ($c1vals) = $self->subset_class($subsetter, $sub->{'CLASS'});
        my ($c2vals) = $self->subset_class($subsetter, $sub->{'MATCH'}[0]);
        my ($nrules) = [];
        
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            if (!$c1vals->[$i])
            { delete $sub->{'RULES'}[$i]; }
            else
            {
                my (@nrule);
                foreach $j (0 .. $#{$sub->{'RULES'}[$i]})
                {
                    if (!defined $c2vals->[$j])
                    { delete $sub->{'RULES'}[$i][$j]; }
                    else
                    { $nrule[$c2vals->[$j]] = $sub->{'RULES'}[$i][$j]; }
                }
                if (@nrule)
                { $nrules->[$c1vals->[$i]] = [grep {$_} @nrule]; }
            }
        }
        if (@{$nrules})
        { $sub->{'RULES'} = $nrules; }
        else
        { return 0; }
    }
    elsif ($type >= 4 && $type <= 6)
    { return $self->subset_cover($subsetter, $sub->{'MATCH'}[0], $sub->{'MARKS'}) ? 1 : 0; }
    elsif ($type >=7 && $type <= 8)
    { return $self->subset_context($subsetter, $sub, $type - 2, $lkvec); }
    return 1;
}

package Font::TTF::GDEF;

sub subset
{
    my ($self, $subsetter) = @_;

    return unless ($self->SUPER::subset($subsetter));
    if (defined $self->{'GLYPH'})
    { delete $self->{'GLYPH'} unless (Font::TTF::Ttopen->subset_class($subsetter, $self->{'GLYPH'}, 1)); }
    if (defined $self->{'ATTACH'})
    { delete $self->{'ATTACH'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'ATTACH'}{'COVERAGE'}, $self->{'ATTACH'}{'POINTS'})); }
    if (defined $self->{'LIG'})
    { delete $self->{'LIG'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'LIG'}{'COVERAGE'}, $self->{'LIG'}{'POINTS'})); }
    if (defined $self->{'MARKS'})
    { delete $self->{'MARKS'} unless (Font::TTF::Ttopen->subset_cover($subsetter, $self->{'MARKS'}, undef)); }
}

package Font::TTF::Cmap;

sub subset
{
    my ($self, $subsetter) = @_;

    return unless ($self->SUPER::subset($subsetter));
    foreach my $i (0 .. $#{$self->{'Tables'}})
    {
        my ($t) = $self->{'Tables'}[$i]{'val'};
        foreach my $k (keys %{$t})
        {
            if ($subsetter->keep_glyph($t->{$k}))
            { $t->{$k} = $subsetter->map_glyph($t->{$k}); }
            else
            { delete $t->{$k}; }
        }
        if ($self->is_unicode($i))
        {
            foreach my $k (keys %{$subsetter->{'remaps'}})
            { $t->{$k} = $subsetter->map_glyph($subsetter->{'remaps'}{$k}); }
        }
    }
}

package Font::TTF::Post;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];

    return unless ($self->SUPER::subset($subsetter));
    # need to rewrite for real glyph remapping
    foreach my $i (0 .. @{$self->{'VAL'}})
    { $res->[$subsetter->map_glyph($i)] = $subsetter->keep_glyph($i) ? $self->{'VAL'}[$i] : ".notdef"; }
    $self->{'VAL'} = $res;
}

package Font::TTF::Hmtx;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($adv) = [];
    my ($lsb) = [];

    return unless ($self->SUPER::subset($subsetter));
    for (my $i = 0; $i < @{$self->{'advance'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        {
            my ($g) = $subsetter->map_glyph($i);
            $adv->[$g] = $self->{'advance'}[$i];
            $lsb->[$g] = $self->{'lsb'}[$i];
        }
    }
    $self->{'advance'} = $adv;
    $self->{'lsb'} = $lsb;
}

package Font::TTF::LTSH;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];

    return unless ($self->SUPER::subset($subsetter));
    for (my $i = 0; $i < @{$self->{'glyphs'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        { $res->[$subsetter->map_glyph($i)] = $self->{'glyphs'}[$i]; }
    }
    $self->{'glyphs'} = $res;
    $self->{'Num'} = $subsetter->{'gcount'};
}


package Font::TTF::Glat;

sub subset
{
    my ($self, $subsetter) = @_;
    my ($res) = [];

    return unless ($self->SUPER::subset($subsetter));
    for (my $i = 0; $i < @{$self->{'attribs'}}; $i++)
    {
        if ($subsetter->keep_glyph($i))
        { $res->[$subsetter->map_glyph($i)] = $self->{'attribs'}[$i]; }
    }
    $self->{'attribs'} = $res;
}

package Font::TTF::Silf;

# disable for now so we can check in initial code
sub subset
{
    my ($self, $subsetter) = @_;
    my ($s);

    return unless ($self->SUPER::subset($subsetter));
    foreach $s (@{$self->{'SILF'}})
    { $self->subset_silf($s, $subsetter); }
}

sub subset_silf
{
    my ($self, $silf, $subsetter) = @_;
    my ($p, $count);

    foreach $p (@{$silf->{'PASS'}})
    {
        my ($cinfo) = {};
        push (@{$subsetter->{'silf'}{'passes'}}, $cinfo);
        $self->markdels($p, $subsetter, $cinfo);
    }

    # calculate substitution classes 
    for (my $i = 0; $i < scalar @{$silf->{'classes'}}; $i++)
    {
        my ($c) = $silf->{'classes'}[$i];
        my (@class) = sort {$c->{$a} <=> $c->{$b}} keys %{$c};
        my (@subsetclass) = grep ($subsetter->keep_glyph($_), @class);
        unless (scalar @subsetclass)
        {
            $subsetter->{'silf'}{'numclasses'}{$i} = -1;
            while (my ($k, $v) = each %{$subsetter->{'silf'}{'numclass_pairs'}})
            { $v->{$i} = -1 if (defined $v->{$i}); }
            next unless (defined $subsetter->{'silf'}{'numclass_pairs'}{$i});
            while (my ($k, $v) = each %{$subsetter->{'silf'}{'numclass_pairs'}{$i}})
            { $subsetter->{'silf'}{'numclass_pairs'}{$i}{$k} = -1; }
            next;
        }
        next unless (defined $subsetter->{'silf'}{'numclass_pairs'}{$i});
        while (my ($k, $v) = each %{$subsetter->{'silf'}{'numclass_pairs'}{$i}})
        {
            next if ($v < 0);
            my (@subother) = grep ($subsetter->keep_glyph($_), keys %{$silf->{'classes'}[$k]});
            next if (scalar @subother == scalar keys %{$silf->{'classes'}[$k]} and
                scalar @subsetclass == scalar @class);
            @subother = ();
            my (@subthis) = ();
            my ($co) = $silf->{'classes'}[$k];
            my (@otherclass) = sort {$co->{$a} <=> $co->{$b}} keys %{$co};
            for (my $j = 0; $j < @class; $j++)
            {
                my ($a) = $class[$j];
                my ($b) = $otherclass[$j];
                if ($subsetter->keep_glyph($a) and $subsetter->keep_glyph($b))
                {
                    push (@subother, $b);
                    push (@subthis, $a);
                }
                elsif ($subsetter->keep_glyph($a))
                { push (@{$subsetter->{'silf'}{'class_pairs_removed'}{$i}{$k}}, $a); }
            }
            if (!scalar @subthis)
            { $subsetter->{'silf'}{'numclass_pairs'}{$i}{$k} = -1; }
            else
            { $subsetter->{'silf'}{'class_pairs'}{$i}{$k} = [[@subthis], [@subother]]; }
        }
    }

    # see what other rules we can delete
    for (my $i = 0; $i < scalar @{$silf->{'PASS'}}; $i++)
    { $self->testrules($silf->{'PASS'}[$i], $subsetter, $subsetter->{'silf'}{'passes'}[$i]); }

    # make new, mapped, classes and a map from one to the other, update class_pairs to return [in_new_class_id, out_new_class_id]
    # also do class reduction.
    $subsetter->{'silf'}{'classes'} = [];
    $subsetter->{'silf'}{'classmap'} = [];
    for (my $i = 0; $i < scalar @{$silf->{'classes'}}; $i++)
    {
        my ($c) = $silf->{'classes'}[$i];
        my (@newclass);
        foreach (sort {$c->{$a} <=> $c->{$b}} keys %{$c})
        {
            if ($subsetter->keep_glyph($_))
            { push (@newclass, $subsetter->map_glyph($_)); }
        }
        if (scalar @newclass)
        {
            my ($i) = 0;
            push (@{$subsetter->{'silf'}{'classes'}}, {map {$_ => $i++} @newclass});
            push (@{$subsetter->{'silf'}{'classmap'}}, $#{$subsetter->{'silf'}{'classes'}});
            if ($DEBUG)
            {
                print "class(".($#{$subsetter->{'silf'}{'classes'}}).") ";
                print join(",", @newclass)."\n";
            }
        }
        else
        { push (@{$subsetter->{'silf'}{'classmap'}}, -1); }
        next unless (defined $subsetter->{'silf'}{'class_pairs'}{$i});
        while(my ($k,$v) = each %{$subsetter->{'silf'}{'class_pairs'}{$i}})
        { $subsetter->{'silf'}{'class_pairs'}{$i}{$k} = [map {$self->addmappedclass($_, $subsetter)} @{$v}]; }
    }

    # see what other rules we can delete
    for (my $i = 0; $i < scalar @{$silf->{'PASS'}}; $i++)
    { 
        unless ($self->finalise_pass($silf->{'PASS'}[$i], $subsetter, $subsetter->{'silf'}{'passes'}[$i]))
        {
            splice(@{$silf->{'PASS'}}, $i, 1);
            splice(@{$subsetter->{'silf'}{'passes'}}, $i, 1);
            foreach ('substPass', 'posPass', 'justPass', 'bidiPass')
            { $silf->{$_}-- if ($i < $silf->{$_} and $silf->{$_} != 0xFF); }
            $i--;
        }
    }

    $silf->{'maxGlyphID'} = $subsetter->{'gcount'} - 1;
    $silf->{'classes'} = $subsetter->{'silf'}{'classes'};
}

# algorithm section 1
sub markdels
{
    my ($self, $pass, $subsetter, $cinfo) = @_;

    # 1.2 mark kept columns
    for (my $i = 0; $i < $subsetter->{'numg'}; ++$i)
    {
        if (defined $pass->{'colmap'}{$i} and $subsetter->keep_glyph($i))
        {
            vec($cinfo->{'cols'}, $pass->{'colmap'}{$i}, 1) = 1;
            push (@{$cinfo->{'glyphcols'}[$pass->{'colmap'}{$i}]}, $i);
        }
    }

    # prepare back references to allow easy row deletion
    # empty rowfwdrefs means deleted.
    $cinfo->{'rowfwdrefs'} = [];
    $cinfo->{'rowbackrefs'} = [];
    for (my $i = 0; $i < $pass->{'numRows'}; $i++)
    {
        $cinfo->{'rowfwdrefs'}[$i] = {};
        $cinfo->{'rowbackrefs'}[$i] = {};
    }
    for (my $i = 0; $i < scalar @{$pass->{'fsm'}}; $i++)
    {
        my ($fsm) = $pass->{'fsm'}[$i];
        for (my $j = 0; $j < scalar @{$fsm}; $j++)
        {
            next unless (vec($cinfo->{'cols'}, $j, 1));
            my ($t) = $fsm->[$j];
            if ($t)
            {
                $cinfo->{'rowfwdrefs'}[$i]{$t} = 1;
                $cinfo->{'rowbackrefs'}[$t]{$i} = 1;
            }
        }
    }
    # delete all rows that are not referenced
    for (my $i = 0; $i < $pass->{'numRows'}; $i++)
    {
        # next unless (grep($_ == $i, @{$pass->{'startStates'}}));    # this should go, but needs special handling
        if (    (!scalar keys %{$cinfo->{'rowfwdrefs'}[$i]} and $i < $pass->{'numTransitional'} and !$self->isFinal($pass, $cinfo, $i))
            or  (!scalar keys %{$cinfo->{'rowbackrefs'}[$i]} and !$self->isStart($pass, $i)))
        { $self->delrow($pass, $cinfo, $i); }
    }

    # 1.4 mark kept rules
    # row value can be 0, 1, 3; never is 2, since how can you have outgoing if you aren't reached.
    for (my $i = $pass->{'numRows'} - $pass->{'numSuccess'}; $i < $pass->{'numRows'}; ++$i)
    {
        if (scalar keys %{$cinfo->{'rowbackrefs'}[$i]})
        {
            my (@rlist) = @{$pass->{'rulemap'}[$i - $pass->{'numRows'} + $pass->{'numSuccess'}]};
            foreach (@rlist)
            { push (@{$cinfo->{'rules'}[$_]}, $i); }
            $cinfo->{'rulemap'}[$i] = [@rlist];
        }
    }

    # 1.5 analyse test constraint code and possibly delete.

    # 1.6 parse and associate substitutionary classes
    for (my $i = 0; $i < $pass->{'numRules'}; ++$i)
    {
        next unless (defined $cinfo->{'rules'}[$i] and @{$cinfo->{'rules'}[$i]});
        my (@rinfo) = $self->unpack_code($pass->{'actionCode'}[$i]);
        foreach my $r (@rinfo)
        {
            if ($r->[0] eq 'put_subs_8bit_obs' or $r->[0] eq 'put_subs')
            { $subsetter->{'silf'}{'numclass_pairs'}{$r->[2]}{$r->[3]}++; }
            elsif ($r->[0] eq 'put_glyph_8bit_obs' or $r->[0] eq 'put_glyph')
            { $subsetter->{'silf'}{'numclasses'}{$r->[1]}++; }
        }
    }
}

sub testrules
{
    my ($self, $pass, $subsetter, $cinfo) = @_;

    for (my $i = 0; $i < $pass->{'numRules'}; ++$i)
    {
        next unless (defined $cinfo->{'rules'}[$i] and @{$cinfo->{'rules'}[$i]});
        my (@rinfo) = $self->unpack_code($pass->{'actionCode'}[$i]);
        foreach my $r (@rinfo)
        {
            if (   (($r->[0] eq 'put_subs_8bit_obs' or $r->[0] eq 'put_subs')
                     and $subsetter->{'silf'}{'numclass_pairs'}{$r->[2]}{$r->[3]} < 0)
                or (($r->[0] eq 'put_glyph_8bit_obs' or $r->[0] eq 'put_glyph')
                     and $subsetter->{'silf'}{'numclasses'}{$r->[1]} < 0))
            { $self->delrule($pass, $subsetter, $cinfo, $i); }
        }
    }
}

sub finalise_pass
{
    my ($self, $pass, $subsetter, $cinfo) = @_;
    my ($i);

    # 5.4 create rule map
    my (@rulemap);
    my ($numrules);
    for (my $i = 0; $i < $pass->{'numRules'}; $i++)
    {
        if (defined $cinfo->{'rules'}[$i] and @{$cinfo->{'rules'}[$i]})
        {
            # print "rule($i->$numrules): " . join(",", @{$cinfo->{'rules'}[$i]}) . "\n";
            push (@rulemap, $numrules++);
        }
        else
        { push (@rulemap, -1); }
    }

    my (@rules);
    # 5.6, 5.7 create row->rule lists and remap rules and the like
    for (my $i = 0; $i < $pass->{'numRules'}; $i++)
    {
        next if ($rulemap[$i] < 0);
        my (@rinfo) = $self->unpack_code($pass->{'actionCode'}[$i]);
        my ($c) = 0;
        foreach my $r (@rinfo)
        {
            if ($r->[0] eq 'next' or $r->[0] eq 'copy_next')
            { $c++; }
            elsif ($r->[0] eq 'put_subs_8bit_obs' or $r->[0] eq 'put_subs')    # need to handle upsizing to 16-bit and perhaps downsizing
            {
                if (defined $subsetter->{'silf'}{'class_pairs'}{$r->[2]}{$r->[3]})
                {
                    $self->remove_trail($subsetter, $cinfo, $pass, $i, $c, 
                        $subsetter->{'silf'}{'class_pairs_removed'}{$r->[2]}{$r->[3]})
                            if (defined $subsetter->{'silf'}{'class_pairs_removed'}{$r->[2]}{$r->[3]});
                    ($r->[2], $r->[3]) = @{$subsetter->{'silf'}{'class_pairs'}{$r->[2]}{$r->[3]}};
                }
                else
                {
                    testclass($r->[2], $subsetter, "pass $pass->{'id'}, rule ${i}a");
                    testclass($r->[3], $subsetter, "pass $pass->{'id'}, rule ${i}b");
                    $r->[2] = $subsetter->{'silf'}{'classmap'}[$r->[2]];
                    $r->[3] = $subsetter->{'silf'}{'classmap'}[$r->[3]];
                }
            }
            elsif ($r->[0] eq 'put_glyph_8bit_obs' or $r->[0] eq 'put_glyph')
            {
                testclass($r->[1], $subsetter, "pass $pass->{'id'}, rule $i");
                $r->[1] = $subsetter->{'silf'}{'classmap'}[$r->[1]];
            }
            # log which glyph attributes are actually referenced and delete the rest.
        }
        push (@rules, $self->pack_code(\@rinfo));
    }

    # rebuild startStates given some of them may have been deleted.
    for ($i = 0; $i < scalar @{$pass->{'startStates'}}; $i++)
    {
        my ($r) = $pass->{'startStates'}[$i];
        last if (scalar keys %{$cinfo->{'rowfwdrefs'}[$r]} or scalar keys %{$cinfo->{'rowbackrefs'}[$r]})
    }
    if ($i < scalar @{$pass->{'startStates'}})
    {
        splice(@{$pass->{'startStates'}}, 0, $i);
        $pass->{'maxRulePreContext'} -= $i;
    }
    else
    {
        print "No start states so exit pass $pass->{'id'}\n";
        return 0;
    }
    if ($pass->{'minRulePreContext'} >= $pass->{'maxRulePreContext'})
    { $pass->{'minRulePreContext'} = $pass->{'maxRulePreContext'}; }
    else
    {
        for ($i = 0; $i < scalar @{$pass->{'startStates'}}; $i++)
        {
            my ($r) = $pass->{'startStates'}[$#{$pass->{'startStates'}} - $i];
            last if (scalar keys %{$cinfo->{'rowfwdrefs'}[$r]} or scalar keys %{$cinfo->{'rowbackrefs'}[$r]});
        }
        if ($i)
        {
            splice (@{$pass->{'startStates'}}, -$i);
            $pass->{'minRulePreContext'} += $i;
        }
    }

    my (@colmap, @allcols);
    my ($numcolumns);
    my (@rowmap, @fsm, @allrows);
    my ($numrows);
    my (@temp) = (0 .. $pass->{'numTransitional'} - 1);
    push (@temp, ($pass->{'numRows'} .. $cinfo->{'totalRows'} - 1)) if ($cinfo->{'totalRows'});
    # @temp = grep {scalar keys %{$cinfo->{'rowbackrefs'}[$_]} or scalar keys %{$cinfo->{'rowfwdrefs'}[$_]}} @temp;
    my (@rlist) = grep {!defined $cinfo->{'rulemap'}[$_] or !@{$cinfo->{'rulemap'}[$_]}} @temp;
    push (@rlist, grep {defined $cinfo->{'rulemap'}[$_] and @{$cinfo->{'rulemap'}[$_]}} @temp);
    my ($merged) = 1;
    while ($merged)
    {
        $merged = 0;
        # 5.3 create rowmap. Add row merging loop
        @rowmap = (); @allrows = ();
        $numrows = 0;
        foreach my $i (@rlist)
        {
            if (scalar keys %{$cinfo->{'rowbackrefs'}[$i]} or scalar keys %{$cinfo->{'rowfwdrefs'}[$i]} or grep($_ == $i, @{$pass->{'startStates'}}))
            {
                push (@allrows, $i);
                $rowmap[$i] = $numrows++;
            }
            else
            { $rowmap[$i] = -1; }
        }
        my (%finalshash) = ();
        for (my $i = $pass->{'numTransitional'}; $i < $pass->{'numRows'}; $i++)
        {
            if (scalar keys %{$cinfo->{'rowbackrefs'}[$i]})
            {
                my ($s) = join(",", @{$cinfo->{'rulemap'}[$i]});
                if (!exists $finalshash{$s})
                {
                    $rowmap[$i] = $numrows++;
                    $finalshash{$s} = $i;
                }
                else
                {
                    $self->mergerow($i, $finalshash{$s}, $pass, $cinfo);
                    $rowmap[$i] = -1;
                }
            }
            else
            { $rowmap[$i] = -1; }
        }

        # create column map. Add column merging loop
        my (%colshash) = ();
        @colmap = (); @allcols = (); $numcolumns = 0;
        for (my $j = 0; $j < $pass->{'numColumns'}; $j++)
        {
            my ($v, $c, $found);
            if (vec($cinfo->{'cols'}, $j, 1))
            {
                foreach my $r (@allrows)
                {
                    my ($f) = $rowmap[$pass->{'fsm'}[$r][$j]];
                    if ($f > 0)
                    {
                        $found = 1;
                        vec($v, $c++, 16) = $f;
                    }
                    else
                    { vec($v, $c++, 16) = 0; }
                }
            }
            if (!$found)
            {
                push (@colmap, -1);
                next;
            }

            if (!exists $colshash{$v})
            {
                $colshash{$v} = $numcolumns;
                push (@colmap, $numcolumns++);
                push (@allcols, $j);
            }
            else
            { push (@colmap, $colshash{$v}); }
        }

        # 5.5 create fsm - rewrite me for handling added rows
        my (%rowhash) = ();
        @fsm = ();
        foreach my $i (@allrows)
        {
            if ($rowmap[$i] >= 0)
            {
                my (@row, $k, $v);
                foreach my $j (@allcols)
                {
                    my ($f) = $pass->{'fsm'}[$i][$j];
                    if ($rowmap[$f] > 0)
                    { push (@row, $rowmap[$f]); }
                    else
                    { push (@row, 0); }
                    vec($v, $k++, 16) = $row[-1];
                }
                push (@fsm, [@row]);
                if (exists $rowhash{$v} and !arraycmp($cinfo->{'rulemap'}[$i], $cinfo->{'rulemap'}[$rowhash{$v}]) and !grep {$_ == $i} @{$pass->{'startStates'}})
                {
                    $self->mergerow($i, $rowhash{$v}, $pass, $cinfo);
                    $merged = 1;
                }
                else
                { $rowhash{$v} = $i; }
            }
        }
    }

    # create row to rules mapping for output
    my (@keys, @prectxts);
    my ($numSuccess) = findmappedrow($pass->{'numRows'} - $pass->{'numSuccess'}, \@rowmap, 1);
    my (@rowrules);
    if ($numSuccess < 0)
    {
        print "No success states, so no rules in $pass->{'id'}\n" if ($DEBUG);
        return 0;
    }
    for (my $i = 0; $i < $pass->{'numRules'}; $i++)
    {
        next if ($rulemap[$i] < 0);
        foreach my $r (@{$cinfo->{'rules'}[$i]})
        {
            if ($rowmap[$r] >= 0)
            { push (@{$rowrules[$rowmap[$r] - $numSuccess]}, $rulemap[$i]); }
        }
        $keys[$rulemap[$i]] = $pass->{'ruleSortKeys'}[$i];
        $prectxts[$rulemap[$i]] = $pass->{'rulePreContexts'}[$i];
    }
   
    # 5.8 create gid->column mapping
    my (%cols);
    while (my ($k, $v) = each %{$pass->{'colmap'}})
    {
        if ($colmap[$v] >= 0 and $subsetter->keep_glyph($k))
        { $cols{$subsetter->map_glyph($k)} = $colmap[$v]; }
    }

    # remap constraint code. Probably should check it for class references or something
    my (@ruleconstraints);
    for (my $i; $i < $pass->{'numRules'}; $i++)
    {
        if ($rulemap[$i] >= 0)
        { $ruleconstraints[$rulemap[$i]] = $pass->{'constraintCode'}[$i]; }
    }

    # put everything back
    $pass->{'fsm'} = [@fsm];
    $pass->{'numSuccess'} = $numSuccess < 0 ? 0 : $numrows - $numSuccess;
    $pass->{'numTransitional'} = scalar @fsm;
    $pass->{'numRows'} = $numrows;
    $pass->{'numColumns'} = $numcolumns;
    $pass->{'colmap'} = {%cols};
    $pass->{'rulemap'} = [@rowrules];
    $pass->{'startStates'} = [map {$rowmap[$_]} @{$pass->{'startStates'}}];
    $pass->{'ruleSortKeys'} = [@keys];
    $pass->{'rulePreContexts'} = [@prectxts];
    $pass->{'actionCode'} = [@rules];
    $pass->{'constraintCode'} = [@ruleconstraints];
    $pass->{'numRules'} = $numrules;
    return 1;
}

sub testclass
{
    my ($c, $subsetter, $d) = @_;
    if ($subsetter->{'silf'}{'classmap'}[$c] == -1)
    { warn ("Bad class $c in $d\n"); }
}

sub findmappedrow
{
    my ($ind, $arr, $dir) = @_;
    $dir = -1 unless (defined $dir);
    while ($arr->[$ind] < 0 && $ind >= 0 && $ind < scalar @{$arr})
    { $ind += $dir; }
    return -1 if ($ind < 0 or $ind >= scalar @{$arr});
    return $arr->[$ind];
}

sub delrule
{
    my ($self, $pass, $subsetter, $cinfo, $num) = @_;

    foreach my $r (@{$cinfo->{'rules'}[$num]})
    {
        $cinfo->{'rulemap'}[$r] = [grep ($_ != $num, @{$cinfo->{'rulemap'}[$r]})];
        if (!scalar @{$cinfo->{'rulemap'}[$r]})    # and $r < $pass->{'numTransitional'})
        { $self->delrow($pass, $cinfo, $r); }
    }
    $cinfo->{'rules'}[$num] = [];
}

sub isStart
{
    my ($self, $pass, $row) = @_;
    if (grep {$_ == $row} @{$pass->{'startStates'}})
    { return 1; }
    else
    { return 0; }
}

sub isFinal
{
    my ($self, $pass, $cinfo, $row) = @_;
    return 0 if ($row < $pass->{'nomRows'} - $pass->{'numSuccess'});
    return 0 if ($row > $pass->{'numRows'} and (!defined $cinfo->{'rulemap'}[$row] or !@{$cinfo->{'rulemap'}[$row]}));
    return 1;
}

sub delrow
{
    my ($self, $pass, $cinfo, $row) = @_;

    foreach my $r (keys %{$cinfo->{'rowfwdrefs'}[$row]})
    {
        delete $cinfo->{'rowbackrefs'}[$r]{$row};
        $self->delrow($pass, $cinfo, $r) unless (scalar keys %{$cinfo->{'rowbackrefs'}[$r]});
    }
    $cinfo->{'rowfwdrefs'}[$row] = {};
    foreach my $k (keys %{$cinfo->{'rowbackrefs'}[$row]})
    {
        delete $cinfo->{'rowfwdrefs'}[$k]{$row};
        $self->delrow($pass, $cinfo, $k) unless (scalar keys %{$cinfo->{'rowfwdrefs'}[$k]} or $self->isFinal($pass, $cinfo, $k));
    }
    $cinfo->{'rowbackrefs'}[$row] = {};
    foreach my $r (@{$cinfo->{'rulemap'}[$row]})
    {
        $cinfo->{'rules'}[$r] = [grep ($_ != $row, @{$cinfo->{'rules'}[$r]})];
        $self->delrule($r) unless (scalar @{$cinfo->{'rules'}[$r]});
    }
    return if ($row >= $pass->{'numTransitional'} && $row < $pass->{'numRows'});

    my (@collist);
    for (my $j = 0; $j < $pass->{'numColumns'}; $j++)
    {
        if (vec($cinfo->{'cols'}, $j, 1) and $pass->{'fsm'}[$row][$j])
        { push (@collist, $j); }
    }
    return unless (@collist);
    for (my $i = 0; $i < $pass->{'numTransitional'}; $i++)
    {
        next unless (scalar keys %{$cinfo->{'rowfwdrefs'}[$i]});
        foreach my $j (@collist)
        {
            if ($pass->{'fsm'}[$i][$j])
            { @collist = grep ($_ != $j, @collist); }
        }
    }
    foreach my $j (@collist)
    { vec($cinfo->{'cols'}, $j, 1) = 0; }    
}

sub addmappedclass
{
    my ($self, $class, $subsetter) = @_;
    my ($l) = scalar @{$class};
    my (@m) = map {$subsetter->map_glyph($_)} @{$class};

    for (my $i = 0; $i < @{$subsetter->{'silf'}{'classes'}}; $i++)
    {
        my ($c) = $subsetter->{'silf'}{'classes'}[$i];
        next unless (scalar keys %{$c} == $l);
        if (!grep {!defined $c->{$m[$_]} or $_ != $c->{$m[$_]}} (0 .. $l - 1))
        { return $i; }
    }
    my ($i) = 0;
    push (@{$subsetter->{'silf'}{'classes'}}, {map {$_ => $i++} @m});
    if ($DEBUG)
    { print "class(" . $#{$subsetter->{'silf'}{'classes'}} . ") " . join(",", @m) . ".\n"; } 
    return $#{$subsetter->{'silf'}{'classes'}};
}

sub addrowsfor
{
    my ($self, $pass, $cinfo, $cols, $len, $row, $parent, $total) = @_;
    my ($res);

    if ($len == 0)
    {
        my (@entries) = grep {$pass->{'fsm'}[$row][$_] == $parent} (0 .. $#{$pass->{'fsm'}[$row]});
        my (@locals) = grep {!defined $cols->{$_}} @entries;
        my (@news) = grep {defined $cols->{$_}} @entries;
        if (!@news)
        { return undef; }
        elsif (@locals)
        {
            $res = $self->addcopyrow($pass, $cinfo, $parent);
            foreach my $r (@news)       # is this right or is it @news that are in @locals?
            { $pass->{'fsm'}[$row][$r] = $res; }
            if (!grep {$pass->{'fsm'}[$row][$_] == $parent} @locals)
            {
                delete $cinfo->{'rowfwdrefs'}[$row]{$parent};
                delete $cinfo->{'rowbackrefs'}[$parent]{$row};
            }
            return $res;
        }
        else
        { return $parent; }
    }
    else
    {
        my (@rets, $neednew, $res);
        foreach my $r (keys %{$cinfo->{'rowbackrefs'}[$row]})
        {
            my ($x) = $self->addrowsfor($pass, $cinfo, $cols, $len - 1, $r, $row, $total);
            next if (!defined $x);
            $neednew = 1 if ($x != $r);
            push (@rets, $x) if (!grep {$_ == $x} @rets);
        }
        return undef unless (@rets);
        return $parent unless ($neednew);
        if ($len < $total - 1)
        { $res = $self->addcopyrow($pass, $cinfo, $parent); }
        else
        { $res = 0; }
        foreach my $r (@rets)
        {
            foreach my $c (@{$pass->{'fsm'}[$r]})
            { $c = $res if ($c == $parent); }
            delete $cinfo->{'rowfwdrefs'}[$r]{$parent};
            delete $cinfo->{'rowbackrefs'}[$parent]{$r};
            if ($res)
            {
                $cinfo->{'rowfwdrefs'}[$r]{$res} = 1;
                $cinfo->{'rowbackrefs'}[$res]{$r} = 1;
            }
            elsif (!scalar keys %{$cinfo->{'rowfwdrefs'}[$r]})
            { $self->delrow($pass, $cinfo, $r); }
        }
        return $res;
    }
}
            
sub remove_trail
{
    my ($self, $subsetter, $cinfo, $pass, $rule, $index, $glyphlist) = @_;
    $index += $pass->{'rulePreContexts'}[$rule];
    my ($countback) = $pass->{'ruleSortKeys'}[$rule] - $index;
    my (@glyphs) = (@{$glyphlist});
    my (@paths, @collist);
    my ($fsm) = $pass->{'fsm'};

    # Identify columns to split and split them
    while (@glyphs)
    {
        my (@glist, $newc);
        my ($g) = shift(@glyphs);
        my ($c) = $pass->{'colmap'}{$g};
        push (@glist, $g);
        for (my $i = 0; $i < @glyphs; )
        {
            if ($pass->{'colmap'}{$glyphs[$i]} == $c)
            {
                push (@glist, $glyphs[$i]);
                splice (@glyphs, $i, 1);
            }
            else
            { $i++; }
        }
        if (defined $cinfo->{'glyphcols'} and scalar @{$cinfo->{'glyphcols'}[$c]} != scalar @glist)
        { $self->splitcol($c, \@glist, $pass, $cinfo); }
    }

    # get a list of paths to trim. Each path includes the final row and is from to end to start
    my (%rowmap);
    my (%colhash) = map {$pass->{'colmap'}{$_} => 1} @{$glyphlist};
    foreach my $p (@{$cinfo->{'rules'}[$rule]})
    {
        foreach my $r (keys %{$cinfo->{'rowbackrefs'}[$p]})
        { $self->addrowsfor($pass, $cinfo, \%colhash, $countback - 1, $r, $p, $countback); }
    }

    while (my ($k, $r) = each %rowmap)
    {
        foreach my $rb (keys %{$cinfo->{'rowbackrefs'}[$r]})
        {
            next if (defined $rowmap{$rb});
            foreach my $c (keys %colhash)
            {
                if ($pass->{'fsm'}[$rb][$c] == $k)
                {
                    $pass->{'fsm'}[$rb][$c] = $r;
                    if (!grep {$_ == $k} @{$pass->{'fsm'}[$rb]})
                    {
                        delete $cinfo->{'rowfwdrefs'}[$rb]{$k};
                        delete $cinfo->{'rowbackrefs'}[$k]{$rb};
                    }
                    $cinfo->{'rowfwdrefs'}[$rb]{$r} = 1;
                    $cinfo->{'rowbackrefs'}[$r]{$rb} = 1;
                }
            }
        }
        my ($f) = $pass->{'fsm'}[$r];
        foreach (keys %{$cinfo->{'rowfwdrefs'}[$r]})
        { delete $cinfo->{'rowfwdrefs'}[$r]{$_} unless (defined $rowmap{$_}); }
        for (my $i = 0; $i < @{$f}; $i++)
        {
            my ($replace) = $f->[$i];
            if (defined $colhash{$i} and grep {$_ == $replace} @{$cinfo->{'rules'}[$rule]})
            { $replace = 0; }
            elsif (defined $rowmap{$replace})
            { $replace = $rowmap{$replace}; }
            next unless ($replace != $f->[$i]);
            delete $cinfo->{'rowbackrefs'}[$f->[$i]]{$r};
            $f->[$i] = $replace;
            if ($replace)
            {
                $cinfo->{'rowfwdrefs'}[$r]{$replace} = 1;
                $cinfo->{'rowbackrefs'}[$replace]{$r} = 1;
            }
        }
    }
}

sub splitcol
{
    my ($self, $col, $removes, $pass, $cinfo) = @_;
    my ($new) = $pass->{'numColumns'}++;
    my (%others) = map {$_ => 1} @{$removes};
    $cinfo->{'glyphcols'}[$col] = [grep {!defined $others{$_}} @{$cinfo->{'glyphcols'}[$col]}];
    $cinfo->{'glyphcols'}[$new] = [@{$removes}];

    foreach my $r (@{$pass->{'fsm'}})
    {
        next unless (defined $r);
        push (@{$r}, $r->[$col]);
    }
    vec($cinfo->{'cols'}, $new, 1) = 1;
    foreach my $g (@{$removes})
    { $pass->{'colmap'}{$g} = $new; }
    return $new;
}

sub addcopyrow
{
    my ($self, $pass, $cinfo, $row) = @_;
    my ($new) = $cinfo->{'totalRows'} || $pass->{'numRows'};
    $cinfo->{'totalRows'} = $new + 1;
    foreach ('fsm', 'rulemap')
    { $pass->{$_}[$new] = [@{$pass->{$_}[$row]}] if (defined $pass->{$_}[$row]); }
    foreach ('rowfwdrefs', 'rowbackrefs')
    { $cinfo->{$_}[$new] = {%{$cinfo->{$_}[$row]}}; }
    foreach (keys %{$cinfo->{'rowfwdrefs'}[$new]})
    { $cinfo->{'rowbackrefs'}[$_]{$new} = 1; }
    return $new;
}

# assumes from and to have the same contents
sub mergerow
{
    my ($self, $from, $to, $pass, $cinfo) = @_;

    foreach my $r (keys %{$cinfo->{'rowbackrefs'}[$from]})
    {
        foreach my $c (@{$pass->{'fsm'}[$r]})
        { $c = $to if ($c == $from); }
        $cinfo->{'rowfwdrefs'}[$r]{$to} = 1;
        $cinfo->{'rowbackrefs'}[$to]{$r} = 1;
    }
    $self->delrow($pass, $cinfo, $from);
}

sub arraycmp
{
    my ($a, $b) = @_;
    if (!defined $a)
    {
        return 0 if (!defined $b or !@{$b});
        return 1;
    }
    elsif (!defined $b)
    {
        return 0 if (!@{$a});
        return -1;
    }
    my ($res) = @{$a} <=> @{$b};
    return $res if ($res != 0);

    for (my $i = 0; $i < @{$a}; $i++)
    {
        $res = $a->[$i] <=> $b->[$i];
        return $res if ($res != 0)
    }
    return 0;
}

__END__

=head1 TITLE

ttfsubset - subset a font

=head1 SYNOPSIS

ttfsubset [options] infont outfont

Opens infont (a .ttf file), subsets it according to the supplied options, then writes the resulting file to outfont.

=head1 OPTIONS

  -h            Get full help
  -d tag[,...]  List of font tables to remove.
  -g listfile   File containing list of glyphs to retain 
  -s tag[,...]  List of OpenType script tags to retain
  -l tag[,...]  List of OpenType language tags to retain
  -n name       Renames the font to the given name (as per ttfname -n)

=head1 DESCRIPTION

ttfsubset removes parts of a font in order to produce a working, smaller, font. Multiple subsetting 
strategies are provided and controlled by options.

The C<-d> option is used to delete whole font tables, e.g., all Graphite tables. A 
list of four-letter table tags identifies the tables to be removed. As in L<ttftable>, 
the following (case insensitive) pseudo tags can also be used:

  graphite  all SIL Graphite tables (Silf Feat Gloc Glat Sill Sile)
  volt      all Microsoft VOLT tables (TSIV TSID TSIP TSIS)
  opentype  all OpenTYpe tables (GDEF GSUB GPOS)

The C<-g> option specifies a file that lists glyphs to be retained in the 
subset font -- ttfsubset will remove all other glyphs and then do what it can to simplify
remaining features.  Glyphs are identified in the file using space-separated indentifiers which
can be decimal numeric glyph IDs, postscript glyph names, or hexidecimal Unicode scalar values in the format
of U+xxxx. Ranges of glyphs (specified by either glyph ID or postscript name) and of Unicode scalar values
can be specified using '..' between the values. Glyph identifiers or ranges may be followed immediately by 
equals sign and 4 to 6 hex digits to indicate the glyph(s) should be encoded.

The C<-s> and C<-l> options identify OpenType script and language (respectively) tags
to retain in the font. The Default language is always retained, so specify C<-l ''> to remove all but the default language. 

=head1 BUGS

ttfsubset is an evolving tool and the invitation is given to contribute improvements that will result
in smaller output fonts.

=cut