# Font::Fret::fret('', @ARGV);

package Font::Fret;

use File::stat;

use Font::TTF::Font;
use Text::PDF::File;
use Text::PDF::Page;
use Text::PDF::SFont;
use Text::PDF::TTFont0;
use Text::PDF::Utils;
# use Font::Metrics::Helvetica;
# use Font::Metrics::HelveticaBold;

use Getopt::Std;
use strict;
use vars qw(@ISA %sizes @EXPORT $pdf_helv $pdf_helvb $pdf_helvi $pdf_helvbi $VERSION
            $dots);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fret);


BEGIN {
    $VERSION = "1.202";

    %sizes = (
        'a4' => [595, 842],
        'ledger' => [1224, 1584],
        'letter' => [612, 792],
        'ltr' => [612, 792],
        'legal' => [612, 1008]
        );
    if ($^O eq "MacOS")
    {
        require Mac::Resources;
        import Mac::Resources;
        require Mac::Memory;
        require IO::Scalar;
    }
    $dots = "0 w [.25 1.25] 0 d";
}


sub fret
{
    my ($package);
    ($package, @ARGV) = @_;
    my ($font, $maxx, $maxy, $pdf, $root);
    my (%opt);
    my ($fh, $fdat);
    
    if ($ARGV[0] =~ /^-p(.*)$/oi)
    {
    	$package = $1;
    	shift @ARGV;
    	$package = shift @ARGV unless $package;
    }

	$package = 'Font::Fret::Default' unless $package;
	
	if ($package->can('process_argv'))
	{	$package->process_argv (\%opt); }
	else
	{   getopts("d:fgh:m:p:qrs:", \%opt); }


    unless (defined $ARGV[0])
    {
    	die <<'EOT';
fret [-p package] [-f] [-g] [-r] [-s size] [-q] font_file [out_file]
Generates a report on a font according to a particular package. In some
contexts the package may be over-ridden. Paper size may also be specified.

If no out_file is given then out_file becomes font_file.pdf (removing .ttf
if present)

  -d num        Sets time for testing purposes
  -f            Don't try to save memory on large fonts (>1000 glyphs)
  -g            Add one glyph per page report following summary report
  -h            Mode for glyph per page output. Bitfield:
                1 = bit 0       don't output point positions
  -m points     Sets glyph size in the box regardless of what is calculated
                Regardless of the consequences for clashes
  -p package    Perl package specification to use for report information
  -q            quiet mode
  -r            Don't output report lines, fill the page with glyph boxes
  -s size       paper size: a4, ltr, legal

If supplied, -p must be the first option.
EOT
						# ' quote matching for above here-doc.

    }

    $opt{s} = lc($opt{s}) || 'ltr';
    $opt{s} = 'ltr' unless defined $sizes{$opt{s}};
    ($maxx, $maxy) = @{$sizes{$opt{s}}};

    unless (defined $ARGV[1])
    {
        $ARGV[1] = $ARGV[0];
        $ARGV[1] =~ s/\.ttf$//oig;
        $ARGV[1] .= ".pdf";
    }

    $pdf = Text::PDF::File->new;
    $pdf->{' version'} = 3;
    $root = Text::PDF::Pages->new($pdf);
    $root->proc_set('PDF', 'Text');
    $root->bbox(0, 0, $maxx, $maxy);
    $pdf_helv = Text::PDF::SFont->new($pdf, "Helvetica", "FR");
    $pdf_helvb = Text::PDF::SFont->new($pdf, "Helvetica-Bold", "FB");
    $pdf_helvi = Text::PDF::SFont->new($pdf, "Helvetica-Oblique", "FI");
    $pdf_helvbi = Text::PDF::SFont->new($pdf, "Helvetica-BoldOblique", "FBI");
    $root->add_font($pdf_helv, $pdf);
    $root->add_font($pdf_helvb, $pdf);
    $root->add_font($pdf_helvi, $pdf);
    $root->add_font($pdf_helvbi, $pdf);

    $Font::TTF::Name::utf8 = 1;

    if ($^O eq "MacOS")
    {
        $ARGV[1] =~ s/([^:]+)$/susbtr($1, length($1) - 31, 31)/oie
                if ($ARGV[1] =~ m/([^:]+)$/oi && length($1) > 31);
        my ($type, $rid, $rh, $num, $rcur);
        
        $type = MacPerl::GetFileInfo($ARGV[0]);
        if ($type eq "tfil" || $type eq "FFIL")
        {
            $rcur = CurResFile();
            $rid = OpenResFile($ARGV[0]);
#            UseResFile($rid);
#            $num = Count1Resources("sfnt");
#            while ($num-- > 0)
#            {
#                UseResFile($rid);
#                $rh = Get1IndResource("sfnt", $num + 1);
                $rh = Get1IndResource("sfnt", 1);
                UseResFile($rcur);
                LoadResource($rh) || die "Couldn't load resource";
                $fdat = $rh->get;
                $fh = IO::Scalar->new(\$fdat);
                ReleaseResource($rh);
                $font = Font::TTF::Font->open($fh) || next;
                process_font($package, $font, $pdf, $root, $maxx, $maxy, $num,
                        %opt) unless ($num == 0);
#            }
#            CloseResFile($rid);
        } else
        { $font = Font::TTF::Font->open($ARGV[0]) || die "Can't open font file $ARGV[0]"; }
    } else
    { $font = Font::TTF::Font->open($ARGV[0]) || die "Can't open font file $ARGV[0]"; }
    $pdf->create_file($ARGV[1]);
    process_font($package, $font, $pdf, $root, $maxx, $maxy, "a0", %opt);
    $pdf->close_file;
}

sub process_font
{
    my ($package, $font, $pdf, $root, $maxx, $maxy, $id, %opt) = @_;
    my (@rev, $i, $numg, $upem, $mextx, $mexty, $tsize, $gsize);
    my ($tfont, $fname, $nump, $maxg, $pnum, $page, $cpyright, $ftrleft);
    my (@rowt, @roww, @row1, @row2, $hdrlft, $hdrright, $pcpy, $hdrbox, $hdrrw);
    my ($gcount, $tr, $tr1, $ppage, @time, @boxhdr, @boxloc, @cids, $numc, $gid);
    my ($type, $rpos);
    my ($optgsize, $maxp);
    my ($numperow) = $opt{'r'} ? 10 : 4;

#    $font->tables_do(sub { $_[0]->read; });
    @rev = $font->{'cmap'}->read->reverse;

    $numg = $font->{'maxp'}->read->{'numGlyphs'};
    $upem = $font->{'head'}->read->{'unitsPerEm'};
    $font->{'loca'}->read->glyphs_do(sub {
        $_[0]->read;
        my ($x) = ($_[0]->{'xMax'}-$_[0]->{'xMin'});
        $mextx = $x if $x > $mextx;
        $_[0]->empty if ($numg > 1000 && !$opt{f});
    });
    $mexty = ($font->{'head'}{'yMax'} - $font->{'head'}{'yMin'}) / 64;
    $mextx /= 48;
    if ($opt{g})
    {
        my ($gextx, $gexty) = ($mextx * 48, $mexty * 64);
        my ($gmextx) = ($maxx - 116) * $upem / $gextx;
        my ($gmexty) = ($maxy - 288) * $upem / $gexty;
        $optgsize = $gmextx > $gmexty ? $gmexty : $gmextx;
    }

    $tsize = $opt{m} || int ($upem / ($mextx > $mexty ? $mextx : $mexty) * 100 - .5) / 100;
    $gsize = int ($upem / $mexty * 25 - .5) / 100;
#    print "tsize = $tsize\n";

    $tfont = Text::PDF::TTFont0->new($pdf, $font, "T$id");
    $root->add_font($tfont, $pdf);
    if ($numg > 1000 && !$opt{f})
    {
        $tfont->ship_out($pdf);
        $tfont->empty;
    }

#    print "numg = $numg\n";
    ($type, @cids) = $package->make_cids($font);
    $numc = @cids;
    $maxg = int(($maxy - 121) / 67) * $numperow;
    $nump = int(($numc + $maxg - 1) / $maxg);
#    print "maxg = $maxg\nnump = $nump\n";
    $maxp = $nump;
    $maxp += $numc if ($opt{g});

    $fname = $font->{'name'}->read->find_name(4);
    $cpyright = $font->{'name'}->find_name(0);
    $cpyright = PDFStr($pdf_helv->trim($cpyright, ($maxx - 72) / 5.6));

    # 80% compressed 7pt Helvetica
    $ARGV[0] =~ s/\\/\\/oig;
    $pcpy = "BT 1 0 0 1 36 " . ($maxy - 67) . " Tm 80 Tz /FR 7 Tf "
        . $cpyright->as_pdf . " Tj 0 8 Td " . asPDFStr("$ARGV[0]") . " Tj ET\n";
    $hdrlft = "BT 1 0 0 1 36 " . ($maxy - 48) . " Tm 80 Tz /FB 12 Tf "
        . asPDFStr($fname) . " Tj ET\n";
no strict;        
    $ftrleft = "BT 1 0 0 1 36 27 Tm 80 Tz /FR 7 Tf (FRET v$VERSION "
        . "Package $package " . ${"${package}::VERSION"} . ") Tj ET\n";
use strict;
    @time = split(/\s+/, localtime($opt{d} || time()));
    $tr = "Printed at $time[3] on $time[0] $time[2] $time[1] $time[4]   Page ";
    @time = split(/\s+/, localtime($font->{'head'}->getdate));
    $hdrrw = "Modified at $time[3] on $time[0] $time[2] $time[1] $time[4]";
    $rpos = $maxx - 36 - $pdf_helv->width($hdrrw) * 5.6;
    $hdrlft .= "BT 1 0 0 1 $rpos ". ($maxy - 58) . " Tm 80 Tz /FR 7 Tf "
        . "($hdrrw) Tj ET\n";
    $tr1 = " of $maxp";
    $hdrrw = ($pdf_helv->width($tr) + $pdf_helv->width($tr1)) * 9.6;
    $hdrright = "BT 1 0 0 1 %x " . ($maxy - 48) .
        " Tm 80 Tz /FR 12 Tf ($tr) Tj /FB 12 Tf (%p) Tj /FR 12 Tf ($tr1) Tj ET\n";
    $hdrbox = ".5 w 36 " . ($maxy - 86) . " 216 16 re S " .
        "198 " . ($maxy - 86) . " m 198 " . ($maxy - 70) . " l s $dots 198 " . ($maxy - 78) .
        " m 252 " . ($maxy - 78) . " l s 225 ". ($maxy - 86) . " m 225 ". ($maxy - 70) .
        " l s [] 0 d ".
        "BT 1 0 0 1 39 " . ($maxy - 81) . " Tm 80 Tz /FI 9 Tf (Size: ) Tj /FB 9 Tf ($tsize pt   ) Tj ".
        "/FI 9 Tf (Em: ) Tj /FB 9 Tf ($upem   ) Tj /FI 9 Tf ".
        "(Type: ) Tj /FB 9 Tf ($type) Tj 225 3 Td /FR 8 Tf (" . ($opt{'r'} ? '' : 'Glyph') . ") Tj ET\n";
    @boxhdr = $package->boxhdr($font);
    @boxloc = ([199, 85], [251, 85], [199, 77], [251, 77]);
    for ($i = 0; $i < 4; $i++)
    {
        my ($text) = $pdf_helv->trim($boxhdr[$i], 4.58);
        my ($x) = $boxloc[$i][0] - ($i & 1 ? $pdf_helv->width($text) * 4.8 : 0);
        
        $hdrbox .= "BT 1 0 0 1 $x " . ($maxy - $boxloc[$i][1]) . " Tm 80 Tz " .
                 "/FR 6 Tf " . asPDFStr($text) . " Tj ET\n";
    }

    $gcount = 0;
    @rowt = $package->row1hdr($font);
    @roww = widths(8, \@rowt);
# structure of @rown: array of [text strings, text widths, yorg, pt]
    push (@row1, [[@rowt], [@roww], $maxy - 77, 8]);
    @rowt = $package->row2hdr($font);
    @roww = widths(8, \@rowt);
    push (@row2, [[@rowt], [@roww], $maxy - 85, 8]);

#    if (0)
    for ($pnum = 1; $pnum <= $nump; $pnum++)
    {
        my ($rtext, $ybase, $xcentre, $row, $yorg);
        my ($glyph, $xorg, $xadv, $gxorg, $gyorg, @rowm, @xorg, @parms, $gcol);

        print STDERR "." unless ($opt{q} || $^O eq "MacOS");
        
        $ppage = Text::PDF::Page->new($pdf, $root);
        $ppage->add($hdrlft . $pcpy . $hdrbox . $ftrleft);
        $rpos = $maxx - ($hdrrw + $pdf_helvb->width($pnum) * 9.6) - 36;
        $rtext = $hdrright;
        $rtext =~ s/\%x/$rpos/oi;
        $rtext =~ s/\%p/$pnum/oi;
        $ppage->add($rtext);

        @row1 = ($row1[0]);
        @row2 = ($row2[0]);

        $ybase = $maxy - 153;
        for ($row = 0; $row < $maxg / $numperow; $row++)
        {
            $ppage->add(".5 w 36 $ybase " . ($numperow * 54) . " 64 re S ");
            for ($i = 0; $i < $numperow - 1; $i++)
            {
                my ($x) = 90 + $i * 54;
                $ppage->add("$x $ybase m $x " . ($ybase + 64) . " l S ");
            }
            unless ($opt{'r'})
            {
                $ppage->add(" $dots 264 " . ($ybase + 65.5) . " m " . ($maxx - 36) . " "
                   . ($ybase + 65.5) . " l s [] 0 d\n");
            }
            $yorg = $ybase + 32 - ($font->{'head'}{'yMax'} + $font->{'head'}{'yMin'}) * $tsize / $upem / 2;
            $ppage->add(sprintf("%s 36 %.4f m %d %.4f l S [] 0 d\n", $dots, $yorg, 36 + $numperow * 54, $yorg)) if ($yorg > $ybase);
            $xcentre = 63;
            for ($i = 0; $i < $numperow; $i++, $xcentre += 54)
            {
                next if ($gcount + $i >= $numc);
                $gcol = "";
                $gid = $package->cid_gid($cids[$gcount + $i], $font);
                $gid =~ s/^([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\|//oi
                        && ($gcol = sprintf("%.2f %.2f %.2f rg",
                                            hex($1), hex($2), hex($3)));
                $glyph = $font->{'loca'}{'glyphs'}[$gid];
                if ($glyph && $glyph->{' LEN'} != 0)
                {
                    $glyph->read;
                    $xorg = ($glyph->{'xMax'} + $glyph->{'xMin'}) * $tsize / $upem;
                    $xorg = $xcentre - $xorg / 2;
                    $xadv = $xorg + $font->{'hmtx'}{'advance'}[$gid] * $tsize / $upem;
                    $ppage->add(sprintf("%s %.4f %d m %.4f %d l S [] 0 d\n", $dots, $xadv, $ybase + 7, $xadv,$ybase + 57)) if ($xadv < $xcentre + 27);
                    $ppage->add(sprintf("%s %.4f %d m %.4f %d l S [] 0 d\n", $dots, $xorg, $ybase + 7, $xorg, $ybase + 57)) if ($xorg > $xcentre - 27 && $xorg < $xcentre + 27);
                    $ppage->add(sprintf("BT 1 0 0 1 %.4f %.4f Tm /T$id $tsize Tf 100 Tz $gcol <%04X> Tj %s ET\n", $xorg, $yorg, $gid, ($gcol ? "0 g " : "")));
                    unless ($opt{'r'})
                    {
                        $gxorg = ($glyph->{'xMax'} + $glyph->{'xMin'}) * $gsize / $upem / 2;
                        $gxorg = 274 - $gxorg;
                        $gyorg = $ybase + (3 - $i) * 16 + 8 - ($font->{'head'}{'yMax'} +
                                $font->{'head'}{'yMin'}) * $gsize / $upem / 2;;
                        $ppage->add(sprintf("BT 1 0 0 1 %.4f %.4f Tm /T$id $gsize Tf 100 Tz <%04X> Tj ET\n", $gxorg, $gyorg, $gid));
                    }
                }
                @parms = ($cids[$gcount + $i], $gid, $glyph, $rev[$gid], $font);
                @rowt = $package->topdat(@parms);
                @roww = widths(6, \@rowt);
                @xorg = ([$xcentre - 26, $xcentre + 24 - $roww[1]],
                        [$xcentre + 25 - $roww[1], $xcentre + 26]);
                $ppage->add(out_row($pdf, 6, $ybase + 58, \@xorg, \@rowt));
                @rowt = $package->lowdat(@parms);
                @roww = widths(6, \@rowt);
                @xorg = ([$xcentre - 26, $xcentre + 24 - $roww[1]],
                        [$xcentre + 25 - $roww[1], $xcentre + 26]);
                $ppage->add(out_row($pdf, 6, $ybase + 2, \@xorg, \@rowt));
                unless ($opt{'r'})
                {
                    @rowt = $package->row1(@parms);
                    @roww = widths(8, \@rowt);
                    push (@row1, [[@rowt], [@roww], $ybase + (3-$i) * 16 + 8.75, 8]);
                    @rowt = $package->row2(@parms);
                    @roww = widths(8, \@rowt);
                    push (@row2, [[@rowt], [@roww], $ybase + (3-$i) * 16 + .75, 8]);
                    $glyph->empty if ($glyph && $numg > 1000 && !$opt{f});
                }
            }
            $gcount += $numperow;
            last if ($gcount >= $numc);
            $ybase -= 67;
        }
        unless ($opt{'r'})
        {
            @rowm = maxwidth(\@row1, $maxx - 330);
            putrows($pdf, \@row1, \@rowm, 294, $ppage);
            @rowm = maxwidth(\@row2, $maxx - 348);
            putrows($pdf, \@row2, \@rowm, 312, $ppage);
        }
        $ppage->{' curstrm'}{'Filter'} = PDFArray(PDFName('FlateDecode'));
        $ppage->ship_out($pdf);
        $ppage->empty;
    }

    return unless $opt{g};
    
    my ($fxmin, $fymin) = ($font->{'head'}{'xMin'}, $font->{'head'}{'yMin'});
    my ($blob) = "q 2 w 1 J s Q";
    my ($bigblob) = "q 4 w 1 J s Q";
    my ($offblob) = "q .5 w 1 J s Q";
    my ($rtext, $glyph, $gcol, $xorg, $yorg, $xwidth);
    my ($points, $onoff, $ends, $corners, $j, @dirs, $txt, $jnext, $jprev);
    my ($p, $x, $y, $e, $cx, $cy, $x0, $y0, $xlast, $ylast, $iscurve);
    my ($tw, $tx, $ty, $ta);
    
    for ($i = 0; $i < $numc; $i++)
    {
        print STDERR "+" unless ($opt{q} || $^O eq "MacOS");

        $gid = $package->cid_gid($cids[$i], $font);
        $gid =~ s/^([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\|//oi
                && ($gcol = sprintf("%.2f %.2f %.2f rg",
                                    hex($1), hex($2), hex($3)));
        $glyph = $font->{'loca'}{'glyphs'}[$gid];
        next unless $glyph;
        $glyph->read;
        $pnum = $nump + $i + 1;
        $ppage = Text::PDF::Page->new($pdf, $root);
        $ppage->add($hdrlft . $pcpy . $ftrleft);
        $rpos = $maxx - ($hdrrw + $pdf_helvb->width($pnum) * 9.6) - 36;
        $rtext = $hdrright;
        $rtext =~ s/\%x/$rpos/oi;
        $rtext =~ s/\%p/$pnum/oi;
        $ppage->add($rtext);

        $yorg = 144 - $fymin * $optgsize / $upem;
        $ppage->add("$dots 58 $yorg m " . ($maxx - 58) . " $yorg l S [] 0 d\n");
        $xorg = 58 - $fxmin * $optgsize / $upem;
        $ppage->add("$dots $xorg 144 m $xorg " . ($maxy - 144) . " l S [] 0 d\n");
        $xwidth = ($font->{'hmtx'}{'advance'}[$gid] - $fxmin) * $optgsize / $upem + 58;
        $ppage->add("$dots $xwidth 144 m $xwidth " . ($maxy - 144) . " l S [] 0 d\n");
        $ppage->add("BT 1 0 0 1 36 " . ($maxy - 132) . " Tm /T$id $tsize Tf 100 Tz " .
                $gcol . sprintf("<%04X> Tj " . ($gcol ? "0 g " : "") . "ET\n", $gid));
#        $ppage->add("BT 1 0 0 1 " . ($maxx - 36 - $pdf_helvb->width("$i") * 19.2) . " " .
#                ($maxy - 136) . " Tm 80 Tz /FB 24 Tf ($i) Tj ET\n");
        @rowt = $package->topdat($cids[$i], $gid, $glyph, $rev[$gid], $font);
        foreach (@rowt) { s/^(.*?\|)?/r,b|/o; }
        @roww = widths(24, \@rowt);
        $ppage->add(out_row($pdf, 24, $maxy - 118, [[200, $maxx - 36]], [$rowt[0]]));
        $ppage->add(out_row($pdf, 24, $maxy - 94, [[200, $maxx - 36]], [$rowt[1]]));

        $points = [];
        @dirs = ();
        ($points, $onoff, $ends, $corners) = get_points($font, $glyph, $points, 1, 0, 0, 1);
        $e = 0;
        for ($j = 0; $j <= $#{$points}; $j++)
        {
            $x = ($points->[$j][0] - $fxmin) * $optgsize / $upem + 58;
            $y = ($points->[$j][1] - $fymin) * $optgsize / $upem + 144;
            $jnext = ($j == $ends->[$e] ? ($e == 0 ? 0 : $ends->[$e-1] + 1) : $j + 1);
            $jprev = ($j == 0 || $j == $ends->[$e-1] + 1) ? $ends->[$e] : $j - 1;
            if ($j == 0 || $j == $ends->[$e - 1] + 1)
            {
                unless ($j == 0)
                {
                    $ppage->add(curveto($cx, $cy, $x0, $y0, $xlast, $ylast)) if ($iscurve);
                    $ppage->add(" s\n");
                }
                $ppage->add(sprintf("%.2f %.2f m", $x, $y));
                ($x0, $y0) = ($xlast, $ylast) = ($x, $y);
                $iscurve = 0;
            } elsif (!$onoff->[$j])
            {
                if ($iscurve)
                {
                    ($tx, $ty) = (.5 * ($cx + $x), .5 * ($cy + $y));
                    $ppage->add(curveto($cx, $cy, $tx, $ty, $xlast, $ylast));
                    ($xlast, $ylast) = ($tx, $ty);
                }
                ($cx, $cy) = ($x, $y);
                $iscurve = 1;
            } else
            {
                if ($iscurve)
                { $ppage->add(curveto($cx, $cy, $x, $y, $xlast, $ylast)); }
                else
                { $ppage->add(sprintf(" %.2f %.2f l", $x, $y)); }
                $iscurve = 0;
                ($xlast, $ylast) = ($x, $y);
            }
            push (@dirs, [($points->[$jprev][1] - $points->[$jnext][1]) / $upem,
                            ($points->[$jnext][0] - $points->[$jprev][0]) / $upem]);
            $e++ if ($j == $ends->[$e]);
        }
        if ($iscurve)
        { $ppage->add(curveto($cx, $cy, $x0, $y0, $xlast, $ylast)); }
        $ppage->add(" s\n");
        $e = 0;
        for ($j = 0; $j <= $#{$points}; $j++)
        {
            $x = ($points->[$j][0] - $fxmin) * $optgsize / $upem + 58;
            $y = ($points->[$j][1] - $fymin) * $optgsize / $upem + 144;
            $e++ if ($j == $ends->[$e] + 1);
            $txt = $package->label($glyph, $j, @{$points->[$j]}, $e, $onoff->[$j], $font);
            
            if ($onoff->[$j])
            {
                if ($j == 0 || $j == $ends->[$e-1] + 1)
                { $ppage->add(sprintf("%.2f %.2f m %s\n", $x, $y, $bigblob)); }
                else
                { $ppage->add(sprintf("%.2f %.2f m %s\n", $x, $y, $blob)); }
            } else
            { $ppage->add(sprintf("%.2f %.2f m %s\n", $x, $y, $offblob)); }
            if ($txt ne '' && ($opt{'h'} & 1) == 0)
            {
                $tw = $pdf_helv->width($txt) * 4.8 + 2;         # 6pt + 2pt margin
                $tx = $x + ($dirs[$j][0] > 0 ? 0 : -$tw);
                $ty = $y + ($dirs[$j][1] > 0 ? 0 : -6);
#                $tx = $dirs[$j][0] ? $tw / $dirs->[$j][0] : 300;
#                $ty = $dirs[$j][1] ? 3 / $dirs->[$j][1] : 300;                   # centre == 2pt + 1pt margin
#                $ta = (abs($tx) > abs($ty)) ? abs($ty) : abs($tx);
#                $tx = $x + $ta * $dirs->[$j][0] * $optgsize;
#                $ty = $y + $ta * $dirs->[$j][1] * $optgsize;
                $ppage->add(sprintf("BT 1 0 0 1 %.2f %.2f Tm 80 Tz /FR 6 Tf %s Tj ET\n",
                        $tx, $ty, asPDFStr($txt)));
            }
        }
        if (($opt{'h'} & 2) == 0)
        {
            my ($points) = $package->extra_points($font, $gid, $glyph);

            foreach my $p (@{$points})
            {
                $x = ($p->[0] - $fxmin) * $optgsize / $upem + 58;
                $y = ($p->[1] - $fymin) * $optgsize / $upem + 144;
                $ppage->add(sprintf("%.2f %.2f m %s\n", $x, $y, $bigblob));
                $ppage->add(sprintf("BT 1 0 0 1 %.2f %.2f Tm 80 Tz /FR 8 Tf %s Tj ET\n",
                        $x + 3, $y - 3, asPDFStr($p->[2])));
            }
        }
        $ppage->{' curstrm'}{'Filter'} = PDFArray(PDFName('FlateDecode'));
        $ppage->ship_out($pdf);
        $ppage->empty;
        $glyph->empty;
    }
}

sub curveto
{
    my ($cx, $cy, $x, $y, $xl, $yl) = @_;
    my ($p1x, $p1y, $p2x, $p2y);

    $p1x = (2 * $cx + $xl) / 3;
    $p1y = (2 * $cy + $yl) / 3;
    $p2x = (2 * $cx + $x) / 3;
    $p2y = (2 * $cy + $y) / 3;

    sprintf(" %.2f %.2f %.2f %.2f %.2f %.2f c", $p1x, $p1y, $p2x, $p2y, $x, $y);
}
    

# Taken from Geometric Algorithms - 2D Cross product
sub clockwise
{
    my ($p0, $p1, $p2) = @_;
    return ($p2->[0] - $p0->[0]) * ($p1->[1] - $p0->[1])
        - ($p1->[0] - $p0->[0]) * ($p2->[1] - $p0->[1]);
}


sub get_points
{
    my ($font, $glyph, $points, @scale) = @_;
    my ($onoff, $ends, $corners);
    my ($comp, $g);

    $glyph->read_dat;
    if ($glyph->{'numberOfContours'} < 0)
    {
        foreach $comp (@{$glyph->{'comps'}})
        {
            my (@tcorner, $cg);
            $cg = $font->{'loca'}{'glyphs'}[$comp->{'glyph'}];
            my ($tpoints, $tonoff, $tends, $tcorners)
                    = get_points($font, $cg, $points, mat_mult($comp->{'scale'}, \@scale));
            my ($base) = $#{$points};
            $base++ if ($base != 0);
                
            push (@$points, map {[$_->[0] + $comp->{'args'}[0], $_->[1] + $comp->{'args'}[1]]}
                    @$tpoints);
            push (@$onoff, @$tonoff);
            push (@$ends, map {$_ + $base} @$tends);
            
            @tcorner = mat_mult($comp->{'flag'} & 200 ? $comp->{'scale'} : [1, 0, 0, 1],
                    [$cg->{xMin}, $g->{'yMin'}, $cg->{'xMax'}, $cg->{'yMax'}]);
            push (@$corners, [@tcorner]);
        }
        return ($points, $onoff, $ends, $corners);
    } else
    {
        my ($count) = $glyph->{'numPoints'} - 1;

        return ([map({[$glyph->{'x'}[$_], $glyph->{'y'}[$_]]} (0 .. $count))],
            [map({$glyph->{'flags'}[$_] & 1} (0 .. $count))],
            $glyph->{'endPoints'}, undef);
    }
}


sub mat_mult
{
    my ($x, $y) = @_;
    my (@res);

    $res[0] = $x->[0]*$y->[0] + $x->[1]*$y->[2];
    $res[1] = $x->[0]*$y->[1] + $x->[1]*$y->[3];
    $res[2] = $x->[2]*$y->[0] + $x->[3]*$y->[2];
    $res[3] = $x->[2]*$y->[1] + $x->[3]*$y->[4];
    (@res);
}
        

sub widths
{
    my ($pt, $row) = @_;
    my ($type, @info, $ft, $fr, $g, $f, $col, @resv, @rest, $i, $e);

    @resv = ();
    for ($i = 0; $i <= $#{$row}; $i++)
    {
        $e = $row->[$i];
        $e =~ s/^(.*[^\\])\|//oi;
        $type = $1;
        @info = split(',', $type);
        $ft = "";
        if ($info[1] =~ /b/oi)
        {
            $ft = "B";
            $fr = $pdf_helvb;
        }
        if ($info[1] =~/i/oi)
        {
            $ft .= "I";
            $fr = $ft eq "B" ? $pdf_helvbi : $pdf_helvi;
        }
        unless ($ft)
        {
            $ft = "R";
            $fr = $pdf_helv;
        }
        $info[0] = "l" unless $info[0];
        $g = $fr->width($e) * $pt * .8;
        push (@resv, $g);
    }
    (@resv);
}

sub out_row
{
    my ($pdf, $pt, $yorg, $xorg, $row) = @_;
    my ($xl, $xc, $xr, $e, $res, $i, $g, $f, $col, @info, $ft, $fr, $type);

    for ($i = 0; $i <= $#{$row}; $i++)
    {
        $xl = $xorg->[$i][0];
        $xr = $xorg->[$i][1];
        $e = $row->[$i];
        $e =~ s/^(.*[^\\])\|//oi;
        $type = $1;
        $e =~ s/\\\|/\|/oig;
        @info = split(',', $type);
        $ft = "";
        if ($info[1] =~ /b/oi)
        {
            $ft = "B";
            $fr = $pdf_helvb;
        }
        if ($info[1] =~/i/oi)
        {
            $ft .= "I";
            $fr = $ft eq "B" ? $pdf_helvbi : $pdf_helvi;
        }
        unless ($ft)
        {
            $ft = "R";
            $fr = $pdf_helv;
        }
        $g = $fr->width($e) * $pt * .8;
        if ($g > $xr - $xl)
        {
            $e = $fr->trim($e, ($xr - $xl) * 1.25 / $pt);
            $g = $fr->width($e) * $pt * .8;
        }
        $xc = ($xl + $xr - $g) / 2;
        $xr -= $g;
        $col = sprintf("%.2f %.2f %.2f rg", hex($1)/256, hex($2)/256, hex($3)/256)
                if $info[2] =~ m/([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})/oi;
        $f = "BT $col 1 0 0 1 ";
        if ($info[0] =~ m/r/oi)
        { $f .= sprintf("%.4f", $xr); }
        elsif ($info[0] =~ m/c/oi)
        { $f .= sprintf("%.4f", $xc); }
        else
        { $f .= sprintf("%.4f", $xl); }
        $f .= sprintf(" %.4f Tm ", $yorg);
        $g = PDFStr($e);
        $f .= "/F$ft $pt Tf 80 Tz " . $g->as_pdf . " Tj ET";
        $f .= " 0 g" if ($col);
        $col = "";
        $res .= "$f\n";
    }
    $res;
}

sub maxwidth
{
    my ($row, $total) = @_;
    my ($i, @resm, $max, $j, $e);

    for ($i = 0; $i <= $#{$row}; $i++)
    {
        $e = $row->[$i][1];
        for ($j = 0; $j <= $#{$e}; $j++)
        { $resm[$j] = $e->[$j] if $e->[$j] > $resm[$j]; }
    }
    foreach (@resm)
    { $max += $_; }
    if ($max > $total && $^O ne "MacOS")
    { print STDERR "Warning overfull box. Truncating all boxes on the page!\n"; }
    $max = ($total - $max) / @resm;
    for ($i = 0; $i <= $#resm; $i++)
    { $resm[$i] += $max; }
    @resm;
}

sub putrows
{
    my ($pdf, $row, $rowm, $x, $npage) = @_;
    my ($i, $j, $rowt, @rowp);

    for ($i = 0; $i <= $#{$rowm}; $i++)
    { push (@rowp, [$x, $x + $rowm->[$i]]); $x += $rowm->[$i]; }
    
    for ($i = 0; $i <= $#{$row}; $i++)
    { $npage->add(out_row($pdf, $row->[$i][3], $row->[$i][2], \@rowp, $row->[$i][0])); }
}

1;

package Font::Fret::Default;

use strict;
use vars qw(@macrev $VERSION);

BEGIN
{
    $VERSION = "1.0";
}


=head1 NAME

Fret - Font REporting Tool

=head1 SYNOPSIS

    use Font::Fret;
    fret('', @ARGV);

or

    package myFret;
    use Font::Fret;
    @ISA = qw(Font::Fret::Default);
    fret('myFret', @ARGV);

=head1 DESCRIPTION

Fret is a font reporting tool system which allows for different reports to be
written. A report is a package on which calls are made to give specific information
for a specific report. The rest of Fret does the housekeeping of generating the
report in PDF format.

The function C<fret> which is imported when the Fret moduled is 'use'd, takes
two arguments: the name of the report package and the command line array. Fret
does all the work of parsing the command line, etc. and just makes call-backs into
the package it is asked to use.

Fret.pm comes with its own default report package (called Font::Fret::Default)
which may be subclassed to generate other reports.

The overall structure of the interaction between Fret and the reporting
package is that Fret will ask the package for a list of character ids in
the order in which those characters should appear in the report. For
each character, Fret will ask the package to create a glyph id for that
character. This allows a double layer of indirection in arriving at the list of
glyph ids to process, allowing a glyph to appear twice in the report with
different information about it each time.

There are two important areas in a report: inside the glyph box (where there are
four corners in which information may be displayed) and the report area, which
consists of two independent rows of information for each glyph. Each row type
is columnated independently across all the glyphs on a page.

In addition to where the report information is displayed, there is also a mechanism
which allows a limited level of formatting of the information. The text may be
justified left, right or centre and the font styling may be adjusted between
regular, bold, italic and bold italic and the colour of the text may be changed.
Notice that the font face may not be changed or the font size or anything else.
A formatted string consists of formatting information separated from the string
by C<|>. If a string needs to contain a C<|> it should be escaped thus:
C<\|> (notice that there is no need to escape C<\> or any other character).

The formatting is structured as a comma separated list of 3 elements: justification,
font styling and then colour.

=over 8

=item justification

The values are r: right justified; c: centred and the default of l: left justified

=item font styling

The values are r: regular (by default); i: italic; b: bold; bi: bold-italic

=item colour

The colour is a string of 6 hex digits corresponding to 8-bits of Red, Green
and Blue information

=back

=head1 METHODS


=head2 make_cids

This subroutine is called to ask for a list of character ids, which will be used
to generate glyph ids and thence glyphs. The returned list is rendered in the
order of the list.

The first item on the returned list is used to display the type of report in the
box header. This string may not be formatted.

This allows a FRET report writer to generate any sequence of glyphs in their
report (e.g. Unicode based, pass/fail conditions, etc.)

=cut

sub make_cids
{
    my ($class, $font) = @_;

    return ("Glyph ID", 0 .. $font->{'maxp'}{'numGlyphs'} - 1);
}

=head2 cid_gid

This is called to convert a character id into a glyph id for rendering.

=cut

sub cid_gid
{
    my ($class, $cid, $font) = @_;

    return $cid;
}


=head2 boxhdr

This subroutine is called to ask the report for the headings for the four items
displayed in a box. The headings appear in the box header. The order of the
returned list of string is: bottom left, bottom right, top left, top right.
The strings may not be formatted in any way.

=cut

sub boxhdr
{
    my ($class, $font) = @_;

    return ("Advance", "Mac ID", "GID", "Unicode");
}


=head2 topdat

This subroutine returns the two strings that constitute what should be displayed
in the top of a glyph box. The two strings allow for per glyph formatting. Notice
that the default action is to render the right hand element (the second element)
right justified.

=cut

sub topdat
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;

    return ($gid, sprintf("r,r|U+%04X", $uid));
}


=head2 lowdat

This subroutine returns two elements for the two elements displayed at the bottom
of a glyph box. The elements may be formatted for colour, etc. and the second
should be right formatted.

=cut

sub lowdat
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;

    return ($font->{'hmtx'}{'advance'}[$gid], "r|$macrev[$gid]");
}


=head2 row1hdr

This returns the heading information for the first report row. The value returned
is a list of formatted items, which will be used to head the columns in row 1 of
the report area. These will be combined in the column width calculations.

=cut

sub row1hdr
{
    my ($class, $font) = @_;
    my ($i);

    for ($i = 0; $i < $font->{'cmap'}{'Num'}; $i++)
    {
        if ($font->{'cmap'}{'Tables'}[$i]{'Platform'} == 1)
        { @macrev = $font->{'cmap'}->reverse($i); last; }
    }

    return ('GID', 'Mac', 'UID', 'r|lsb', 'r|rsb',
            'r,b|adv', 'r,i|xmax', 'r,i|xmin', 'r,i|ymax', 'r,i|ymin');
}


=head2 row2hdr

Returns a list of formatted items corresponding to the column headers for row 2
of the report area.

=cut

sub row2hdr
{
    my ($class, $font) = @_;

    return (',,008000|PSname');
}


=head2 row1

This subroutine is called for each glyph to return the content of each column in
row 1 as a list of formatted items. The values passed in are:

    cid     character id as passed to cid_gid
    gid     glyph id as returned from cid_gid and is an index into the font
            for such tables as hmtx.
    glyph   the glyph object from the font i.e. $font->{'loca'}{glyphs}[$gid]
    uid     unicode reverse lookup of the gid. This is the lowest Unicode value
            which maps to this gid
    font    the font object corresponding to this font

Each element in the returned list corresponds to an element in the returned list
for row1hdr

=cut

sub row1
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;
    my ($aw) = $font->{'hmtx'}{'advance'}[$gid];
    my ($rsb) = $aw - $glyph->{'xMax'};

    return ($gid, $macrev[$gid], sprintf("x%04X", $uid),
            "r|$font->{'hmtx'}{'lsb'}[$gid]",
            $rsb >= 0 ? "r|$rsb" : "r,b,0000FF|$rsb",
            "r,b|$aw", "r,i|$glyph->{'xMax'}",
            "r,i|$glyph->{'xMin'}", "r,i|$glyph->{'yMax'}",
            "r,i|$glyph->{'yMin'}");
}


=head2 row2

As per row 1 for row 2

=cut

sub row2
{
    my ($class, $cid, $gid, $glyph, $uid, $font) = @_;

    return (",,008000|$font->{'post'}{'VAL'}[$gid]");
}


=head2 label

Given:

    Glyph
    Point number
    [x, y] point co-ordinates
    path number
    on or off point
    font

Returns a simple string for the label for the point

=cut

sub label
{
    my ($class, $glyph, $pnum, $x, $y, $path, $onoff, $font) = @_;

    if ($glyph->{'numberOfContours'} > 0 && $onoff)
    { return sprintf("%d.%d(%d,%d)", $pnum, $path, $x, $y); }
    return '';
}


=head2 extra_points

Returns an array of arrays for a list of extra points to display on the glyph page.
Each sub array consists of [x, y, label]

=cut

sub extra_points
{
    my ($class, $font, $gid, $glyph) = @_;

    return [];
}