#!/usr/bin/env perl
# Convert PC Screen Font (PSF) font to Glyph Bitmap Distribution Format (BDF).
# Copyright (c) 2015 Kacper Gutowski
# Copyright (c) 2015 Susanne Oberhauser-Hirschoff
# The MIT License applies (http://opensource.org/licenses/MIT)

# https://gist.github.com/mwgamera/6ad86e71e002e5aef1b8/01ffe8208b2763dd353ea7afacedf83072477372
# with minor fixes

use strict;

use constant {
    PSF1_MODE512           => 0x01,
    PSF1_MODEHASTAB        => 0x02,
    PSF2_HAS_UNICODE_TABLE => 0x01,
};

push @ARGV, '-' unless scalar @ARGV;

for (@ARGV) {
    my $fn = /^-$/ ? 'stdin' : $_;
    eval {

        my ($length, $width, $height);
        my (@glyphs, @unicode);
        my $unilen = 0;

        open my $fh, $_ or die $!;
        binmode $fh;
        read $fh, $_, 4 or die $!;

        if (0x0436 == unpack 'v') {    # psf1
            my ($mode, $size) = unpack 'x2CC';
            $length = $mode & PSF1_MODE512 ? 512 : 256;
            $height = $size;
            $width  = 8;
            read $fh, $_, $length * $size;
            @glyphs = unpack "(a$size)$length";
            if ($mode & PSF1_MODEHASTAB) {
                for my $i (0 .. $length - 1) {
                    my ($u, @u) = 0;
                    do {
                        read $fh, $_, 2;
                        $u = unpack 'v';
                        push @u, $u if $u < 0xFFFE;
                    } while $u < 0xFFFE;
                    while ($u != 0xFFFF) {
                        read $fh, $_, 2;
                        $u = unpack 'v';
                        warn 'Unicode sequence ignored' if $u == 0xFFFE;
                    }
                    $unicode[$i] = [@u];
                    $unilen += (scalar @u) - 1 if (scalar @u);
                }
            }
        }
        elsif (0x864ab572 == unpack 'V') {    # psf2
            read $fh, $_, 28 or die $!;
            (my ($ver, $hlen, $flg), $length, my $size, $height, $width) = unpack 'V7';
            die "Unknown version $ver\n" unless $ver == 0;
            warn "Unexpected glyph size $size bytes for ${width}×$height px\n"
              unless $size == $height * int(($width + 7) / 8);
            read $fh, $_, $hlen - 32;         # skip to data
            read $fh, $_, $length * $size;
            @glyphs = unpack "(a$size)$length";
            if ($flg & PSF2_HAS_UNICODE_TABLE) {
                my $buf = do { local $/; <$fh>; };
                for my $i (0 .. $length - 1) {
                    $buf =~ m/\G([^\xfe\xff]*+)(?:\xfe[^\xfe\xff]++)*\xff/sg;
                    utf8::decode(my $str = $1);
                    $unicode[$i] = [map ord, split //, $str];
                    $unilen += (scalar @{$unicode[$i]}) - 1 if (scalar @{$unicode[$i]});
                }
            }
        }
        else {
            die "Bad format\n";
        }


        print "STARTFONT 2.1\n";
        printf "FONT %s\n",                   '-psf-';
        printf "SIZE %u 72 72\n",             $height;
        printf "FONTBOUNDINGBOX %u %u 0 0\n", $width, $height;

        printf "STARTPROPERTIES %u\n", 6 + 2 * !!@unicode;
        printf "PIXEL_SIZE %u\n",      $height;
        printf "POINT_SIZE %u\n",      10 * $height;
        printf "FONT_ASCENT %u\n",     $height;
        print "FONT_DESCENT 0\n";
        print "RESOLUTION_X 72\n";
        print "RESOLUTION_Y 72\n";
        if (@unicode) {
            print "CHARSET_REGISTRY \"ISO10646\"\n";
            print "CHARSET_ENCODING \"1\"\n";
        }
        print "ENDPROPERTIES\n";

        printf "CHARS %u\n", $length + $unilen;

        for my $i (0 .. $length - 1) {
            my @encodings = ($i);
            my $is_unicode = 0;

            if(@unicode && @{$unicode[$i]}) {
                @encodings = @{$unicode[$i]};
                $is_unicode = 1;
            }

            foreach my $e (@encodings) {
                printf "STARTCHAR psf%03x-%04x\n", $i, $e;
                if ($is_unicode) {
                    printf "ENCODING %u\n", $e;
                }
                else {
                    printf "ENCODING -1 %u\n", $e;
                }
                printf "SWIDTH %u 0\n",   $width * 1000 / $height;
                printf "DWIDTH %u 0\n",   $width;
                printf "BBX %u %u 0 0\n", $width, $height;
                my $bw = (($width + 7) & ~7) >> 3;
                printf "BITMAP\n%s\n", join "\n", map unpack('H*', $_), unpack "(a$bw)*", $glyphs[$i];
                printf "ENDCHAR\n";
            }
        }

        print "ENDFONT\n";

    };
    warn "$fn: $@" if $@;
    last;
}