view release on metacpan or  search on metacpan

digitdemog  view on Meta::CPAN

    $M{$len}[2] = $_ if ! defined $M{$len}[2] ; 
    $M{$len}[3] = $_ ;
  }
  print join ( "\t", map {UNDERLINE $_} qw[length freq minstr maxstr] , $oL4 ? qw[first_str last_str ]:() ) , "\n" ;
  for ( sort { $a <=> $b } keys %M ) {  # 数値 (文字列の長さを表す)でソート 
    my @str = @{ $M{$_} } ;
    my @prt = $optq0 ? @str : map { defined $_ ? qq['$_'] : undef } @str ;
    $prt[1] = DARK '<-- same' if $str[1] eq $str[0] ; 
    $prt[3] = DARK '<-- same' if $oL4 and defined $str[3] and $str[3] eq $str[2] ; #|| $str[3] eq $str[1]; 
    for my $p ($oL4? 0..3 : 0..1 )  { 
      $prt[$p] = $prt[$p] . DARK "(" . $freq{ $str[$p] } . ")" if $freq{ $str[$p] } != $Lfrq{$_} ;
    }
    print join ( "\t" , $_ , $Lfrq{$_}, @prt ) , "\n" ;
  }
}

sub d3 ($) { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ; # 数を3桁区切りに変換する。

sub majority2 ( @ ) { 
  # いろんな値を配列で受け取り、頻度2以上のものについて、多い順番に返す。# 同一の入力でも、同じ頻度ならどっちが優先されるかは不明。
  my %h ; # ヒストグラム
  ++ $h { $_ } for ( @_ ) ;
  my $m = max values %h ; 
  $h{$_} == 1 and delete $h{$_} for keys %h ;  #++ $m if $m == 1;  # 頻度の最大値が1なら、次の処理で空列を返すようにする。
  my %h2 ; 
  my @out ; 
  for ( keys %h ) { push @{ $h2{ $h{$_} } } , $_ } 
  for ( sort { $b <=> $a } keys %h2 ) { push @out , @{ $h2{$_} } } 
  return @out  ;#first { $h {$_} == $m } keys %h
} # リストから最も成分の多いものをさらにひとつだけ選ぶ.

sub backslash ($$) { # 制御文字を一部エスケープシーケンスに変化させる。 arg2 は シングルクォーテーションを何に変化させるか。
  do{ my $c = eval qq["$_"] ; $_[0] =~ s/$c/$_/g and $_[0] =~ s/'/$_[1]/g } for qw[\a \n \r \f \t \e] ; 
  return $_[0] ; # 
}

sub stock ($$$$) { # arg2が参照する配列で arg1 個蓄えるが、arg3の値を後ろに追加。さらに、arg4の0/1に応じて、pop/shift(後ろ出し/前出し)する。
  my @ary = uniq @{ ${$_[1]} }, $_[2] ; 
  @{ ${$_[1]} } = splice @ary, ( $_[3] ? max 0,scalar @ary - $_[0] : 0 ) , $_[0] ;
} ;  # 各行の例をストックするための関数

##
## 普通のモードのmain関数
##

sub main_normal ( ) { 

  my %freq ; # 同じ行が来たかどうかの判定に使う。数が集計される。
  my %S1 ; # $S1{$v}{$pos} のように使う。 出現回数の集計表 ; # ここの $v は 文字と言うよりパターンを示す。'a'とか [1-3]とか。ここでは「文字」と呼ぶ。
  my %S2 ; # $S2{$v}{$pos} = "行番号+行番号+...行番号+" (Lとする); $vが出現した桁$posに対応する行番号を蓄える。
  my %S3 ; # @ { $S3{ F } } によって、分割表で頻度 F 回現れた 行番号集合の値 L (%S2の持つ値)を参照できるようにする。
  my %mark ; # $mark{ L } がピリオドをピリオド付ける。 ( -. で使う。)
  my %Gs  ; # @{ $G { $v } { $pos } [ 0 or 1 ] } で 行の具体例を格納。 ( -g で使う。)
  my $maxlen = 0 ; # 文字列の最大長
  my $eol = "EOL" . int rand 8 ; # 各行の終わりを示す。## saikoro -g10,3 でいろいろ試した。

  @e = map { decode_utf8 $_ } @e unless $optu0  ;
  unshift @e , "$eol\$" ;  # 正規表現パターン群に $eol を 最初に 追加。 # 「行末」は頻度が多いので最初に持ってきた。
  #push @e , "$eol\$" ;  # 正規表現パターン群に $eol を 最後に 追加。# ここは、unshift でも push でも良い。
  my @eqr ; # 「e をqrされた 」により名付けた。
  my @exu ; # 「eにおいて、エスケープ(escape)してユニコード(unicode)で表した部分がある」により名付けた
  for ( 0 .. $#e ) { 
    my $eout = $e[$_] =~ s/#.*$//r ; # 正規表現で、コメント#の部分は除去する。
    my @F  = split /([[:^ascii:]])/o , $eout , 0 ; # パターンで切った最後は空文字列なら切り落とすための0
    grep { $_ =  (sprintf '\x{%02X}', ord $_ ) if m/[[:^ascii:]]/ } @F ;
    my $p = join '' , @F ;
    $eqr [ $_ ] = qr/$p/ ; # あらかじめ正規表現として先にコンパイルすることで高速化。
    push @exu , $p ;
  }
  
  # split で割るためのパターンの設定。
  my $piecePattern = @e ? do{ my$t=join'|',@exu,'.','\n';qr/$t/o} : qr//o ; # @exuに1文字(.)と改行文字を追加した。

  $header = <> if $o{'='} ; 
  while ( <> ) { 
    chomp if 0 eq ($o{n}//'') ; #-n0 で改行文字を除去。
    next if $freq{$_} ++ && $o{1} ; # && の前後の順序に注意
    s/\r$// unless $optw0 ;    
    $_ = decode_utf8 $_ unless $optu0 ;
     # ▽ パターンに文字列を分解。
    my @vvec = m/$piecePattern/go ; 
    push @vvec , $eol ; # 各行をバラバラにした後に、$eolを最後に追加。
    splice @vvec , $width, if defined $width ; 
    $maxlen = @vvec if $maxlen < @vvec ; # 最大長の保管
    for my $pos ( 0 .. $#vvec ) {
      my $char = $vvec [ $pos ] ; # 実際の文字(列)。  (パターンにはまだ分類していない。)
      my $v  ; # どのパターンまたは文字として認識するか。(分類されたパターンなのである。)
       # ▽ どのパターンにマッチしたかを$vに格納する。次の2行のコードで。
      $char =~ $eqr[$_] and do { $v = $e[$_] ; last } for 0 .. $#e ; # 指定したパターンの数が多いと遅くなるであろう。頻度の高いパターンを先に置くと早くなる。
      $v //= "'$vvec[$pos]'" ; # 前行の処理で当てはまらない場合。クォーテーションを付加するようにした。
      $S1 { $v } { $pos } ++ ; 
      $S2 { $v } { $pos } .= "$.+" if $o{'.'} ; # <-- $S2{..}で、その「文字」がその桁で現れた、「行番号集合」L が結果的に生成される。
      do { for my $way (0,1) { & stock ( $o{g} , \$Gs{$v}{$pos}[$way] , $_ , $way ) } } if $o{g}  ; # 改行文字はここでは除去せず
    }
  } # ← 入力読み取り処理の終わり
  if ( $o{'.'} ) {  ## 複雑な処理である↓ # $S1{ .. }　で その「文字」が「各桁」で、何回 (b回) 現れたのか。... # この  ; 「b回」現れた L を S3に保管。
    for my $v ( keys %S1 ){ 
      push @{  $S3 { $S1{$v}{$_} }  }, $S2{$v}{$_} for keys %{ $S1{$v} } ; 
    } 
    for( keys %S3 ){ # 各「文字」が各桁で何回現れたか(頻度) の 数 それぞれに対して
      my @pcand  = majority2 @{ $S3{$_} }  ; # 行番号集合L を考えて、そういうLで最も頻度の高いものを取り出す。
      grep { $mark { $pcand [$_] } = '.' . ( '0' x $_ ) } 0 .. min $#pcand , $o{'.'} - 1 if @pcand ; 
    }  
  }
  # 出力

  my $ex = "example${sep}..${sep}example" ; # 具体例を表す列の表頭をどうするか?
  say join "\t" , map { UNDERLINE YELLOW $_ } (0+$o{o}) .. ($maxlen+$o{o}-1) , 'char' , 'code' , 'freq' , $o{g} ? $ex :() ; # 行頭の出力
  my %vcate ; $vcate{$_} = 2 for @e ; # omit する
  my @vset ; # 表示する値の配列。順番は、 (1). 引数に渡された正規表現いくつか (2). 非cntrl文字 (3). cntrl文字(4). 各行の終わり
  push @vset , @e[ 1 .. $#e ] ; # (1).
  push @vset , sort {length $a <=> length $b or $a cmp $b } grep { ! $vcate { $_ } and ! /[[:cntrl:]]/ } keys %S1 ; # (2)
  push @vset , sort {length $a <=> length $b or $a cmp $b } grep { ! $vcate { $_ } and /[[:cntrl:]]/ } keys %S1 ; #(3)
  push @vset , $e[ 0 ] ;
  my $take = sub ($$) { splice @{$_[1]} , 0, $_[0] } ; # 配列参照arg2からその配列の先頭arg1個取ってくる。
  my $take2 = sub ($$$) { uniq $take->($_[0],$_[1]) , $take->($_[0],$_[2]) } ;# 配列参照2個(arg2,arg3)から、それぞれarg1個取って、uniq する。
  my $ucd = sub ($){ ( sprintf 'U+%06X', ord $_[0] ) =~ s/(00)+((..)+$)/$2/r } ; # Unicode の符号位置を返す。2桁以上の偶数桁になるように。
  for my $v ( @vset ){ # <-- ソート順には注意したい
    my @out = map { $S1{$v}{$_} // 0 } 0 .. ( $maxlen - 1 ) ; 
    my @pvec = grep { $out[$_] } $o{g}=~/\.$/o ? reverse 0..$#out : 0..$#out ;  # 何桁目を見るか、そして、優先的にどこから見るか。
    my @pv = map { [ grep { $out[$_] } @{$_} ] } [0..$#out] , [reverse 0..$#out] ;  # 何桁目を見るか、そして、優先的にどこから見るか。