#!/usr/bin/perl -w
#
# pedant - a simple Japanese composition checker
#
# Copyright (C) 1998-1999 Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>
#     All rights reserved.
#     This is free software with ABSOLUTELY NO WARRANTY.
#
# You can redistribute it and/or modify it under the terms of 
# the GNU General Public License version 2.
#
#  This file must be encoded in EUC-JP encoding
#
# ChangeLog:
#
#  v0.1.3 [01/02/1998]
#    * Added a feature to check frequently misused words
#      - [Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>] - code
#    * Fixed subtle bugs
#      - [kaneoka@pic.melco.co.jp] - report
#  v0.1.2 [12/23/1998]
#    * Fixed subtle bugs
#      - [Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>] - code
#  v0.1.1 [12/23/1998]
#    * Added the HTML paragraph recognition feature 
#      - [yano@moon.email.ne.jp (YANO Keisuke)] - idea
#    * Added the ignoring headers (not HTML) feature
#      - [Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>] - code
#    * Added the ignoring items (not HTML) feature
#      - [Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>] - code
#
#  v0.1.0 [12/16/1998]
#    * First version was made
#      - [Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>] - code
#

require 5.005;
  $^W = 0; # turn the warning switch off 
    require "jcode.pl";
  $^W = 1; # turn the warning switch on
use strict;
use IO::File;
use Getopt::Long;
my $VERSION      = "0.1.3";
my $CHAR         = "(?:[\x21-\x7e]|[\xa1-\xfe][\xa1-\xfe])";
my $NONKANJI     = "(?:[\x21-\x7e]|[\xa1-\xaf][\xa1-\xfe])";
my $KIGOU        = "(?:[\xa1\xa2\xa6-\xa8][\xa1-\xfe])";
my $ALNUM        = "(?:\xa3[\xa1-\xfe])";
my $CHOON        = "(?:[\xa1][\xbc]|[\xa1][\xc1])";  # ー, 〜
my $NAKAGURO     = "(?:[\xa1][\xa6])";  # ・
my $TOUTEN       = "(?:[\xa1][\xa2])";    # 、
my $KUTEN        = "(?:[\xa1][\xa3])";    # 。
my $HIRAGANA     = "(?:(?:[\xa4][\xa1-\xf3])|$CHOON)";
my $KATAKANA     = "(?:(?:[\xa5][\xa1-\xf6])|$CHOON)";
my $KANJI        = "(?:[\xb0-\xfe][\xa1-\xfe]|\xa1\xb9)";
my $SYMBOL       = "(?:[\x21-\x2f\x3a-\x40\x5b-\x60\x7b-\x7e])";
my $ASCII        = "(?:[\0x21-\x7e])";
my $OptHtml      = 0;
my $OptMail      = 0;
my $OptAscii     = 0;
my $OptParagraph = 0;
my $OptHeading   = 0;
my $OptItems     = 0;
my $OptMisuse    = 0;
my $OptStatistics= 1;
my $Debug        = 0;
my %FMW          = ();  # a hash to squirrel frequently misused words
my $FMW_REGEX    = "";

STDOUT->autoflush(1);
main();

sub dprint (@) {
    print STDERR @_ if $Debug;
} 

sub main() {
    my %info;
    init_info(\%info);
    parse_commandline();
    ignore_headers() if $OptMail;
    initialize_frequently_miused_words_list() if $OptMisuse;

  LOOP1:
    while (1) {
	for my $p (read_paragraph()) {
	    last LOOP1 unless defined $p;
	    dprint "((\n$p\n))\n\n";
	    check_fmw($p) if $OptMisuse;
	    analyze($p, \%info);
	}
    }
    show_result(\%info) if $OptStatistics && !$OptMisuse;
}

sub check_fmw ($) {
    my ($p) = @_;

    while ($p =~ /(?:$CHAR)*?($FMW_REGEX)/go) {
	print "$FMW{$1}{judge}: $1 → $FMW{$1}{correct}  $FMW{$1}{comment}\n";
    }
}

sub ignore_headers () {
    do {
	$_ = <>;
    } while ($_ !~ /^$/);
}

sub parse_commandline () {
    my $touten;
    my $kuten;
    my $version;
    my $help;

    return unless @ARGV > 0;  # no option are given
    Getopt::Long::Configure('bundling');
    GetOptions('x|html'       => \$OptHtml,
	       's|statistics' => \$OptStatistics,
	       'm|mail'       => \$OptMail,
	       'p|paragraph'  => \$OptParagraph,
	       'a|asciiart'   => \$OptAscii,
	       'e|heading'    => \$OptHeading,
	       'i|items'      => \$OptItems,
	       't|touten=s'   => \$touten,
	       'k|kuten=s'    => \$kuten,
	       'd|debug'      => \$Debug,
	       'v|version'    => \$version,
	       'h|help'       => \$help,
	       'u|misuse'     => \$OptMisuse,
	       );
    $TOUTEN = "(?:\Q$touten\E)" if defined $touten;
    $KUTEN  = "(?:\Q$kuten\E)"  if defined $kuten;
    if ($version) {
	print "pedant version $VERSION\n" ;
	exit 0;
    } elsif ($help) {
	show_usage();
	exit 0;
    }
}

sub show_usage () {
    print STDERR <<EOM;
pedant v$VERSION - a simple Japanese composition checker
Usage: pedant [options] [files]
 Mode:
   -s, --statistics    文字の使用率,文の長さなどの統計をとる - default
   -u, --misuse        間違いやすい言葉の誤用をチェックする
   -v, --version       ヴァージョンを表示する
   -h, --help          このヘルプを出力

 Options:
   -x, --html          HTML文書をそれなりに扱う
   -m, --mail          Mail/News のファイルをそれなりに扱う
   -a, --asciiart      絵文字を無視する
   -p, --paragraph     HTMLの段落を認識する - <P>要素
   -e, --heading       見出しを無視する
   -i, --items         箇条書きを無視する - ([*o+-]|\\d\\.) ではじまる行
   -t, --touten=TOTEN  読点を指定する [、]
   -k, --kuten=KUTEN   句点を指定する [。]
   -d, --debug         デバッグ情報を出力する

EOM

}

sub init_info (\%) {
    my ($info) = @_;

    $info->{cfreq} = {};  # Hash  to squirrel character frequencies
    $info->{sleng} = [];  # Array to squirrel sentence lengths
    $info->{pleng} = [];  # Array to squirrel paragraph lengths
    $info->{tleng} = 0;   # Total length
}

sub analyze ($\%) {
    my ($p, $info) = @_;

    return if $p =~ /^\s*$/;  # an empty paragraph

    my $sleng = 0;
    my $pleng = 0;

    while ($p =~ 
	   /
	   (
	    ([a-zA-Z]+)|      # 2
	    ([0-9])+|         # 3
	    ($KANJI+)|        # 4
	    ($HIRAGANA+)|     # 5
	    ($KATAKANA+)|     # 6
	    ($ALNUM+)|        # 7  (so-called Zenkaku Alnums)
	    ($TOUTEN+)|       # 8
	    ($KUTEN+)|        # 9
	    ($KIGOU+)|        # 10 (so-called Zenkaku Kigou)
	    ($SYMBOL+)|       # 11 (ASCII symbols)
	    (\S+)|            # 12 (unkown characters)
	    (\n+)|            # 13 (line feeds)
	    (\s+)             # 14 (white spaces)
	    )
	   /ogsx)
    {
	my $sflag = 0; # sentence flag
	my $leng = length($1);
	$leng /= 2 if is_wbyte($1);
	$leng  = 0 if is_space($1);
	$info->{tleng} += $leng;
	$pleng += $leng;

	if      (defined($2)) {
	    $info->{cfreq}->{"英文字"} += $leng;
	} elsif (defined($3)) {
	    $info->{cfreq}->{"数字"} += $leng;
	} elsif (defined($4)) {
	    $info->{cfreq}->{"漢字"} += $leng;
	} elsif (defined($5)) {
	    $info->{cfreq}->{"ひらがな"} += $leng;
	} elsif (defined($6)) {
	    $info->{cfreq}->{"カタカナ"} += $leng;
	} elsif (defined($7)) {
	    $info->{cfreq}->{"X0208英数"} += $leng;
	} elsif (defined($8)) {
	    $info->{cfreq}->{"読点"} += $leng;
	} elsif (defined($9)) {
	    $info->{cfreq}->{"句点"} += $leng;
	    $sflag = 1;
	} elsif (defined($10)) {
	    $info->{cfreq}->{"X0208記号"} += $leng;
	} elsif (defined($11)) {
	    $info->{cfreq}->{"ASCII記号"} += $leng;
	} elsif (defined($12)) {
	    $info->{cfreq}->{"不明"} += $leng;
	} elsif (defined($13)) {
	    $sflag = 1;
	} elsif (defined($14)) {
	    # $info->{cfreq}->{"空白"} += $leng;
	}

	if ($sflag) {
	    push(@{$info->{sleng}}, $sleng) if $sleng > 0;
	    $sleng = 0;
	} else {
	    $sleng += $leng;
	}
    }
    push(@{$info->{sleng}}, $sleng) if $sleng > 0;
    push(@{$info->{pleng}}, $pleng);

}

sub is_wbyte ($) {
    $_[0] =~ /^[\xa1-\xfe]/;
}

sub is_space ($) {
    $_[0] =~ /^\s/;
}

sub show_result (\%) {
    my ($info) = @_;
    print "文字種別使用頻度\n";
    for my $key (sort {$info->{cfreq}->{$b} <=> $info->{cfreq}->{$a}} 
		 keys %{$info->{cfreq}}) 
    {
	printf "  * %-10s: %-8s 文字 (%5.2f %%)\n", 
	$key, commas($info->{cfreq}->{$key}), 
	$info->{cfreq}->{$key} / $info->{tleng} * 100;
    }
    printf "  * %-10s: %-8s 文字\n", "総計", commas($info->{tleng});
    print "\n";
    show_sub_result("文に関する情報", $info->{sleng});
    show_sub_result("段落に関する情報", $info->{pleng});
}

sub show_sub_result ($\@) {
    my ($name, $rarray) = @_;
    my $sum = 0;
    my $max = 0;
    my $n = @{$rarray};
    print $name, "\n";
    for my $val (@{$rarray}) {
	$max = $val if $val > $max;
	$sum += $val;
    }
    my $average = $sum / @{$rarray};
    printf "  * %-10s: %-8s 個\n",     "総計",  commas($n);
    printf "  * %-10s: %-8s 文字\n",   "最大長", commas($max);
    printf "  * %-10s: %-8s 文字\n",   "平均長", commas(int($average));
    print "\n";
}


# from Mastering Regular Expressions
sub commas ($) {
    my ($num) = @_;

    $num = "0" if ($num eq "");
#    1 while $num =~ s/(.*\d)(\d\d\d)/$1,$2/;
    $num =~ s<\G((?:^-)?\d{1,3})(?=(?:\d\d\d)+(?!\d))><$1,>g;
    $num;
}

sub read_paragraph () {
    my $p = "";  # contain logical paragraph chunk
    my @terminator = ();  # contain an additional undef

    do {
	while (1) {
	    my $line = read_line();
	    unless (defined $line) {
		push(@terminator, undef);
		last;
	    }
	    last if $line =~ /^$/;  # an empty line

	    if (($p =~ /[\xa1-\xfe]$/) && ($line =~ /^[\xa1-\xfe]/)) {
		$p =~ s/\n$//;  # connect directly
	    } 
	    $p .= $line;
	}
    } while ($p eq "" && !@terminator);

    return split_chunk($p), @terminator;
}

sub split_chunk ($) {
    my ($p) = @_;

    if (!defined $p) {
	return undef;
    } else {
	do_html_processing($p) if $OptHtml;
	my @tmp;
	for my $tmp (split(/\n\n+/, $p)) {
	    if ($OptHeading && $tmp =~ /^[^\n]+$/ && 
		$tmp !~ /$TOUTEN|$KUTEN/) 
	    {
		# a heading
		dprint "%%HEADER DETECTED%%\n%%$tmp\n\n";
		next;
	    }
	    adjust_whitespaces(\$tmp);
	    do_asciiart_processing(\$tmp) if $OptAscii;
	    next if $tmp =~ /^\s*$/;  # an empty paragraph
	    push(@tmp, $tmp);
	}
	return @tmp;
    }
}

sub do_asciiart_processing ($) {
    my ($p) = @_;

    # determine whether this is a ascii art, and if this is, erase this!
    # Rule: if $p contains 20% or more symbols, it must be a ascii art.
    my $n = $$p =~ tr/+\-|<>*\/\\^=~#:;_/+\-|<>*\/\\^=~#:;_/;
    if (($n / length($$p) * 100) >= 20) {
	dprint "{{ASCII ART DETECTED\n $$p}}\n\n";
	$$p = "" ;
    }
}

sub do_html_processing ($) {
    my ($p) = @_;

    # following regexes can not perfectly parse an html but almost works
    if ($OptParagraph) {  # only <P> elements are allowed
	my $tmp = "";
	$$p =~ s!<P(?:\s+[^>]*)?>(.*?)</P>!$tmp .= $1 . "\n\n"!iges;
	$$p = $tmp;
    }
    $$p =~ s/<[^>]*>//g;  # remove all html elements
    decode_entity($p);
}

sub read_line () {
    my $line = <>;
    return undef unless defined $line;

    codeconv(\$line);
    adjust_whitespaces(\$line);

    if ($OptMail) {
	if ($line =~ /^begin \d\d\d/) {  # uuencode begins
	    dprint "##UUENCODE LINE DETECTED##\n##$line\n\n";
	    1 while(<>);  # ignore all remains of line
	    return undef;
	}
	# skip a cited or comment line
	if ($line =~ /^(.{0,10}>|[\>\|\:\#])/) {
	    dprint "==ITED OR COMMENT LINE DETECTED==\n==$line\n\n";
	    $line = ""   ;
	}
    }
    if ($OptItems && $line =~ /^([*o+-]|\d\.)/) {
	dprint "!!ITEM LINE DETECTED!!\n!!$line\n\n";
	$line = "";
    }
    $line .= "\n";

    return $line;
}

sub adjust_whitespaces ($) {
    my ($str) = @_;

    # convert control characters into spaces
    $$str =~ tr/\x00-\x09\x0b-\x1f\xff/   /;

    $$str =~ s/[\r\n]+/\n/g;
    $$str =~ s/^ +//;
    $$str =~ s/ +$//;
    $$str =~ s/[ \t]+/ /g;
    $$str =~ s/^\n+//g;
    $$str =~ s/\n+$//g;
}

sub decode_entity ($) {
    my ($str) = @_;

    return unless defined($$str);

    $$str =~ s/&#(\d{2,3})[;\s]/decode_numbered_entity($1)/ge;
    $$str =~ s/&quot[;\s]/\"/g;
    $$str =~ s/&amp[;\s]/&/g;
    $$str =~ s/&lt[;\s]/</g;
    $$str =~ s/&gt[;\s]/>/g;
    $$str =~ s/&nbsp/ /g;
}

# only #0-127 are supported
sub decode_numbered_entity ($) {
    my ($num) = @_;
    return ""
	if $num >= 0 && $num <= 8 ||  $num >= 11 && $num <= 31 || $num >=127;
    sprintf ("%c",$num);
}

sub codeconv ($) {
    my ($line) = @_;

    $^W = 0;  # turn the warning switch off
      jcode::convert($line,'euc');
    $^W = 1;  # turn the warning switch on
}

sub initialize_frequently_miused_words_list () {
    my $tmp = <<'EOM';
## 間違いやすい言葉の表
## 誤用, 正しい用法, 判定 (あきらかな間違いは×, 要注意は△), 注釈
的を得る	的を射る	×
汚名挽回	汚名返上/名誉挽回	×
デヴュー	デビュー	×
役不足	力不足	△
いじましい	いじらしい	△
ディスクトップ	デスクトップ	×

## 日下部さんの	Webペイジより
内臓	内蔵	△
とうり	とおり	×
話し	話	△
意志表示	意思表示	×
こじんまり	こぢんまり	×
まじか	まぢか	×
しずらい	しづらい	×
ひずけ	ひづけ	×
シュミレート	シミュレート	×
コミニュケーション	コミュニケーション	×
# 例え〜であっても	たとえ〜であっても	×

## ===  間違えやすい会社名  ===
## From: nakagosi@d1.dion.ne.jp (Haruki Nakagoshi)
## Newsgroups: fj.rec.misc
## Subject: Re: Company Name
## Date: Mon, 28 Dec 1998 09:32:40 JST
## Message-ID: <wk7lvdayxj.fsf@KLIPPER.d1.dion.ne.jp>
## より
インテル・ジャパン	インテル	×	(社名)
キャノン	キヤノン	×	(社名)
Cannon	Canon	×	(社名)
キューピー	キユーピー	×	(社名)
# 近畿日本「金矢」道(鉄のつくりが矢)	近畿日本鉄道	×	(社名)
近鉄バッファローズ	近鉄バファローズ	×	(社名)
暮しの手帳	暮しの手帖社	×	(社名)
# (「サクマ式 ドロップス」を製造販売)	佐久間製菓
# (「サクマ ドロップス」を売っている)	サクマ製菓
さんしょうどう	さんせいどう	×	(三省堂)(社名)
シャチハタ	シヤチハタ	×	(社名)
スクゥエア	スクウェア	×	(社名)
スクエア	スクウェア	×	(社名)
スクェア	スクウェア	×	(社名)
SONY Corporation	Sony Corporation	×	(社名)
Dr.Pepper	Dr Pepper	×	(社名)
ニッセキハウス工業	ニツセキハウス工業	×	(社名)
にほんでんき	にっぽんでんき	×	(日本電気), (社名)
ニッポン放送	ニツポン放送	×	(社名)
阪神タイガーズ	阪神タイガース	×	(社名)
ビッグカメラ	ビックカメラ	×	(社名)
BIG CAMERA	BIC CAMERA	×	(社名)
富士フィルム	富士写真フイルム	×	(社名)
ブリジストン	ブリヂストン	×	(社名)
ブルドッグソース	ブルドックソース	×	(社名)
文化シャッター	文化シヤッター	×	(社名)
松下電気産業	松下電器産業	×	(社名)
松下電機	松下電器産業	×	(社名)
# 本来は
#   土
#   口 野 家 ディー・アンド・シー      吉野屋
# だそうだ
吉野屋	吉野家	×	(社名)
RICHO	RICOH	×	(社名)

## ===  番外編(商品名・名称など)  ===
ザ・タイガース	ザ・タイガーズ	×	(ジュリーがいた)
WOWWOW	WOWOW	×
SKY PerfectTV!	SKY PerfecTV!	×
Sky Perfec TV	SKY PerfecTV!	×
スカイパーフェクトティービー	スカイパーフェクＴＶ！	×
DirecTV	DIRECTV	×
ビジネスショー	ビジネスシヨウ	×
ビジネスショウ	ビジネスシヨウ	×
バャリース	バヤリース	×	(ジュースの名前)
レガシー	レガシィ	×	(車の名前)
ゼクシー	ゼクシィ	×	(結婚情報誌)
レッツゴー三匹	レツゴー三匹	×
PC-98 シリーズ	PC-9800 シリーズ	×
PC-98NX	PC98-NX	×	(NECのPC)
BeOs	BeOS	×
Be-OS	BeOS	×
EOM

    my (@lines) = split('\n+', $tmp);
    for my $line (@lines) {
	next if $line =~ /^#/;  # comment line
	my (@items) = split('\t', $line);
	if (@items < 3) {
	    dprint "WARNING: Invalid line: $line\n";
	    next;
	}
	my $misuse  = $items[0];
	my $correct = $items[1];
	my $judge   = $items[2];
	my $comment = defined $items[3] ? $items[3] : "";
	$FMW{$misuse}          = {};
	$FMW{$misuse}{correct} = $correct;
	$FMW{$misuse}{judge}   = $judge;
	$FMW{$misuse}{comment} = $comment;
    }
    $FMW_REGEX = join('|', 
		      map {s/([^\w\xa1-\xfe])/\\$1/g;$_} # instead of quotemeta
		      sort {length($b) <=> length($a)} keys %FMW);
    dprint "FMW_REGEX: ", $FMW_REGEX, "\n";
}