#!/usr/bin/perl 
use 5.014 ; use warnings ; 
use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Encode qw[ decode_utf8 encode_utf8 ] ; 
use Getopt::Std ; getopts '=0:R:e:i:u:y:' , \my %o  ; 
use Term::ANSIColor qw[ color :constants ] ; $Term::ANSIColor::AUTORESET = 1 ;
use FindBin qw[ $Script ] ; 
use autodie qw [ open ] ;
use List::Util qw[ max ] ; 
use Scalar::Util qw [ dualvar ]  ; 

* d3 = exists $o{','} && $o{','} eq 0 ? sub{$_[0]} : sub { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
my $time0 = time ; 
my $help = 0  ; # オンラインヘルプの文面の表示をしたか否か。
my $readLines  ; # 読み取った行数
my $sec = $o{'@'} // 15 ; # 何秒おきにアラームを発生させるか
our @y_ranges ; 
& y_init () ; 

* R0proc = exists $o{R} && $o{R} eq 0 ? sub {} : sub { s/\r$// } ; 
* decode = ($o{u}//'') ne 0 ? * decode_utf8 : sub ( $ ) { $_[0] } ; 
$o{0} //= '-' ; # 行列状の出力で 値が 0 の場合に出力する文字
my $isep = $o{i} // "\t" ;  # 入力の区切り文字
$o{e} = decode ( $o{e} ) if exists $o{e} ;
* len = ! exists $o{e} ? sub ( $ ) { length $_[0]  } : sub ($) { my @c = $_[0] =~ m/$o{e}/g ; scalar @c } ;

my @cn =  & colnames if $o{'='} ;  # Column Names の頭文字
my @Cij  ; # $Cij[列番]{桁数} により、0始まり何番の列に、何桁のものが、何件あったかを示す。
my %Cj  ; # $Cj{ 桁数} > 0 により、その桁数のものが存在したことを示す。digit length のつもり。
my @E1  ; # $E1[$i] = [入力$i列目(出力$i行目)の最も右のjの値(位置) , 入力での出現値 , その位置と出現値の頻度 ] 。
my @E2  ; # [位置, 出現値, 頻度]  ; $E2[$j] で $E1[$j] に準じるものになる。 形式は同様。

while( <> ) { 
  chomp ; & R0proc ; 
  my @F = split /$isep/ , decode( $_ ) , -1 ; 
  for ( 0 .. $#F ) { 
    $Cij [ $_ ] { '' }  //= '' ; # 入力の列に対応する出力の行で、何も出力するものが無かった場合でも、全部を表示するためのトリック。
    my $j = len ( $F[$_] ) ; 
    next unless & y_filter ( $j ) ; # 桁数が範囲外なら読まない
    $Cij [ $_ ] { $j } ++ ; 
    $Cj { $j } ++  ;
    $E1[$_] = [ $j , $F[$_] , 0 ] if ( $E1[$_]->[0] // "-Inf" ) < $j ;  # ここでの $_ は列番号である。
    $E1[$_]->[2] ++ if $E1[$_]->[0] == $j && $E1[$_]->[1] eq $F[$_] ; 
    $E2[$_] = [ $j , $F[$_] , 0 ] if ( $E2[$_]->[0] // "-Inf" ) < $j && $F[$_] ne $E1[$_]->[1] ; # && $E1[$_]->[0] == $j ;  
    $E2[$_]->[2] ++ if exists $E2[$_]->[1] && $E2[$_]->[1] eq $F[$_] ;     
  }
} 

# 出力; 
binmode STDOUT, "utf8" if ($o{u}//'') ne 0 ; 
my @Cj = sort { $a <=> $b } keys %Cj ;
say join "\t" , map { UNDERLINE $_ } YELLOW ('col') , @Cj , map { "eg.$_". FAINT "(freq)" } 1..2 ;  
for my $i ( 0 .. $#Cij ) {
  my @out ; 
  push @out , YELLOW $cn [ $i ] // YELLOW $i + 1 ; 
  push @out , $Cij[ $i ] { $Cj[$_] } // $o{0} for 0 .. $#Cj ; 
  push @out , $E1[$i]->[1] . '' . FAINT "($E1[$i]->[2])" if exists $E1[$i] ;
  push @out , $E2[$i]->[1] . '' . FAINT "($E2[$i]->[2])" if exists $E2[$i] ;
  say join "\t" , @out ; 
}

$SIG{INT} = sub { exit } ;
$SIG{ALRM} = sub { 
  my $n = $.  =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr ; # 3桁ごとに区切る。
  say STDERR GREEN "$n lines read ($Script). " , scalar localtime ; 
  alarm $sec 
} ; 
alarm $sec ;

### ヘッダから列名を取得する。 -= が指定された場合のみ
sub colnames ( ) {  
  $_ = <> ; 
  $_ //= '' ; 
  & R0proc ; # <-- R0procで行末の\r対策。
  chomp $_ ; 
  decode ($_) ; 
  my @F = split /$isep/, decode ($_) , -1 ; 
} 

##
sub y_init ( ) { 
  my @ranges = split /,/o , $o{y} // '' , -1 ; 
  grep { $_ = $_ . ".." . $_ unless m/\.\./ }  @ranges ; # = split /,/ , $o{y} // '' , -1 ; 
  do { m/^(\d*)\.\.(\d*)/ ; push @y_ranges , [ $1||1 , $2||'Inf' ] } for @ranges ; 
}
sub y_filter ( $ ) { 
  do { return not 0 if $_->[0] <= $_[0] && $_[0] <= $_->[1] } for @y_ranges ; 
  return @y_ranges ? not 1 : not 0 ; # 指定が無かった場合はとにかく真を返す。
}

END {
  exit if $help ;
  my $procsec = sprintf "%.5f", tv_interval ${ dt_start } ; #time - $time0 ; # このプログラムの処理にかかった秒数。比較する2個の時刻は秒単位なので、±1秒未満の誤差は発生する。
  $readLines //= $. ; # Ctrl+Cの連打で必要となる処理。
  return if ($o{2}//'') eq 0 ; 
  my $linenumeral = $readLines > 1 ? 'lines' : 'line' ; 
  print STDERR BOLD FAINT ITALIC & d3 ( $readLines ) . " $linenumeral read" ; 
  my $s = tv_interval $dt_start , [ gettimeofday ] ; 
  say STDERR BOLD FAINT ITALIC " -- $Script ; " . $procsec . " sec. in process" ;
}

## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
  use FindBin qw[ $Script ] ; 
  $ARGV[1] //= '' ;
  open my $FH , '<' , $0 ;
  while(<$FH>){
    s/\$0/$Script/g ;
    print $_ if s/^=head1// .. s/^=cut// and $ARGV[1] =~ /^o(p(t(i(o(ns?)?)?)?)?)?$/i ? m/^\s+\-/ : 1;
  }
  close $FH ;
  exit 0 ;
}

=encoding utf8

=head1 $0 

TSV形式ファイルにおいて、各列に何桁の文字列が何件含まれていたかを一覧表示する。
出力の右側は、具体的な文字列の例を表す。その頻度は薄い文字で括弧内に表す。
その具体例の1番目は、最長の文字列であるが、オプションの-yで指定された場合、その範囲の長さに限定される。
2番目の例は、1番目とは異なるものを探す。できるだけ長い文字列を採用するようにアルゴリズムの設計は試みたが、そうなるとも限らない。

オプション : 

 -=     : 入力の1行目を、変数名の並びと見なすか。見なした場合、出力の1列目に、列番号の代わりに列名が並ぶ。
 -0 str : 頻度が0の場合に与える文字列
 -e RGX : 各セルの文字列長を測る代わりに、正規表現RGXをいくつ持っていたかを測るようにする。 -e '1' や -e '[0-9]$' や -e '大' を指定可能。
 -i str : 入力の区切り文字。未指定なら \t すなわちタブ文字。csvなら -i , のように与える。
 -u 0   : UTF-8 と通常見なすが、そうせず、バイナリのまま処理をする。
 -R 0   : 改行がWindows形式すなわち \r\n であっても、\nしか改行文字と見なさない。(何かこの特殊な用途を想定して実装した。)

 --help : このオンラインのヘルプ画面を出力する。 perldoc $0 や man $0 でも可能であろう。

開発メモ : 
  * 半角数値およびピリオドとプラスマイナスさらに半角空白の頻度表の機能を実装したい。
  * 平均と分散を算出する機能を入れたい(不偏分散の平方根とするか否か)
  * 先頭文字または末尾の文字についても一覧にしたい。


=cut
