view release on metacpan or  search on metacpan

ctransition  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use warnings ; 
use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Getopt::Std ; getopts '~=@:0:2:l:q:' , \my %o  ; 
use Term::ANSIColor qw[ color :constants ] ; $Term::ANSIColor::AUTORESET = 1 ;
use FindBin qw[ $Script ] ; 
use Encode qw[ decode_utf8 encode_utf8 ] ; 

* d3 = exists $o{','} && $o{','} eq 0 ? sub{$_[0]} : sub { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
my $time0 = time ; 
my $help = 0  ; # オンラインヘルプの文面の表示をしたか否か。
my $head ;
$o{i} //= "\t" ;
my $readLines = 0 ; # 読み取った行数
my $optL0 = ($o{l}//'') eq 0 ? 1 : 0 ;
$o{'@'} //= 15 ; # 何秒おきにアラームを発生させるか
$o{0} //= '-' ; # 出力表において、頻度が 0 の場合に、どんな値を出力するかを表す。
$o{q} //= "'" ; # 出力する文字を前後で囲む文字。

binmode STDOUT, ":utf8" ;

$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 $o{'@'} 
} ; 
alarm $o{'@'} ;

my %nn ; # $nn{ $prev } { $post } で頻度である。
my %n2 ; # $post を格納する(ひとまずの定義)。他の意味づけや他の用途は考えられるであろう。

do { $_ = <> ; chomp ; $head = $_ } if $o{'='} ; 
my $z = 'start' ; # 直前の文字として格納。
my $end = 'end' ; # 最後を表す文字 End Char

while( <> ) { 
  $readLines ++ ;
  do { chomp ; $z = 'start' } if ! $optL0 ; # 行を意識する場合。
  $_ = decode_utf8 $_ ; 
  my @chars = split // , $_ , 0 ; 
  for ( @chars ) {
    $_ = '$/' if $_ eq $/  ;
    $o{'~'} ? ++ $nn {$_} {$z} && ++ $n2 {$z} : ++ $nn {$z} {$_} && ++ $n2 {$_} ; # トリッキーかも。
    $z = $_ ;
  } 
  do { $o{'~'} ? ++$nn{$end}{$z} && ++$n2{$z} : ++$nn{$z}{$end} && ++$n2{$end} } if ! $optL0 ; # 行を意識する場合
}
do { $o{'~'} ? ++$nn{$end}{$z} && ++$n2{$z}: ++$nn{$z}{$end} && ++$n2{$end} } if $optL0 ; # 行を意識しない場合

my @keg1 = sort { &conv($a) cmp &conv($b) } keys %nn ; 
my @keg2 = sort { &conv($a) cmp &conv($b) } keys %n2 ; 
use utf8 ;
say UNDERLINE join "\t" , ($o{'~'} ? '↓prev' : 'prev→') , map { & conv($_) } @keg2 ; 
for my $k ( @keg1 ) { 
  say join "\t" , & conv($k) , map { $nn { $k } { $_ } // $o{0} } @keg2 ; 
}
say join "\t" , "total" , map { $n2 { $_ } // $o{0} } @keg2 ; 
exit ;

sub conv ( $ ) { 
  return $_[0] = '"\t"' if $_[0] eq "\t" ; 
  return $_[0] = '"\n"' if $_[0] eq "\n" ;   
  return $_[0] if length $_[0] > 1 ;
  return "$o{q}$_[0]$o{q}" ; 
}

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" ;
  say STDERR BOLD FAINT ITALIC $head if defined $head ;
}

## ヘルプの扱い