#!/bin/perl
#require 5.008;
my $THIS = "z80jis2sjis.pl";
my $VERSION = "0.01"; # 2010-05-25

## http://jrf.cocolog-nifty.com/archive/z80jis2sjis-20100525.pl

use utf8;
use strict;
use warnings;

use CPU::Z80::Assembler q(z80asm);
## エミュレータのドキュメントは CPU::Emulator::Z80::Manual にもある。
use CPU::Emulator::Z80;
use Encode q(find_encoding);

## 出力は UTF8。
binmode(STDOUT, ':utf8');

## アセンブル結果を表示し、アセンブルのエラー等をわかりやすくする。
$CPU::Z80::Assembler::verbose = 1;
#$CPU::Z80::Assembler::fill_byte = 0xFF;

## ORG は今回はいらないけど、おまじないとして付けてる。
my $_z80jis2sjis = z80asm(<<'EOA');
    ORG 0x0000
    LD A, H
    SUB 0x21
    SCF
    RRA
    LD H, A
    LD A, 0x1F
    JR NC, L1
    LD A, 0x7D
  L1:
    ADD A, L
    CP 0x7F
    JR C, L2
    INC A
  L2:
    LD L, A
    LD A, H
    INC A
    CP 0xA0
    JR C, L3
    ADD A, 0x40
  L3:
    LD H, A
    STOP
EOA

my $_z80jis2sjis_daa = z80asm(<<'EOA');
    ORG 0x0000
    LD A, H
    SUB 0x21
    SCF
    RRA
    LD H, A
    LD A, 0
    CCF
    RLA
    DEC A
    AND 0x5E
    ADD A, 0x1F
    ADD A, L
    CP 0x7F
    CCF
    ADC A, 0
    LD L, A
    INC H
    LD A, H
    AND 0xF0
    DAA
    RRA
    RRCA
    AND 0x40
    ADD A, H
    LD H, A
    STOP
EOA

my $_z80jis2sjis_nojump = z80asm(<<'EOA');
    ORG 0x0000
    LD A, H
    SUB 0x21
    SCF
    RRA
    LD H, A
    LD A, 0
    CCF
    RLA
    DEC A
    AND 0x5E
    ADD A, 0x1F
    ADD A, L
    CP 0x7F
    CCF
    ADC A, 0
    LD L, A
    INC H
    LD A, H
    CP 0xA0
    LD A, 0
    CCF
    RRA
    RRCA
    ADD A, H
    LD H, A
    STOP
EOA

my $_z80jis2sjis_sample = z80asm(<<'EOA');
    ORG 0x0000
    LD BC, 0x217E
    ADD HL, BC
    LD A, H
    XOR 0x40
    SCF
    RRA
    LD H, A
    JR C, DONE
    LD A, L
    SUB 0xDE
    SBC A, 0x80
    LD L, A
DONE:
    STOP
EOA

my $_z80jis2sjis_sample2 = z80asm(<<'EOA');
    ORG 0x0000
    LD BC, 0x217E
    ADD HL, BC
    LD A, H
    XOR 0x40
    SCF
    RRA
    LD H, A
    LD A, 0
    RLA
    DEC A
    LD B, A
    LD A, L
    SUB 0xDE
    SBC A, 0x80
    AND B
    LD C, A
    LD A, B
    XOR 0xFF
    AND L
    ADD A, C
    LD L, A
    STOP
EOA

my $_z80jis2sjis_sample3 = z80asm(<<'EOA');
    ORG 0x0000
    LD A, H
    ADD A, 0x21
    XOR 0x40
    SCF
    RRA
    LD H, A
    LD A, 0
    CCF
    RLA
    DEC A
    AND 0x5E
    ADD A, 0x1F
    ADD A, L
    CP 0x7F
    CCF
    ADC A, 0
    LD L, A
    STOP
EOA


sub z80jis2sjis {
  my ($h, $l, $code) = @_;
  $code = $_z80jis2sjis if ! defined $code;

  ## init_H はない。init_HL だけがある。
  my $cpu = CPU::Emulator::Z80->new(memory => $code, 
				    init_PC => 0x0000, 
				    init_HL => $h * 0x100 + $l);
  $cpu->run();
#  print $cpu->format_registers();
  return ($cpu->register('H')->get(), $cpu->register('L')->get());
}


sub hexdump {
  my ($s) = @_;
  return join("", map  {sprintf("%02X", $_)} (unpack("C*", $s)));
}

MAIN: {
  my $jisenc = find_encoding('JIS');
  my $sjisenc = find_encoding('cp932');
  my $utf8 = "あいうえお。Ｚ８０なんて网全々覚えてねぇ！奸÷";
#  my $utf8 = "あ";
#  my $utf8 = "Ｚ"; ## 「あ」がうまくいっても「Ｚ」がうまくいくとは限らない。
#  my $utf8 = "÷"; ## DAA の前に下位 4bit をやはり削らねばならない。
#  my $utf8 = "奸"; ## INC H の位置に関してバグがあった。
  my $jis = $jisenc->encode($utf8);
  my $sjis = $sjisenc->encode($utf8);
  $jis =~ s/\x1B\x24\x42//g;
  $jis =~ s/\x1B\x28\x42//g;
  my @input;
  my $r;

  print "jis =" . hexdump($jis) . "\n";
  print "sjis=" . hexdump($sjis) . "\n";

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis));
  }
  print "r1  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_daa));
  }
  print "r2  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_nojump));
  }
  print "r3  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_sample));
  }
  print "r4  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_sample2));
  }
  print "r5  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  @input = unpack("C*", $jis);
  $r  = "";
  while (my ($h, $l) = splice(@input, 0, 2)) {
    $r = $r . pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_sample3));
  }
  print "r6  =" . hexdump($r) . "\n";
  if ($sjis eq $r) {
    print "Success!\n";
  } else {
    print "Error!\n";
  }

  printf("length(jis2sjis) = %d\n", length($_z80jis2sjis));
  printf("length(daa) = %d\n", length($_z80jis2sjis_daa));
  printf("length(nojump) = %d\n", length($_z80jis2sjis_nojump));
  printf("length(sample) = %d\n", length($_z80jis2sjis_sample));
  printf("length(sample2) = %d\n", length($_z80jis2sjis_sample2));
  printf("length(sample3) = %d\n", length($_z80jis2sjis_sample3));

#  exit(0);

  ## 次のループはなぜかいきなり止まる！メモリ関係？
  ## なお、jis->utf8->sjis では、記号などでちゃんと対応してないものがある。
 LOOP: for (my $h = 0x21; $h <= 0x7E; $h++) {
# LOOP: for (my $h = 0x43; $h <= 0x7E; $h++) {
# LOOP: for (my $h = 0x5D; $h <= 0x7E; $h++) {
    my $succ = 0;
    for (my $l = 0x21; $l <= 0x7E; $l++) {
      my $utf8 = $jisenc->decode("\x1B\x24\x42" . pack("C*", $h, $l)
				 . "\x1B\x28\x42");
      next if ($utf8 eq "\uFFFD");
      my $sjis = $sjisenc->encode($utf8);
      my ($sh, $sl) = unpack("C*", $sjis);
      next if length($sjis) != 2 || $sh >= 0xf0;
      my $r1 = pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis));
      my $r2 = pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_daa));
      my $r3 = pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_nojump));
      my $r4 = pack("C*", z80jis2sjis($h, $l, $_z80jis2sjis_sample));
      if (! ($sjis eq $r1 && $sjis eq $r2 && $sjis eq $r3 && $sjis eq $r4)) {
	print "char= " . $utf8 . "\n";
	print "jis = " . hexdump(pack("C*", $h, $l)) . "\n";
	print "sjis= " . hexdump($sjis) . "\n";
	print "r1  = " . hexdump($r1) . "\n";
	print "r2  = " . hexdump($r2) . "\n";
	print "r3  = " . hexdump($r3) . "\n";
	print "r4  = " . hexdump($r4) . "\n";
#	last LOOP;
      }
      $succ++;
    }
    printf("0x%02X - %d\n", $h, $succ);
  }
}