#!/usr/bin/perl -w
# This script requires 't1asm' program, which is part of t1utils package,
# and 'pfaedit'.

use strict;
use utf8;
use IO::Socket::INET;
use BerkeleyDB;

my $omegadb_path="/usr/local/lib/chise/omega"; # set to the path of your db and script.

my $kageaddr="kage2.fonts.jp:80"; # Specify port number!
my $kagecgi="/~kamichi/test/kagecgi.cgi"; #

my $t1asm = "/usr/bin/env t1asm"; # point to 't1asm' executable.
#die "Cannot execute $t1asm. Abort.\n" unless -x $t1asm;
my $pfaedit="/usr/bin/env pfaedit"; # point to 'pfaedit' executable.
#die "Cannot execute $pfaedit. Abort.\n" unless -x $pfaedit;

$omegadb_path=~s!/$!!;

my $cleanup_script="$omegadb_path/svg2t1.pfe"; # Check the path of pfaedit script.
my $dbpath="$omegadb_path/glyph.db"; # check your DB path.

# Open Glyph Database
my $db = new BerkeleyDB::Hash
    -Filename => $dbpath, -Flags => DB_CREATE
    || print STDERR "Cannot open $dbpath. Do not use glyph database.\n";

####################
#### subroutines ###
####################

sub printheader {
my ($fontname, $fullname, $familyname,
    $weight, $version, $uniqueID,
    $numchars,  $encoding) = @_;
return <<"HEADER";
%!PS-Adobe-Font-1.0: $fontname
11 dict begin
/PaintType 0 def
/FontType 1 def
/FontMatrix [0.001 0 0 0.001 0 0] readonly def
/UniqueID $uniqueID def
/FontBBox [0 -100 1000 900 ]readonly def
/FontInfo 8 dict dup begin
 /version ($version) readonly def
 /Notice (Copyright (C) Chise Project; Glyphs generated by KAGE server) readonly def
 /FullName ($fullname) readonly def
 /FamilyName ($familyname) readonly def
 /Weight ($weight) readonly def
 /ItalicAngle 0 def
 /isFixedPitch true def
 /UnderlinePosition -200 def
end readonly def
$encoding
currentfile eexec
dup
/Private 9 dict dup begin
/-|{string currentfile exch readstring pop}executeonly def
/|-{noaccess def}executeonly def
/|{noaccess put}executeonly def
/BlueValues [] noaccess ND
/UniqueID $uniqueID def
/MinFeature{16 16} |-
/ForceBold false def
/password 5839 def
/lenIV 4 def
end readonly def
2 index /CharStrings $numchars dict dup begin
HEADER
}

sub printfooter {
return <<"FOOTER";
/.notdef {
        0 1000 hsbw
        endchar
        } |-
end
end
readonly put
noaccess put
dup/FontName get exch definefont pop
mark currentfile closefile
cleartomark
FOOTER
}

# Convert svg to Type1 charstring.
# Return: Type1 charstring.
sub svg2charstring {
    my ($svg) = @_;
    my @paths= split(/\n/, $svg);
    my ($x1, $y1, $x2, $y2);
    my $glyph= "\{\n0 1000 hsbw\n";
    for (@paths){
	if(m/error/i){
	    return undef;
	}
	next unless /\<path d=\"M([0-9, ]+)Z\"\/\>/;
	my $path = $1; $path =~ s/^ +//; $path =~ s/ +$//;
	my @point_pair = split(/ /, $path);
	($x1, $y1) =  split(/,/, shift(@point_pair));
	$y1=1000-$y1-100;
	if(defined $x2){
	    $glyph.=sprintf("%d %d rmoveto\n", $x1-$x2, $y1-$y2);
	}else{
	    $glyph.= "$x1 $y1 rmoveto\n";
	}
	foreach my $pair (@point_pair) {
	    ($x2, $y2) = split(/,/, $pair);
	    $y2=1000-$y2-100;
	    $glyph.=sprintf("%d %d rlineto\n", $x2-$x1, $y2-$y1);
	    $x1=$x2; $y1=$y2;
	}
	$glyph.= "closepath\n";
    }
    return $glyph.= "endchar\n\} |-\n";
}

# Query KAGE server and generate Type1 charstrings.
# Return: charstrings, encoding vector, and number of chars.
sub makefont{
    my ($requests, $suffix) = @_; # Receive REF for @requests array.
    my $charstrings = "";
    my $charnum=0;
    my $encoding=""; # /Encoding vector
    my $blackbox=<<'BLACKBOX';
    {
	0 1000 hsbw
	 100 800 rmoveto
	 -800 vlineto
	 800 hlineto
	 800 vlineto
	 closepath
	 endchar} |-
BLACKBOX

     foreach my $req (@$requests){
	 # Note:
	 # Referene passing destroys the original array!
	 my $request="$req.$suffix";
	 my ($svg, $charstring);
	 my $char = sprintf("ch%03d", $charnum);
	 if(defined $db && $db->db_get($request, $svg)==0){
	     # If glyph is already in DB, then use it.
	     $charstring = svg2charstring($svg);
	     print STDERR "Use cached glyph for $request.\n";
	 }else{
	     # If glyph is not yet in DB, query KAGE server.
	     my $kageserver;
	     my $location; # For redirection
	     if($kageserver = IO::Socket::INET->new("$kageaddr")){
		 print $kageserver "HEAD /$request.svg HTTP/1.1\r\n";
		 print $kageserver "Host: $kageaddr\r\n\r\n";
		 #Get redirection info.
		 local $/="\r\n";
		 while(<$kageserver>){
		     chomp;
		     next unless m|^location:\s+http://([a-z0-9.:]+)/|i;
		     $location=$1;
		 }
		 close($kageserver);
		 print STDERR "Connecting $location...\n";
		 if($location
		    and $kageserver=IO::Socket::INET->new($location)){
		     print $kageserver "GET /$request.svg HTTP/1.1\r\n";
		     print $kageserver "Host: $location\r\n\r\n";
		     local $/; $svg=<$kageserver>;
		     close($kageserver);
		     $svg =~ s/\r//gm; # remove CR.
		     $svg =~ s/^.+\n\n//ms; # remove HTTP header.
		 }else{
		     $svg="error";
		 }
	     }else{
		 print STDERR "Cannot connect to KAGE server at $kageaddr.\n";
		 $svg="error";
	     }
	     if($charstring = svg2charstring($svg)){
		 if(defined $db && $db->db_put($request, $svg)==0){
		     # If glyph request is successful, then store it to DB.
		     print STDERR "Glyph for $request cached.\n";
		 }
	     }else{
		 # If glyph request failed, then print a black box.
		 # Do not store glyph to DB.
		 print STDERR "Glyph request for $request failed.\n";
		 $charstring = $blackbox;
	     }
	 }
	 $charstrings.= "/$char $charstring";
	 $encoding.= "dup $charnum/$char put\n";
	 $charnum++;
     }
    return ($charstrings, $encoding, $charnum);
}

##############
#### main ####
##############

# Read ids data generated by inCHISE
my $idsdata="$omegadb_path/idsdata.pl";
my ($font_start, $ids_start, %ids);
if(-e $idsdata){
    # "require" doesn't work well.
    # I don't know why...
    open (my $data, "<$idsdata");
    while(<$data>){
	eval $_;
    }
    close($data);
}else{
    die "Cannot read $idsdata\n";
}

# Create (a nested) list of requests.
# $Request[font-number][char-code]='uhhhh...'
my @Requests;
foreach my $key (keys %ids){
    my $code="";
    my @elements=();
    foreach my $elem (split(//,$key)){
	$elem=unpack('U', $elem);
	if($elem < 0x10000){ # BMP
	    $code.=sprintf("u%04x", $elem);
	}elsif($elem < 0x110000){ # needs surrogate pair
	    my $high_surrogate=($elem-0x10000) / 0x400 + 0xd800;
	    my $low_surrogate=($elem-0x10000) % 0x400 + 0xdc00;
	    $code.=sprintf("u%04xu%04x",
			   $high_surrogate, $low_surrogate);
	}else{ #out of range.
	    $code="uffff"; # this generates KAGE server error.
	    last;
	}
    }
    $Requests[$ids{$key}[0]]->[$ids{$key}[1]]=$code;
}

# Create fonts.
foreach my $fontnum (0 .. $#Requests){
    my @faces=(['Mincho', 'min', 'mincho'],
	       ['Gothic', 'got', 'gothic']
	       );
    foreach my $i (0 .. 1){
	my $fontname=sprintf("Chise%s%03d", $faces[$i][0], $fontnum);
	my $pfbname=sprintf("chisesub%03d%s.pfb", $fontnum, $faces[$i][1]);
	my $suffix=$faces[$i][2]; # .mincho or .gothic
	# Unique ID:
	# mincho= 430000...,  gothic 440000...
	my $unique_id=430000+$fontnum+$i*10000;

	my($charstrings, $encoding, $charnum)=
	    makefont($Requests[$fontnum], $suffix);
	
	$encoding = sprintf("/Encoding %d array\n%sreadonly def",
			    $charnum, $encoding);

	my $font =
	    printheader($fontname, # FontName
			$fontname, # FullName
			'Chise',   # FamilyName
			'Medium',  # Weight
			'001.001', # version (whatever)
			$unique_id, # UniqueID (should be >= 4000000)
			$charnum+1, # Number of chars (.notdef included)
			$encoding   # Encoding vector
			) . $charstrings . printfooter();
	# Convert font to PFB
	open(my $asm, '|-', "$t1asm -b -o $pfbname");
	print $asm $font;
	close($asm);
	# Clean up PFB
	system("$pfaedit -script $cleanup_script $pfbname");
    }
}

# Close Database
undef $db;
