#!/usr/bin/perl -w
use strict;

my @current_char;
my @chars;

sub lmax {
 my $best = $_[0];
 for my $x (@_[1..$#_]) {
   $x > $best and $best = $x;
 }
 $best;
}
sub lmin {
 my $best = $_[0];
 for my $x (@_[1..$#_]) {
   $x < $best and $best = $x;
 }
 $best;
}
sub round {
  int($_[0]); # rounding down to nearest integer seems to be sufficient...
              # still it's annoying that ps2ps emits rcurvetos and not curvetos,
              # I wonder if there's a way of changing that.
}

# Read in paths from postscript file on stdin.

# We're assuming output from ps2ps, so that
# m means moveto
# c means rcurveto
# p means a sequence of rlinetos.
# f means fill

my ($x, $y);
while (<>) {
    if (/^(\S+) (\S+) m$/) {
      $x = $1;
      $y = $2;
      push @current_char, ["m", $x, $y];
    }
    if (/^((\S+ \S+ )*)p$/) {
      for ($1 =~ /(\S+ \S+)/g) {
        my ($dx, $dy) = split;
        $x += $dx;
        $y += $dy;
        push @current_char, ["l", $x, $y];
      }
    }
    if (/^(\S+) (\S+) (\S+) (\S+) (\S+) (\S+) c$/) {
      my @rv = ();
      push @rv, ($x + $1, $y + $2);
      push @rv, ($x + $3, $y + $4);
      $x += $5; $y += $6; push @rv, ($x, $y);
      push @current_char, ["c", @rv];
    }
    if (/^f$/) { push @chars, {path => [@current_char]}; @current_char = () }
}

# Patch up rounding error on path begin and end points

for my $x (@chars) {
  for my $i (@{$x->{path}}) {
    $i->[-2] = round($i->[-2]);
    $i->[-1] = round($i->[-1]);
  }
}

# Compute left and right bounds on each path

for my $x (@chars) {
  my @xs = map {$_->[-2]} @{$x->{path}}; # second to last is always x coord of point
  $x->{xmin} = lmin(@xs);
  $x->{xmax} = lmax(@xs);
}

# Sort by midpoint of x extent

sub mid { $_[0]{xmin} + $_[0]{xmax} }
@chars = sort { mid($a) <=> mid($b) } @chars;

# XXX At this point we should union-find overlapping intervals

# Emit SFD file on stdout.
my $num_chars = @chars;

print <<EOF;
SplineFontDB: 3.0
FontName: Untitled
FullName: Untitled
FamilyName: Untitled
Ascent: 800
Descent: 250
Encoding: UnicodeBmp
BeginChars: 65536 $num_chars
EOF

my $enc = 0;

for (@chars) {
my $ascii = 65 + $enc;
  print <<EOF;
StartChar: none
Encoding: $ascii $ascii $enc
Width: 500
Fore
SplineSet
EOF

  for my $i (@{$_->{path}}) {
    print join " ", @{$i}[1..$#$i], $i->[0], 4, "\n";
  }
  print "EndSplineSet\nEndChar\n";
  $enc++;
}

print "EndChars\nEndSplineFont\n";

1. Draw a font as a series of letters left to right
   
2. Scan it in in like photoshop or something, crop it nicely
   
3. Save it as some format that potrace understands (bmp, pbm, pgm)
   
4. potrace font.pgm (this produces font.eps)
   
5. ps2ps font.eps font.ps (this optimizes normalizes the postscript)
   
6. perl ps2sfd.pl font.ps > font.sfd (this finds all disjoint shapes in the image, sorts them from left to right, and inserts them in a fresh fontforge file starting at "A")
   
7. Open it up in fontforge and clean things up. Letter consisting of multiple disjoint splines will have to be merged by hand. This is something I could probably easily fix by doing the proper sort of union find on horizontally overlapping shapes. Doing mass transforms to shift stuff down vertically is useful. Also "set both bearings" to 50 gets rid the insane amount of horizontal space introduced by ps2sfd.pl.
   
8. Generate TTF as usual in fontforge