#!/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";
Instructions for using it:
- Draw a font as a series of letters left to right
- Scan it in in like photoshop or something, crop it nicely
- Save it as some format that potrace understands (bmp, pbm, pgm)
- potrace font.pgm (this produces font.eps)
- ps2ps font.eps font.ps (this optimizes normalizes the postscript)
- 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")
- 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.
- Generate TTF as usual in fontforge
The whole process of (draw font, scan in font, write script, run script, fiddle with font-page CMS, upload) took only about a couple hours, which I am pretty content with.