#!/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('Cd:g:hHl: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 EBDT EBLC EBSC Silt aat /oi;
    $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/ mort morx feat /oi;
    $opts{'d'} .= " fpgm cvt_ prep" if (defined $opts{'H'});
    # Split generously (spaces, comma, colon, semicolon)
    foreach my $tag (grep {length($_) == 4} split(/[\s,:;]+/, $opts{'d'}))
    {
        $tag =~ s/_/ /og;
        delete $f->{$tag} if exists $f->{$tag};
    }
    foreach my $tag (grep {length($_) == 4} keys %$f)
    {
        delete $f->{$tag} if ($f->{$tag}{' LENGTH'} < $f->{$tag}->minsize());
    }
}

if (defined $f->{'kern'})
{
    my $kern = $f->{'kern'}->read;
    if ($kern->{'Version'} > 0)
    {
        warn ("Can't handle AAT style kern tables, deleting");
        delete $f->{'kern'};
    }
}

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, \%opts);
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 "Warning: Can't parse or find $g, ignoring."; 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();
}
else
{
    $subsetter->map_unity();
}

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

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

my ($canchangegids) = 1;
$f->tables_do(sub {$canchangegids &= $_[0]->canchangegids($subsetter);});
$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;

# manage the subsetting process

sub new
{
    my ($class, $numg, $opts) = @_;
    my ($self) = {};
    $self->{'glyphs'} = '';     # bit vector in old font gid space, set if glyph to be kept
    $self->{'remaps'} = {};     # maps new unicode cmap entry to old font gid
    $self->{'numg'} = $numg;
    $self->{'numPseudo'} = 0;
    $self->{'opts'} = $opts;
    # other attributes:
    # $self->{'gidmap'} = [];   # maps old gid to new gid
    # $self->{'gcount'} = 0;    # number of glyphs in new font
    # $self->{'langs'} = {};    # a set of lang tags of languages to include
    # $self->{'scripts'} = {};  # a set of script tags to include
    bless $self, $class || ref $class;
    foreach (0..2) { $self->add_glyph($_); }
    return $self;
}

# ensure this glyph gets into the output
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 map_unity
{
    my ($self) = @_;

    for (my $i = 0; $i < $self->{'numg'}; $i++)
    { vec($self->{'glyphs'}, $i, 1) = 1; }
}

# should this glyph from the old font go into the new font?
sub keep_glyph
{
    my ($self, $n) = @_;
    return vec($self->{'glyphs'}, $n, 1);
}

# add a cmap entry for this old font glyph
sub remap
{
    my ($self, $u, $n) = @_;
    $self->{'remaps'}{$u} = $n;
}

# here's the list of languages to conserve
sub langlist
{
    my ($self, @dat) = @_;
    $self->{'langs'} = { map {$_=>1} @dat };
}

# here's the list of scripts to conserve
sub scriptlist
{
    my ($self, @dat) = @_;
    $self->{'scripts'} = { map {$_=>1} @dat };
}

# now we know what all glyphs the user thinks we need to keep, create the map old to new
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); }
    $count = $self->{'gcount'};
    foreach my $i ($self->{'gcount'} .. $self->{'gcount'} + $self->{'numPseudo'})
    { push (@{$self->{'gidmap'}}, vec($self->{'glyphs'}, $i, 1) ? $count++ : 0); }
    if ($DEBUG)
    {
        my (@list);
        foreach (0 .. $#{$self->{'gidmap'}})
        { push (@list, "$_=$self->{'gidmap'}[$_]") if ($self->{'gidmap'}[$_] > 0); }
        print join(", ", @list) . "\n";
    }
    return $self->{'gcount'};
}

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

package Font::TTF::Table;

# shared code for all tables

# by default, this table can allow glyph ids to be changed. In theory a table
# might not support us changing glyph ids around
sub canchangegids
{ 1; }

# set up the table for subsetting and say we did it.
sub subset
{
    my ($self, $subsetter) = @_;
    return 0 if ($self->{' subsetdone'});
    $self->{' subsetdone'} = 1;
    $self->read;
    $self->dirty;
    return 1;
}


package Font::TTF::Loca;

# we handle the actual glyphs and we are the only table that might
# add extra glyphs to conserve (due to glyph references). So we
# are run first.
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)
    {
        # if this glyph is made up of references, ensure the referenced glyphs are conserved
        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'}); }   # recurse for references of references etc.
            $c->{'glyph'} = $subsetter->map_glyph($c->{'glyph'});   # update the reference to new gid
        }
        $g->{' isDirty'} = 1;
    }
    if (defined $subsetter->{'opts'}{'H'})
    {
        my ($g) = $self->{'glyphs'}[$n];
        next unless (defined $g);
        $g->read_dat() unless ($g->{' isDirty'});
        $g->{'instLen'} = 0;
        $g->{'hints'} = "";
        $g->{' isDirty'} = 1;
    }   
}


package Font::TTF::Ttopen;

# shared code for GSUB and GPOS

# entry point for subsetting GSUB and GPOS
sub subset
{
    my ($self, $subsetter) = @_;
    return unless ($self->SUPER::subset($subsetter));

    my ($l, $count, @lmap, @lookups, $lkvec, $res, $nlookup);
    $lkvec = "";    # bit vector for each lookup to say whether to conserve
    $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]);     # subset the lookup, returning a list of new subtables

        if (!@{$res})       # no subtables? delete the lookup
        {
            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())
            {       # contextual lookups are the last 2 before the extension lookup
                $res = $self->subset_lookup($self->{'LOOKUP'}[$l], $lkvec);     # subset it like non-contextual
                if (!@{$res})
                {
                    delete $self->{'LOOKUP'}[$l];
                    vec($lkvec, $l, 1) = 0;
                }
                else
                {
                    $self->{'LOOKUP'}[$l]{'SUB'} = $res;
                    vec($lkvec, $l, 1) = 1;
                }
            }
        }
        # save a pass and collect list of lookups to output as we go, along with an old->new map
        if (vec($lkvec, $l, 1))
        {
            push (@lookups, $self->{'LOOKUP'}[$l]);
            push (@lmap, $count++);
        }
        else
        { push (@lmap, -1); }
    }
    
    $self->{'LOOKUP'} = \@lookups;
    # now we have the map, we can change the lookup references in the contextual lookups to refer
    # to the new lookup ids.
    foreach $l (@lookups)
    { $self->fixcontext($l, \@lmap); }

    # now make the new FEATURES structure, removing or changing lookup ids
    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'}}]; }
    }
    # remove empty FEATURES by simply not having a FEAT_TAG to refer to them
    $self->{'FEATURES'}{'FEAT_TAGS'} = [grep {defined $self->{'FEATURES'}{$_}} @{$self->{'FEATURES'}{'FEAT_TAGS'}}];

    my ($isEmpty) = 1;
    foreach my $s (keys %{$self->{'SCRIPTS'}})
    {
        # update LANG structures inside the SCRIPTS, use -1 for DEFAULT
        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; }
            }
            # do we delete this language?
            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];
                }
            }
        }
        $self->{'SCRIPTS'}{$s}{'LANG_TAGS'} = [grep {$_} @{$self->{'SCRIPTS'}{$s}{'LANG_TAGS'}}];
        
        # do we delete this script since it has no languages and wasn't required to be preserved
        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 there are no scripts to output, there is no table!
    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'}})
    {
        # call the subclass to process this subtable
        if (!$self->subset_subtable($subsetter, $s, $lookup, $lkvec)
            || !defined $s->{'RULES'} || !@{$s->{'RULES'}})
        { next; }
        
        # remove empty rules and coverage entries but keep them in sync
        if (defined $s->{'COVERAGE'}) # 'RULES' is tested for above
        {
	        my $c = $s->{'COVERAGE'}{'val'};
	        my $r = $s->{'RULES'};
	        my $cover = {};
	        my $rules = [];
	        my $i = 0;
	        foreach my $gid (sort {$c->{$a} <=> $c->{$b}} keys %{$c})
	        {
	        	my ($ix) = $c->{$gid};
                if ($r->[$ix])      # strip empty rules from coverage table
                {
    	        	push (@{$rules}, $r->[$ix]);
	            	$cover->{$gid} = $i++; #will exclude empty hash keys
                }
	        }
	        $s->{'COVERAGE'}{'val'} = $cover;
			$s->{'RULES'} = $rules;        
    	}
    	else
    	{
    		$s->{'RULES'} = [grep {$_} @{$s->{'RULES'}}];
    	}
        
        push (@{$res}, $s);
    }
    return $res;
}

# subset a class table (coverage table with class values)
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; }
}

# subset the common initial relationship between coverage table and rules
# leaves the rules array the same size with the same indices. Remaps the input to the coverage table
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})
    {   # run sorted so we don't overwrite something we output since we assume map_glyph(x) <= x
        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;
    }
}

# subset an array of gids in a contextual lookup based on format of lookup
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;
}

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

    # subset the various coverage and class tables
    return 0 if (defined $sub->{'COVERAGE'} && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $fmt < 2 ? $sub->{'RULES'} : undef));
    if ($fmt < 3) {
    	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'})));

    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;
                # subset the ACTION gids
                if ($type == 4)     # handle ligature substitution differently
                {
                    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 any of the context lists end up empty, delete the subrule
                if (!$test)
                { delete $sub->{'RULES'}[$i][$j]; }
                else
                { $isEmpty = 0; }
            }
            # shrink the list to remove undefs
            $sub->{'RULES'}[$i] = [grep {$_} @{$sub->{'RULES'}[$i]}];
        }
        if ($isEmpty)   # delete the rule?
        {
            delete $sub->{'RULES'}[$i];
            delete $sub->{'COVERAGE'}{'val'}{$gids[$i]} if ($fmt < 2);  # already remapped
        }
    }
    return 1;
}

# fixup the gid references in a contextual lookup actions to point to their new values. No subsetting
# just remapping.
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);

    # handle conventionally structured lookups coverage tables
    return 0 if ($type < 4 && !$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'}));

    if ($type < 4) {        # non contextual lookups
    	while (($k, $v) = each %{$sub->{'COVERAGE'}{'val'}})
		{ $gids[$v] = $k; }}

    if (($type == 1 && $fmt > 1) || $type == 2)     # single or multiple substitution
    {
        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)      # alternate substitution
    {
        foreach $i (0 .. $#{$sub->{'RULES'}})
        {
            if (!defined $sub->{'RULES'}[$i])
            {
                delete $sub->{'COVERAGE'}{'val'}{$gids[$i]};    # already remapped
                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)     # contextual lookups (including ligatures, which look like contextual lookups)
    { 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 ($i, $j, $k);

    if ($type <= 6)
    { return 0 if (!$self->subset_cover($subsetter, $sub->{'COVERAGE'}, $sub->{'RULES'})); }
    
    if ($type == 2 && $fmt == 1)        # pair positioning
    {
        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)     # pair positioning class based
    {
        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; }
    }
    # This doesn't cover removing anchors from bases where the mark class is no longer used
    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));

    # we are not a subclass of Font::TTF::Ttopen so use direct calls
    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::OS_2;

sub subset
{
    my ($self, $subsetter) = @_;
    
    return unless ($self->SUPER::subset($subsetter) && defined $self->{' PARENT'}{'cmap'});
    my ($cmap) = $self->{' PARENT'}{'cmap'};
    $cmap->subset($subsetter);  # Must be done first so we have valid cmap

    # The subset font can support no more ranges than the original, so we use
    # whatever bits guessRangeBits() comes up with as long as long as those bits 
    # were set in the original font. I.e. we do a logical AND. 
    my (@fields) = (qw( ulCodePageRange1 ulCodePageRange2 ulUnicodeRange1 ulUnicodeRange2 ulUnicodeRange3 ulUnicodeRange3));
    my (%save) = (map {$_ => $self->{$_}} @fields); # Remember original
    $cmap = $cmap->find_ms->{'val'};                # generate new bits
    $self->guessRangeBits($cmap);
    map { $self->{$_} &= $save{$_} } @fields;       # turn off any bits that weren't in the original.
}

package Font::TTF::Cmap;

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

    return unless ($self->SUPER::subset($subsetter));
    if (defined $subsetter->{'opts'}{'C'})
    {
       $self->{'Tables'} = [grep {$_->{'LOC'} == $cmap->{'LOC'} or 
                                ($cmap->{'Platform'} == 3 
                                    && $_->{'Platform'} == $cmap->{'Platform'} 
                                    && $_->{'Encoding'} == 1)}
                                        @{$self->{'Tables'}}];
    }
    foreach my $i (0 .. $#{$self->{'Tables'}})
    {
        my ($r) = {};
        my ($t) = $self->{'Tables'}[$i]{'val'};
        foreach my $k (keys %{$t})
        {
            if ($subsetter->keep_glyph($t->{$k}))
            { $r->{$k} = $subsetter->map_glyph($t->{$k}); }
        }
        if ($self->is_unicode($i))
        {
            foreach my $k (keys %{$subsetter->{'remaps'}})
            { $r->{$k} = $subsetter->map_glyph($subsetter->{'remaps'}{$k}); }
        }
        $self->{'Tables'}[$i]{'val'} = $r;
    }
}

package Font::TTF::Post;

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

    return unless ($self->SUPER::subset($subsetter));

    if (defined $self->{'VAL'})
    {
        foreach my $i (0 .. @{$self->{'VAL'}})
        {
            if ($subsetter->keep_glyph($i))     # only add entries for new glyphs (cf Hmtx algorithm)
            { $res->[$subsetter->map_glyph($i)] = $self->{'VAL'}[$i]; }
        }
        $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::Vmtx;

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->{'top'}[$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::Kern;

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

    return unless ($self->SUPER::subset($subsetter));
    foreach my $t (@{$self->{'tables'}})
    {
        if ($t->{'Version'} == 0)
        {
            my (%copy);
            foreach my $l (keys %{$t->{'kern'}})
            {
                if ($subsetter->keep_glyph($l))
                {
                    my ($n) = $subsetter->map_glyph($l);
                    $copy{$n} = {};
                    foreach my $r (keys %{$t->{'kern'}{$l}})
                    {
                        if ($subsetter->keep_glyph($r))
                        { $copy{$n}{$subsetter->map_glyph($r)} = $t->{'kern'}{$l}{$r}; }
                    }
                }
            }
            $t->{'kern'} = \%copy;
        }
        elsif ($t->{'Version'} == 2)
        {
            warn("Kern type 2 subtables not supported, deleting subtable");
            $t->{'Version'} = -1;
        }
    }
    $self->{'tables'} = [grep {$_->{'Version'} != -1} @{$self->{'tables'}}];
    $self->{'Num'} = scalar @{$self->{'tables'}};
}


package Font::TTF::Name;

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

    return unless($self->SUPER::subset($subsetter));
    return unless(defined $subsetter->{'opts'}{'C'});
    $pid = $cmap->{'Platform'};
    $eid = $pid == 3 ? 1 : $cmap->{'Encoding'};
    foreach my $n (@{$self->{'strings'}})
    {
        next unless (defined $n);
        for (my $p = 0; $p < @{$n}; $p++)
        {
            next if ($p == $pid);
            delete $n->[$p];
        }
        next unless (defined $n->[$pid]);
        for (my $e = 0; $e < @{$n->[$pid]}; $e++)
        {
            next if ($e == $eid);
            delete $n->[$pid][$e];
        }
    }
}


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;

# include the pseudo glyphs
sub canchangegids
{
    my ($self, $subsetter) = @_;
    my ($maxpseudo) = 0;

    $self->read();
    $self->{' PARENT'}{'Gloc'}->read();
    $maxpseudo = scalar @{$self->{' PARENT'}{'Gloc'}{'locations'}} - 1 - $subsetter->{'numg'};
    $subsetter->{'numPseudo'} = $maxpseudo;
    foreach my $s (@{$self->{'SILF'}})
    {
        $subsetter->add_glyph($s->{'lbGID'});
        $s->{'lbGID'} = $subsetter->map_glyph($s->{'lbGID'});
    }

    #foreach my $i (0 .. $maxpseudo - 1)
    #{ $subsetter->add_glyph($subsetter->{'numg'} + $i); }
    return 1;
}


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

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


# This is the original long algoriththe original. It got modified a bit as I wrote the real code:
# 1.	For each pass
#	1.1	Establish rule->row and row->rule mappings
#	1.2	Mark kept columns
#	1.3	Mark kept rows (based on deleted columns)
#	1.4	Mark kept rules (based on deleted rules)
#	1.5 Test constraint to see if deleted features have impossible values
#	1.6 Parse and associate substitutionary classes
#
# 2.	Mark deleted classes
#	2.1 If a single input class has more than one output class, copy input class and map
#	2.2 Remove entries from input and output class pairs
#		2.2.1 Mark empty classes as deleted
#
# 3.	For each pass
#	3.1 For each non-deleted rule
#		3.1.1 Mark deleted if references deleted class
#
# 4. Mark unneeded classes as deleted
#	4.1 re-merge identical input classes to have multiple output classes
#	4.2 Create old->new class id mapping
#	4.3 Create remapped classes to new glyph ids.
# 5. For each pass
#	5.1 Mark rows of deleted rules as deleted
#	5.2 Mark columns that only consist of deleted rows as deleted
#	5.3 Create old->new row mapping
#	5.4 Create old->new rule mapping
#	5.5 Create new fsm
#	5.6 Create new row->rule lists
#	5.7 Create new rules with classes remapped
#	5.8 Remap gids in column mapping
# 6. Create new classes structure deleting some classes, and remapping gids

# We use various attributes of $subsetter->{'silf'}:
# All the glyphs referenced here are in terms of the input font
# passes            An array of sub info per pass:
#       cols            bitmap for columns of fsm. Set if required in output
#       glyphcols       array indexed by col, list of required glyphs mapping to that col
#       rowfwdrefs      array indexed by row, a set of required rows this fsm row can end up at
#       rowbackrefs     array indexed by row, a set of required rows that can fwd reference to here
#       rules           array indexed by rule, a list of rows that fire this rule
#       rulemap         array indexed by row, a list of rules this row fires
# numclass_pairs    hash keyed by class, contains a hash of classes that required rules map glyphs from the hash key to, valued by number of occurrences
# numclasses        hash keyed by class, contains a hash of classes used in required rules, valued by number of occurrences
# class_pairs       double hashed key by in & out class to a pair of lists in & out required glyphs.
# class_pairs_removed   double hash, 2 classes to a list of glyphs in the first class that map to unrequired glyphs in the second
# classes
# class_map

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 
    $silf->{'classes'} = [] if (!defined $silf->{'classes'});
    for (my $i = 0; $i < scalar @{$silf->{'classes'}}; $i++)
    {
        my ($subsetexists) = grep {defined $_ and $subsetter->keep_glyph($_)} @{$silf->{'classes'}[$i]};
        my ($nosubset) = grep {defined $_ and !$subsetter->keep_glyph($_)} @{$silf->{'classes'}[$i]};
        unless ($subsetexists)
        {
            $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);
            # get all required glyphs in the other class of the pair
            my ($subotherexists) = grep {defined $_ and $subsetter->keep_glyph($_)} @{$silf->{'classes'}[$k]};
            my ($noothersubset) = grep {defined $_ and !$subsetter->keep_glyph($_)} @{$silf->{'classes'}[$k]};
            next if (!$noothersubset and !$nosubset);
            my (@subother) = ();
            my (@subthis) = ();
            # subset based on both glyphs being required
            for (my $j = 0; $j < @{$silf->{'classes'}[$i]}; $j++)
            {
                my ($a) = $silf->{'classes'}[$i][$j];
                my ($b) = $silf->{'classes'}[$k][$j];
                if ($subsetter->keep_glyph($a) and $subsetter->keep_glyph($b))
                {
                    push (@subother, $b);
                    push (@subthis, $a);
                }
                elsif ($subsetter->keep_glyph($a))  # if second glyph deleted, mark pair to delete
                { push (@{$subsetter->{'silf'}{'class_pairs_removed'}{$i}{$k}}, $a); }
            }
            if (!scalar @subthis)   # if no pairs
            { $subsetter->{'silf'}{'numclass_pairs'}{$i}{$k} = -1; }    # delete the class pair
            else    # two lists of required glyphs: in & out
            { $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/reuse class_pairs to return [in_new_class_id, out_new_class_id]
    # also do class reduction.
    $subsetter->{'silf'}{'classes'} = [];   # for each class a hash of new gid to new class index
    $subsetter->{'silf'}{'classmap'} = [];  # size of each class, -1 for a deleted class
    my ($numlin) = $self->{'numLinearClasses'};
    my (@linclasses, @nonlinclasses);
    for (my $i = 0; $i < scalar @{$silf->{'classes'}}; $i++)
    {
        my ($c) = $silf->{'classes'}[$i];
        my (@newclass, $index);
        my (@newclass) = map {$subsetter->map_glyph($_)} grep {$subsetter->keep_glyph($_)} @{$silf->{'classes'}[$i]};
        if (scalar @newclass)
        {
            my ($i) = 0;
            if ($i < $numlin)
            {
                push (@linclasses, [@newclass]);
                push (@{$subsetter->{'silf'}{'classmap'}}, $#linclasses);
            }
            else
            {
                push (@nonlinclasses, [@newclass]);
                push (@{$subsetter->{'silf'}{'classmap'}}, -(scalar @nonlinclasses));
            }
        }
        else
        {
            push (@{$subsetter->{'silf'}{'classmap'}}, undef);
            --$silf->{'numLinearClasses'} if ($i < $silf->{'numLinearClasses'});
        }
        next unless (defined $subsetter->{'silf'}{'class_pairs'}{$i});
        # iterate over class pairs containing arrays of glyphs to create real classes in silf.class and replace
        # the class pairs entry with the id of that new class.
        while(my ($k,$v) = each %{$subsetter->{'silf'}{'class_pairs'}{$i}})
        {
            $self->addmappedclass($v->[0], \@linclasses);
            $self->addmappedclass($v->[1], \@nonlinclasses);
        }
    }
    @{$subsetter->{'silf'}{'classes'}} = (@linclasses, @nonlinclasses);
    $silf->{'numLinearClasses'} = scalar @linclasses;
    foreach my $r (@{$subsetter->{'silf'}{'classmap'}})
    {
        if (!defined $r)
        { $r = -1; }
        elsif ($r < 0)
        { $r = $silf->{'numLinearClasses'} - $r; }
    }

    # 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]))
        #unless ($self->finalise_pass($silf->{'PASS'}[$i], $subsetter, {}))
        {
            splice(@{$silf->{'PASS'}}, $i, 1);
            splice(@{$subsetter->{'silf'}{'passes'}}, $i, 1);
            foreach ('substPass', 'posPass', 'justPass', 'bidiPass')
            { $silf->{$_}-- if ($i < $silf->{$_} and $silf->{$_} != 0xFF); }
            $i--;
        }
        else
        { $subsetter->{'silf'}{'passes'}[$i] = undef; }
    }

    foreach my $k (keys %{$silf->{'pseudos'}})
    {
        my ($g) = $silf->{'pseudos'}{$k};
        if ($subsetter->keep_glyph($g))
        { $silf->{'pseudos'}{$k} = $subsetter->map_glyph($g); }
        else
        { delete $silf->{'pseudos'}{$k}; }
    }
    $silf->{'maxGlyphID'} = $subsetter->{'gcount'} - 1;
    $silf->{'classes'} = $subsetter->{'silf'}{'classes'};
}

# algorithm section 1
# analyse fsm while ignoring columns that only cover deleted glyphs
sub markdels
{
    my ($self, $pass, $subsetter, $cinfo) = @_;

    # 1.2 mark kept columns
    for (my $i = 0; $i < $subsetter->{'numg'} + $subsetter->{'numPseudo'}; ++$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. Not yet implemented

    # 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]}++; }
        }
    }
}

# check the rules of a pass and delete any that reference a deleted class
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)
        {   # delete rule if class pair or referenced class has been deleted
            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 canmergerule
{
    my ($self, $hash, $in, $cinfo, $rulemap) = @_;

    return undef unless (defined $hash);
    return $hash->[0] unless defined $cinfo->{'prerules'}[$in];
    foreach my $h (@{$hash})
    {
        my ($failed) = 0;
        foreach my $t (keys %{$cinfo->{'prerules'}[$in]})
        {
            if ($rulemap->[$t] > $h)
            {
                $failed = 1;
                last;
            }
        }
        return $h if (!$failed);
    }
    return undef;
}

sub substrulemap
{
    my ($self, $in, $out, $subsetter, $cinfo) = @_;
    my ($row);

    foreach $row (@{$cinfo->{'rules'}[$in]})
    {
        if (!grep {$_ == $out} @{$cinfo->{'rulemap'}[$row]})
        {
            foreach my $c (@{$cinfo->{'rulemap'}[$row]})
            { $c = $out if ($c == $in); }
        }
        else
        { $cinfo->{'rulemap'}[$row] = [grep {$_ != $in} @{$cinfo->{'rulemap'}[$row]}]; }
    }
}

# basically creates the new fsm and rules and the mapping between them
# minimises the fsm on the way
sub finalise_pass
{
    my ($self, $pass, $subsetter, $cinfo) = @_;
    my ($i);

    # 5.4 create rule map
    my (@rulemap, @revrulemap);
    my ($numrules, %actdedup);
    $cinfo->{'prerules'} = [];
    for (my $i = 0; $i < $pass->{'numRules'}; $i++)
    {
        foreach my $row (@{$cinfo->{'rules'}[$i]})
        {
            foreach my $rule (@{$cinfo->{'rulemap'}[$row]})
            {
                last if ($rule == $i);
                $cinfo->{'prerules'}[$i]{$rule} = 1 if ($pass->{'ruleSortKeys'}[$rule] == $pass->{'ruleSortKeys'}[$i]);
            }
        }
    }
    for (my $i = 0; $i < $pass->{'numRules'}; $i++)
    {
        if (defined $cinfo->{'rules'}[$i] and @{$cinfo->{'rules'}[$i]})
        {
            my ($actd) = $actdedup{$pass->{'actionCode'}[$i]}{$pass->{'constraintCode'}[$i]}{$pass->{'ruleSortKeys'}[$i]}{$pass->{'rulePreContexts'}[$i]};
            $actd = $self->canmergerule($actd, $i, $cinfo, \@rulemap);
            if ($actd)
            {
                # [DOME] update $cinfo->{'rulemap'} and don't update $cinfo->{'rules'} here. Also allows for row deduping on this rule.
                # for $cinfo->{'rulemap'} make sure all values are unique and appropriately ordered (for deduping comparison)
                $self->substrulemap($i, $revrulemap[$actd], $subsetter, $cinfo);
                push (@rulemap, $actd);
            }
            else
            {
                # print "rule($i->$numrules): " . join(",", @{$cinfo->{'rules'}[$i]}) . "\n";
                push (@{$actdedup{$pass->{'actionCode'}[$i]}{$pass->{'constraintCode'}[$i]}{$pass->{'ruleSortKeys'}[$i]}{$pass->{'rulePreContexts'}[$i]}}, $numrules);
                push (@revrulemap, $i);
                push (@rulemap, $numrules++);
            }
        }
        else
        { push (@rulemap, -1); }
    }

    # dedup final rows that map to the same rule set
    my (%rmap);
    for (my $i = $pass->{'numTransitional'}; $i < $pass->{'numRows'}; $i++)
    {
        my ($c) = 0;
        my (%rs) = map {$_ => $c++} @{$cinfo->{'rulemap'}[$i]};
        my ($r) = join(" ", sort keys %rs);
        if (defined $rmap{$r})
        { $self->mergerow($i, $rmap{$r}, $pass, $cinfo); }
        else
        {
            $rmap{$r} = $i;
            $cinfo->{'rulemap'}[$i] = [sort {$rs{$a} <=> $rs{$b}} keys %rs];      # dedup the rules
        }
    }
    my (@rules);
    my ($lastrule) = -1;
    # 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] <= $lastrule);    # only process first occurrence of a rule
        $lastrule = $rulemap[$i];
        my (@rinfo) = $self->unpack_code($pass->{'actionCode'}[$i]);
        my ($c) = 0;
        my ($deleterule) = 0;
        foreach my $r (@rinfo)
        {
            # update action code if needbe
            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]})
                {
                    # if some glyphs have been removed from the class, then the column may need to split
                    # so that only a subset of the column has a path to this rule. Edit the fsm accordingly.
                    # This will grow the fsm. But later deduping can shrink it again. Actually a good form of
                    # optimisation.
                    $deleterule |= $self->remove_trail($subsetter, $cinfo, $pass, $i, $c, $r->[2],
                        $subsetter->{'silf'}{'class_pairs_removed'}{$r->[2]}{$r->[3]})
                            if (defined $subsetter->{'silf'}{'class_pairs_removed'}{$r->[2]}{$r->[3]});
                    # update the action code
                    #($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.
        }
        if ($deleterule)
        {
            @rulemap = map {$_ == $lastrule ? -1 : ($_ > $lastrule ? $_ - 1 : $_)} @rulemap;
            splice(@revrulemap, $lastrule, 1);
            $lastrule--;
        }
        else
        {    
            push (@rules, $self->pack_code(\@rinfo));
        }
    }

    if (scalar @rules != scalar @revrulemap)
    { die "rules and revrulemap are different lengths!"; }
    # 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;
        }
    }

    # create a new, optimised fsm
    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;
    # do empty rows then ones with rules.
    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)     # if we have deduped columns and then deduped rows as a result, then go round again to look for more
    {
        $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; }
        }
        # dedup final non-transitional rows
        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. Dedup columns
        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 - dedup rows again having deleted columns
        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];
                    my ($o) = $rowmap[$f] > 0 ? $rowmap[$f] : 0;
                    push (@row, $o);
                    vec($v, $k++, 16) = $o;
                }
                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;       # we deduped a row, so repeat algorithm in case removing a row allows columns to be merged
                }
                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] <= -1);
        foreach my $r (@{$cinfo->{'rules'}[$i]})
        {
            if ($rowmap[$r] >= 0)
            { push (@{$rowrules[$rowmap[$r] - $numSuccess]}, $rulemap[$i]); }
        }
        # doesn't matter that these are overwritten for each duplicate rule since the values should be
        # identical each time.
        $keys[$rulemap[$i]] = $pass->{'ruleSortKeys'}[$i];
        $prectxts[$rulemap[$i]] = $pass->{'rulePreContexts'}[$i];
    }
    foreach my $r (@rowrules)
    {
        my ($c) = 0;
        my (%hr) = map {$_ => $c++} @$r;
        $r = [sort {$keys[$a] <=> $keys[$b] || $hr{$a} <=> $hr{$b}} keys %hr];
    }
   
    # 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);
    my ($lastrule) = -1;
    for (my $i; $i < $pass->{'numRules'}; $i++)
    {
        if ($rulemap[$i] > $lastrule)
        {
            $lastrule = $rulemap[$i];
            $ruleconstraints[$lastrule] = $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'} = scalar @rules;
    return 1;
}

# a test assertion. Should neve fire. Helps spot bugs in the code (or faulty fonts)
sub testclass
{
    my ($c, $subsetter, $d) = @_;
    if ($subsetter->{'silf'}{'classmap'}[$c] == -1)
    { warn ("Bad class $c in $d\n"); }
}

# finds the first element in the array that isn't -1, at or after ind.
# returns -1 if it can't find one.
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];
}

# deletes a rule updating the pass info for the fsm
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] = [];
}

# returns whether a row is a start state
sub isStart
{
    my ($self, $pass, $row) = @_;
    if (grep {$_ == $row} @{$pass->{'startStates'}})
    { return 1; }
    else
    { return 0; }
}

# returns whether a row is a final state
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;
}

# mark an fsm row for deletion and work through implications to see what else we can delete
# may recurse whether indirectly or directly.
sub delrow
{
    my ($self, $pass, $cinfo, $row) = @_;

    foreach my $r (keys %{$cinfo->{'rowfwdrefs'}[$row]})
    {
        delete $cinfo->{'rowbackrefs'}[$r]{$row};
        # delete a fwd referenced row if deleting us means nothing else fwd references it
        $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};
        # delete a back referenced row if deleting us means there is nothing for it to fwd reference to or it's a final 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]})];
        # delete rule if there are now no rows that reference the rule
        $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++)
    {
        # potentially delete all cols that have transitions on the deleted row
        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]});
        my (@templist) = @collist;  # allow us to edit the collist inside the loop
        foreach my $j (@templist)
        {
            # keep those cols where there are transitions in other required rows
            if ($pass->{'fsm'}[$i][$j])
            { @collist = grep ($_ != $j, @collist); }
        }
    }
    # do the column deletion
    foreach my $j (@collist)
    { vec($cinfo->{'cols'}, $j, 1) = 0; }    
}

# add a class to the set of output classes deduping as we go
# returns the new class id
sub addmappedclass
{
    my ($self, $class, $classes) = @_;
    my ($l) = scalar @{$class};
    my (@m) = map {$subsetter->map_glyph($_)} @{$class};

    for (my $i = 0; $i < @{$classes}; $i++)
    {
        my ($nomatch) = 0;
        my ($c) = $classes->[$i];
        next unless (scalar @{$c} == $l);
        foreach (my $j = 0; $j < $l; $j++)
        {
            if ($c->[$j] != $m[$j])
            {
                $nomatch = 1;
                last;
            }
        }
        return $i if (!$nomatch);
    }
    my ($i) = 0;
    push (@{$classes}, [@m]);
    return $#{$classes};
}

# given a list of columns, a starting row and a number of steps backwards to walk,
# floodfills backwards the number of steps and then copies the rows for the
# columns not in the list. This is needed when one splits a column and wants to
# split the paths through the fsm for a particular rule
sub addrowsfor
{
    my ($self, $pass, $cinfo, $cols, $len, $row, $parent, $total) = @_;
    # $parent is the row of interest
    # $row is the row leading to $parent
    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;
    }
}

# a rule references a class that has been changed. We now have to analyse the glyphs
# to see which columns they are in and whether as a result of changing the glyph lists
# those columns need splitting (since there are glyphs in there that shouldn't cause
# our rule to fire). Then we update the fsm to add rows for the extra columns we make
# and ensure the path to the rule (given it's back length) is now correct within
# the fsm. All paths to other rules are copied for the new column.
# This results in potentially a lot of growth for the fsm and probably some duping.
# deduping later will take care of that.        
sub remove_trail
{
    my ($self, $subsetter, $cinfo, $pass, $rule, $index, $col, $glyphlist) = @_;
    $index += $pass->{'rulePreContexts'}[$rule];
    my ($countback) = $pass->{'ruleSortKeys'}[$rule] - $index;
    my (@glyphs) = (@{$glyphlist});
    my (%outmap) = map {$_ => 1} @glyphs;
    my (%inmap) = map {$_ => 1} grep {!defined $outmap{$_}} @{$cinfo->{'glyphcols'}[$col]};
    my (@paths, @collist);
    my ($fsm) = $pass->{'fsm'};
    my ($deleteme) = (length(@glyphs) > 0);

    # Identify columns to split and split them
    # test each collection of glyphs with a given column id against that complete
    # class. If that collection is different from our accumulated column, then
    # split the column to reflect that some glyphs need to take a different path
    # through the fsm
    while (@glyphs)
    {
        my (@glist);
        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++; }
        }
        my ($new) = $self->splitcol($c, \@glist, $pass, $cinfo);
        $deleteme = 0 if ($new != $c);
        foreach my $r (@{$cinfo->{'rules'}[$rule]})
        {
            foreach my $p (keys %{$cinfo->{'rowbackrefs'}[$r]})
            { $pass->{'fsm'}[$p][$new] = 0; }
        }
    }

    return $deleteme;

    # 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};
    # expand the fsm to ensure paths for each rule
    foreach my $p (@{$cinfo->{'rules'}[$rule]})
    {
        foreach my $r (keys %{$cinfo->{'rowbackrefs'}[$p]})
        { $self->addrowsfor($pass, $cinfo, \%colhash, $countback - 1, $r, $p, $countback); }
    }

    # does this loop even run?
    # rowmap maps old rows to new rows
    while (my ($k, $r) = each %rowmap)
    {
        # remap fsm entries for the colhash according to the rowmap entry
        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];
            # this is the row and column that fires our rule so don't let it move on
            if (defined $colhash{$i} and grep {$_ == $replace} @{$cinfo->{'rules'}[$rule]})
            { $replace = 0; }
            # assumes $i not in %colhash
            elsif (defined $rowmap{$replace})
            { $replace = $rowmap{$replace}; }
            next unless ($replace != $f->[$i]);
            # update fsm entry to be new value of $replace
            delete $cinfo->{'rowbackrefs'}[$f->[$i]]{$r};
            $f->[$i] = $replace;
            if ($replace)
            {
                $cinfo->{'rowfwdrefs'}[$r]{$replace} = 1;
                $cinfo->{'rowbackrefs'}[$replace]{$r} = 1;
            }
        }
    }
}

# splits a column set (of glyphs) into two updating the fsm
sub splitcol
{
    my ($self, $col, $removes, $pass, $cinfo) = @_;
    my (%others) = map {$_ => 1} @{$removes};
    my ($olds) = [grep {!defined $others{$_}} @{$cinfo->{'glyphcols'}[$col]}];
    my ($new);
    if (scalar @{$olds})
    {
        $cinfo->{'glyphcols'}[$col] = $olds;
        $new = $pass->{'numColumns'}++;
        $cinfo->{'glyphcols'}[$new] = [@{$removes}];
    }
    else
    { return $col; }

    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;
}

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

    foreach my $rule (@{$cinfo->{'rulemap'}[$from]})
    {
        foreach my $c (@{$cinfo->{'rules'}[$rule]})
        { $c = $to if ($c == $from); }
        if (!grep {$_ == $rule} @{$cinfo->{'rulemap'}[$to]})
        { push (@{$cinfo->{'rulemap'}[$to]}, $rule); }
    }

    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;
        # delete $cinfo->{'rowfwdrefs'}[$r]{$from}; #not needed because delrow will have non empty row
    }
    # $cinfo->{'rowbackrefs'}[$from] = {};  # not needed becuase delrow will have non empty rows
    $self->delrow($pass, $cinfo, $from);
}

# add a row to the fsm that is the copy of another
# update everything accordingly
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;
}

# Does a fast ordered comparison of two arrays
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 NAME

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 [default].
  -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)
  -H            strips all hinting
  -C            strips legacy cmaps

=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)
  aat       all AAT tables (mort morx feat)
  default   all unhandled tables (hdmx vdmx EBDT EBLC EBSC Silt aat)

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.

A missing C<-g> option results in all glyphs being conserved.

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.

=head1 AUTHOR

Martin Hosken L<http://scripts.sil.org/FontUtils>.
(see CONTRIBUTORS for other authors).

=head1 LICENSING

Copyright (c) 1998-2014, SIL International (http://www.sil.org)

This script is released under the terms of the Artistic License 2.0.
For details, see the full text of the license in the file LICENSE.

=cut

