#!/usr/bin/perl

use strict;
use vars qw($opt_in_cs $opt_order $opt_kage $opt_help $usage
	    $in_cs $out_cs $i @chars
	    @order $order %order
	    $char $char_id $out_char
	    $ids $ids_argc %ids $idsdb
	    $idsdata_file $ids_start $font_start
	    $perl56 $perl58
	    @CDP @HZK @GT
	    );
use Getopt::Long;
use utf8;
use Chise_utils ':all';

my $perl="/usr/bin/perl";
my $makefonts="/Users/izumi/.chise/makefonts.pl";
my $exec_makefonts=0;
my $geta=pack("S",8750|0x8080);

if($^V and $^V ge v5.8){
    $perl58=1;
}elsif($^V and $^V ge v5.6){
    $perl56=1;
}else{
    print STDERR "This versin is not supported.";
}
if($perl58){
    eval "use Encode";
    binmode(STDIN, ':encoding(utf8)');
    binmode(STDOUT, ':encoding(utf8)');
}

&GetOptions("in=s"=>\$opt_in_cs,
	    "order=s"=>\$opt_order,
	    "kage",\$opt_kage,
	    "help",\$opt_help);

$usage=<<EOF;
Usage: $0 [-i <input coding system>] [-o <order of kanji>] [-k] <filename>
    input coding system: (default: ucs\@mcs)
      ucs\@mcs, ucs\@cns, ucs\@gb, ucs\@jis, ucs\@ks
    order of kanji: (default: j)
       c: CNS
       g: GB
       j: JIS
       k: KS
       t: GT
       m: Multi, use \\UTFM of otf.sty
      You can also combine them, ex. jtcgkm
    k: use Kage server.
EOF

%order=('c'=>'UniCNS',
	'g'=>'UniGB',
	'j'=>'UniJIS',
	'k'=>'UniKS',
	't'=>'GT',
	'm'=>'Multi',
	);

if($opt_help){
    print STDERR $usage;
    exit 1;
}

if(not defined($opt_in_cs)){
    print STDERR "Assuming input coding system is ucs\@mcs.\n";
    $in_cs='ucs@mcs';
}else{
    if(($opt_in_cs eq 'ucs@mcs')or
       ($opt_in_cs eq 'ucs@cns')or
       ($opt_in_cs eq 'ucs@gb')or
       ($opt_in_cs eq 'ucs@jis')or
       ($opt_in_cs eq 'ucs@ks')){
	$in_cs=$opt_in_cs;
    }else{
	print STDERR "Invalid arguments.\n";
	print STDERR $usage;
	exit 1;
    }
}

if(not defined($opt_order)){
    print STDERR "Using only UniJIS.\n";
    $opt_order='j';
}

if(defined($opt_order)){
    if($opt_order=~/^[cgjktm]+$/){
	@order=split(//,$opt_order);
	@order=map {$order{$_}} @order;
    }else{
	print STDERR "Invalid option!\n";
	print $usage;
	exit 1;
    }
}

if($opt_kage){
    $exec_makefonts=1;
}

$idsdata_file="idsdata.pl";
$ids_start=0x00; 
$font_start=0;

if(-e $idsdata_file){
    require $idsdata_file;
}

$ids_argc=0;
$ids="";

@GT=(#"=gt","=gt-k",
     "=gt-pj-1","=gt-pj-2","=gt-pj-3","=gt-pj-4","=gt-pj-5",
     "=gt-pj-6","=gt-pj-7","=gt-pj-8","=gt-pj-9","=gt-pj-10",
     "=gt-pj-11"
     #,"=gt-pj-k1","=gt-pj-k2"
     );
@HZK=("=hanziku-1","=hanziku-10","=hanziku-11","=hanziku-12",
      "=hanziku-2","=hanziku-3","=hanziku-4","=hanziku-5",
      "=hanziku-6","=hanziku-7","=hanziku-8","=hanziku-9");
@CDP=("=big5-cdp");

while(<>){
    s/&(.*?);/&de_er($1)/ge;
    if($in_cs ne 'ucs@mcs'){
	s/(.)/pack("U",&get_char_id(unpack("U",$1),$in_cs))/ge;
    }
    @chars=split(//);
    for($i=0;$i<=$#chars;$i++){
	$char=$chars[$i];
	$char_id=unpack("U",$chars[$i]);

	if($char_id<=0x7f){
	    # Basic Latin
	    print $char;
	    next;
	}elsif($char_id>=0x2ff0 and $char_id<=0x2fff){
	    # Ideographic Description Characters
	    print &ids_parse();
	    next;
	}elsif($char_id >= 0x20000 && $char_id <=0x2a6df){
	    # CJK Unified Ideographs Extension B
	    if(not defined($ids{$char}) and $ids{$char}[1]>=0){
		$ids{$char}[0]=$font_start;
		$ids{$char}[1]=$ids_start;
		$ids_start++;
		if($ids_start>255){
		    $ids_start=0;
		    $font_start++;
		}
	    }
	    print "{\\fontencoding{OT1}\\fontfamily{" .
		sprintf("chise%03d",$ids{$char}[0]) .
		"}\\selectfont\\char$ids{$char}[1]}";
	    next;
	}else{
	    if(($out_char=&get_output_char($char_id))){
		print $out_char;
	    }else{
		print &get_macro_for_ids(&get_ids($char));
	    }
	}
    }
}

open(IDSDATA,">$idsdata_file") or die;
print IDSDATA 'use utf8;',"\n";
foreach $ids (keys %ids){
    print IDSDATA '$ids{\'',$ids,'\'}='
	,'[',join ",",@{$ids{$ids}},"];\n" if($perl56);
    print IDSDATA '$ids{\'',encode('utf8',$ids),'\'}='
	,'[',join ",",@{$ids{$ids}},"];\n" if($perl58);
}
print IDSDATA '$font_start=',$font_start,";\n";
print IDSDATA '$ids_start=',$ids_start,";\n";
print IDSDATA "1;";

if($exec_makefonts){
    if(-f $makefonts){
	system($perl,$makefonts) ==0
	    or die "Could not make fonts: $?";
    }else{
	print STDERR "cannot find $makefonts\n";
    }
}

exit 0;

sub ids_parse{
    # arguments: none
    # return: return character for output,
    #          TeX macro for ids,
    #          or GETA character if ids is invalid.
    my($ids,$ids_argc)=&ids_rest("",0,$chars[$i]);

    while($ids_argc>0){
	# We are in IDS.
	$i++;
	if($i>$#chars){
	    print STDERR "IDS parse error: $ids\n";
	    return $geta;
	}

	($ids,$ids_argc)=&ids_rest($ids,$ids_argc,$chars[$i]);
	if($ids_argc==0){
	    if(($char_id=&get_char_id_for_ids($ids))
	       and($out_char=&get_output_char($char_id))){
		return $out_char;
	    }else{
		return &get_macro_for_ids($ids) if($perl56);
		return encode('utf8', &get_macro_for_ids($ids)) if($perl58);
	    }
	}
    }
}

sub ids_rest{
    # arguments: <ids>, <rest number of arguments for ids>, <character>
    # return: ids and rest number of arguments for ids.
    my($ids,$ids_argc,$char)=@_;
    my($argc);
    $argc=&ids_argc($char);
    if($argc){
	$ids_argc+= $ids_argc==0 ? $argc : $argc-1;
    }else{
	$ids_argc--;
    }
    $ids.=$char if($perl56);
    $ids.=encode('utf8',$char) if($perl58);
    return ($ids,$ids_argc);
}

sub get_macro_for_ids{
    # argument: <ids>
    # return: TeX macro for ids
    #          or GETA character if ids is invalid for KAGE.
    my($ids)=@_;
#    return $geta if(not $exec_makefonts);
    $ids=&normalize_ids($ids,"UniJIS");
    return $geta if(($ids!~/[$idc]/)
		    or($ids=~/[\x{10000}-]/));
                    #irregular for KAGE.
    if(not defined($ids{$ids}) and $ids{$ids}[1]>=0){
	$ids{$ids}[0]=$font_start;
	$ids{$ids}[1]=$ids_start;
	$ids_start++;
    }
    if($ids_start>255){
	$ids_start=0;
	$font_start++;
    }
    return "{\\fontencoding{T1}\\fontfamily{"
	.sprintf("chisesub%03d",$ids{$ids}[0])
	."}\\selectfont\\char$ids{$ids}[1]}";
}

sub normalize_ids{
    # argument: <ids>, <output coding system>
    # return: ids or GETA character if ids is invalid for KAGE.
    my($ids,$out_cs)=@_;
    $ids = decode('utf8', $ids) if $perl58;
    $out_cs=~s/Uni(.+)/"ucs\@".lc($1)/e;

    my $output_ids="";
    my($char,$char_id,$output_char_id);
    while($ids=~m/(.)/g){
	$char=$1;
	$char_id=unpack("U",$char);
	if($char=~/[$idc]/){
	    $output_ids.=$char;
	}elsif($output_char_id=&get_char_attribute($char,"=$out_cs")){
	    $output_ids.=pack("U",$output_char_id);
	}elsif($output_char_id=&get_char_attribute($char,"=ucs")){
	    $output_ids.=pack("U",$output_char_id);
	}else{
	    return $geta;
	}
    }
    return $output_ids;
}

sub get_output_char{
    # argument: <char-id>
    # return: character in EUC-JP or TeX macro for pTeX.
    my($char_id)=@_;
    my($char,$out_char,$out_char_id,$gt);
    
    $char=pack('U',$char_id);

    if($out_char=&get_char_attribute($char,'=jis-x0208')){
	return pack("S",$out_char|0x8080);
    }else{
	foreach $out_cs (@order){
	    if($out_cs eq 'UniJIS'
	       and &get_char_attribute($char,"adobe-unijis-utf16-h")){
		if($out_char_id=&get_char_attribute($char,'=ucs@jis')
		   or $out_char_id=&get_char_attribute($char,'=ucs')){
		    return "\\UTF{".sprintf("%X",$out_char_id)."}";
		}
	    }elsif($out_cs eq 'UniGB'
		   and &get_char_attribute($char,"adobe-unigb-ucs2-h")){
		if($out_char_id=&get_char_attribute($char,'=ucs@gb')
		   or $out_char_id=&get_char_attribute($char,'=ucs')){
		    return "\\UTFC{".sprintf("%X",$out_char_id)."}";
		}
	    }elsif($out_cs eq 'UniCNS'
		   and &get_char_attribute($char,"adobe-unicns-ucs2-h")){
		if($out_char_id=&get_char_attribute($char,'=ucs@cns')
		   or $out_char_id=&get_char_attribute($char,'=ucs')){
		    return "\\UTFT{".sprintf("%X",$out_char_id)."}";
		}
	    }elsif($out_cs eq 'UniKS'
		   and &get_char_attribute($char,"adobe-uniks-ucs2-h")){
		if($out_char_id=&get_char_attribute($char,'=ucs@ks')
		   or $out_char_id=&get_char_attribute($char,'=ucs')){
		    return "\\UTFK{".sprintf("%X",$out_char_id)."}";
		}
	    }elsif($out_cs eq 'GT'){
		return $gt if($gt=&get_macro_for_GT($char_id));
	    }elsif($out_cs eq 'Multi'){
		if($out_char_id=&get_char_attribute($char,'=ucs')){
		    return "\\UTFM{".sprintf("%X",$out_char_id)."}";
		}
	    }
	}
    }
    return undef;
}

sub get_ids{
    # argument: <character>
    # return: ids
    my($char)=@_;
    my $ids="";
    $ids=&get_char_attribute($char,"ids-aggregated")
	or &get_char_attribute($char,"ids");
    $ids=decode('utf8', $ids) if($perl58);
    return $ids;
}

sub get_char_id_for_ids{
    # argument: <character>
    # return: char-id
    my($ids)=@_;
    my($output_char);
    $ids=decode('utf8', $ids) if($perl58);

    if(($output_char)=&get_chars_matching("ids",$ids)){
	return unpack("U",$output_char);
    }else{
	return undef;
    }
}

sub get_char_id{
    # argument: <char-id>, <input coding system>
    # return:   char-id.
    my($char_id,$in_cs)=@_;
    my($output_char);

    if(($output_char)=&get_chars_matching("=$in_cs",$char_id)){
	return unpack("U",$output_char);
    }else{
	return $char_id;
    }
}

sub get_macro_for_GT{
    # argument: <char-id>
    # return: TeX macro for GT fonts.
    my($char_id)=@_;
    my($char,$gt,$GT);
    $char=pack("U",$char_id);
    foreach (@GT){
	if($gt=&get_char_attribute($char,$_)){
	    m/gt\-pj\-(\d+)/ and $GT=$1;
	    last;
	}
    }
    if($gt){
	return "{\\fontfamily{"
	    .sprintf("gto%02d",$GT)
	    ."}\\selectfont\\char".($gt|0x8080)."}";
    }else{
	return undef;
    }
}