#!/usr/bin/perl
# $Id: fontcat.pl 283 2008-10-11 00:08:06Z chris $

use strict;
use warnings;

use Font::TTF::Font;



{
    # Parse Arguments
    unless (@ARGV >= 3) { die "Usage: ..."; }
    
    my ($fileA, $fileB, $fileOut) = splice(@ARGV, 0, 3, ());
    
    # TODO: Parse remaining args and populate chars
    my @chars = ();
    foreach (@ARGV) {
	my ($l, $u) = m/^U\+([0-9A-F]+)\-U\+([0-9A-F]+)/i or die "Cannot parse '$_'";
	push @chars, (hex($l)..hex($u)); 
    }
    
    
    
    # Read in both fonts in their entirety
    my $fontA = Font::TTF::Font->open($fileA);
    $fontA->tables_do( sub {$_[0]->read;} );
    $fontA->{'loca'}->glyphs_do( sub { $_[0]->read_dat; } );
    
    my $fontB = Font::TTF::Font->open($fileB);
    $fontB->tables_do( sub {$_[0]->read;} );
    $fontB->{'loca'}->glyphs_do( sub { $_[0]->read_dat; } );
    

    
    # Calculate scale factor
    # TODO: Allow this to be overridden by command line options
    my ($scaleFactorX, $scaleFactorY) = (1, 1);
    $scaleFactorY = ($fontA->{'hhea'}->{'Ascender'} - $fontA->{'hhea'}->{'Descender'})
	/ ($fontB->{'hhea'}->{'Ascender'} - $fontB->{'hhea'}->{'Descender'});
 
    $scaleFactorX = $scaleFactorY;
    
    

    # Produce a mapping of character to glyphs for the characters that are 
    # to be copied across.

    # If no @chars was specified on the command line, default to all 
    # characters not in fontA

    my $charMap = {};

    if (@chars == 0) {

	my @c = $fontB->{'cmap'}->reverse('array' => 1);
	for (my $i = 0; $i < @c; $i++) {
	    if (defined $c[$i]) {
		foreach (@{$c[$i]}) {
		    unless (defined $fontA->{'cmap'}->ms_lookup($_)) {
			$charMap->{$_} = $i;
		    }
		}
	    }
	}

    } else {    

	foreach (@chars) {
	    if ($fontA->{'cmap'}->ms_lookup($_)) {
		warn sprintf("Unicode character U+%.4X already exists in '$fileA', won't overwrite it", $_);
	    }
	    
	    if (defined (my $g = $fontB->{'cmap'}->ms_lookup($_))) {
		$charMap->{$_} = $g;
	    }
	}
    }
    
    
    
    # Given charMap, build up a list of all glyphs that are required
    my $glyphMap = {};
    foreach (values %$charMap) {
	$glyphMap->{$_} = $_;
    }

    # and recursively determined which other glyphs need to be copied because they're used in compound glyphs
    for (my ($glyphs, $newGlyphs) = ({%$glyphMap}, {}); keys %$glyphs > 0; $glyphs = $newGlyphs, $newGlyphs = {}) {
	
	foreach (keys %$glyphs) {
	    
	    my $g = $fontB->{'loca'}->{'glyphs'}->[$_];
	        
	    if (defined $g && defined ($g->{'comps'})) {
		
		foreach (@{$g->{'comps'}}) {
		    
		    if (!defined $glyphMap->{$_->{'glyph'}}) {
			$glyphMap->{$_->{'glyph'}} = $_->{'glyph'};
			$newGlyphs->{$_->{'glyph'}} = 1;
		    }
		    
		}
		
	    }
	    
	}
    }
    
    
    
    # Remapping glyph if there are any collisions
    # Glyph are remapped if their value is less than the last glyph in fontA (as it's not easy to 
    # decide which glyphs are unused, even if $fontA->{'loca'}->{'glyphs'}}->[...] is undef, it can still 
    # have a width, and hence shouldn't be overwritten), or if a glyph remapped earlier in the loop necessitates 
    # another remapping.
    {
	my $lastGlyph = @{$fontA->{'loca'}->{'glyphs'}} - 1; # Index of last glyph
	my $nextSlot = $lastGlyph + 1; # Next index to start searching for a new free slot
	my %slots; # Keep track of which values have already been used
	
	foreach (sort keys %$glyphMap) {
	    if ($glyphMap->{$_} <= $lastGlyph || defined $slots{$_}) {
		while (defined $slots{$nextSlot}) { $nextSlot++; }
		
		$glyphMap->{$_} = $nextSlot;
	    }
	    $slots{$glyphMap->{$_}} = 1;
	}
    }
    
    
    
    # Copy across all necessary glyphs and associated data.
    # TODO: Much more data associated with each glyph to copy.
    foreach (sort keys %$glyphMap) {

	my $g = $fontB->{'loca'}->{'glyphs'}->[$_];

	if (defined $g) {

	    # Disassociate glyph from fontB.  Almost certainly not required, but perhaps
	    # prevent future bugs if fontB is used for anything else.
	    $fontB->{'loca'}->{'glyphs'}->[$_] = undef;

	    # Resize
	    resizeGlyph($g, $scaleFactorX, $scaleFactorY);

	    # Remap other glyphs if this is a compound glyph
	    if (defined $g->{'comps'}) {
		foreach (@{$g->{'comps'}}){ 
		    $_->{'glyph'} = $glyphMap->{$_->{'glyph'}};
		}
	    }

	    # Not sure whether this is required
	    $g->{' PARENT'} = $fontA;
	}

	# Set regardless of whether $g is defined or not to make sure that the 
	# extent of the array is sufficient
	$fontA->{'loca'}->{'glyphs'}->[$glyphMap->{$_}] = $g;


	# Copy other attributes
	$fontA->{'post'}->{'VAL'}->[$glyphMap->{$_}] = $fontB->{'post'}->{'VAL'}->[$_];
	$fontA->{'hmtx'}->{'advance'}->[$glyphMap->{$_}] = $fontB->{'hmtx'}->{'advance'}->[$_] * $scaleFactorX;
	# Don't copy GDEF for now, try to understand how GDEF, GPOS and GSUB work together first
	# $fontA->{'GDEF'}->{'GLYPH'}->{'val'}->{$glyphMap->{$_}} = $fontB->{'GDEF'}->{'GLYPH'}->{'val'}->{$_};
    }
    $fontA->{'maxp'}->{'numGlyphs'} = @{$fontA->{'loca'}->{'glyphs'}};
    $fontA->{'loca'}->dirty();
    $fontA->{'post'}->dirty();
    $fontA->{'hmtx'}->dirty();
    $fontA->{'maxp'}->dirty();
    # $fontA->{'GDEF'}->dirty();
    $fontA->update();
    
    
    
    # Update character table with desired characters (and new glyphs)
    my $tables = @{$fontA->{'cmap'}->{'Tables'}};
    for (my $t = 0; $t < $tables; $t++) {
	if ($fontA->{'cmap'}->is_unicode($t)){ 
	    foreach (sort keys %$charMap) {
		$fontA->{'cmap'}->{'Tables'}->[$t]->{'val'}->{$_} = $glyphMap->{$charMap->{$_}};
	    }
	} else {
	    # TODO: Update all character tables
	    warn "Table $t isn't unicode, not updated!";
	}
    }
    $fontA->{'cmap'}->dirty();
    $fontA->update();
    
    $fontA->out($fileOut);
}



sub resizeGlyph {
    my ($g, $sfx, $sfy) = @_;

    foreach (@{$g->{'x'}}) { $_ *= $sfx; }
    foreach (@{$g->{'y'}}) { $_ *= $sfy; }
    if (defined $g->{'comps'}) {
	foreach (@{$g->{'comps'}}){ 
	    $_->{'args'}->[0] *= $sfx;
	    $_->{'args'}->[1] *= $sfy;
	}
    }

    $g->update();
}