読者です 読者をやめる 読者になる 読者になる

無精・短気・傲慢

perlの事 いろいろ

再帰(recursion)

再帰でプログラミングするとシンプル(綺麗に、格好良く)に書ける。再帰脳を鍛えよう!

最初の一歩 等差数列の和(1から10までの合計を求める。)

perl -E 'sub f{$_[0]>1?$_[0]+f($_[0]-1):$_[0]} say f(10)'

ワンライナーをばらすと…

sub f{
  $_[0] > 1 ? $_[0]+f($_[0]-1)  # f(n) = n + f(n-1)
            : $_[0];            # f(1) = 1
}

say f(10) 

考え方

f(0) = 0
f(1) = 1
f(2) = 2 + f(1)
f(3) = 3 + f(2)
     .
     .
f(n) = n + f(n-1)

しかし、再帰は計算量が増える傾向にある。1回で計算出きるなら1回の方が良いに決まっている。(多分)

perl -E 'sub f{($_[0]+$_[1])*($_[1]-$_[0]+1)/2} say f(1,10)'

ワンライナーをばらすと…

sub f{
  ($_[0]+$_[1])*($_[1]-$_[0]+1)/2; #(最初の数+最後の数)×(全体の個数)÷2
}
say f(1,10)

考え方

(最初の数+最後の数)×(全体の個数)÷2
 (1 + 10) × 10 ÷ 2
10□□□□□□□□□□
 9□□□□□□□□□■ 1
 8□□□□□□□□■■ 2
 7□□□□□□□■■■ 3
 6□□□□□□■■■■ 4
 5□□□□□■■■■■ 5
 4□□□□■■■■■■ 6
 3□□□■■■■■■■ 7
 2□□■■■■■■■■ 8
 1□■■■■■■■■■ 9
  ■■■■■■■■■■10
  1 2 3 4 5 6 7 8 910 

最大公約数を求める

整数xとyの最大公約数求める時は2つの数を除算し余りが0になるまで繰り返すと最大公約数が求められる。これをユークリッドの互除法ユークリッドのごじょほう、英: Euclidean Algorithm)と言うらしい。

perl -E 'sub gcd{$_[1]?gcd($_[1],$_[0]%$_[1]):$_[0]} say gcd(1071,1029)'

ワンライナーをばらすと…

sub gcd{
  $_[1] ? gcd($_[1],$_[0]%$_[1])   # 引数2、引数2と引数1の余りで再計算する
        : $_[0];                   # 引数2が0(余り無し)の場合は引数1が解である
}
say gcd(1071,1029)

ハノイの塔を積む

perl -E 'sub h{return if(!$_[0]);push(@_,$_[0]-1);h(@_[-1,1,3,2,4]);$_[4]->(@_);h(@_[-1,2,1,3,4]);} h(pop,A..C,sub {say "$_[1]($_[0])=>$_[3]";})' 4

ワンライナーをばらすと…

sub h{
  return if(!$_[0]);      # 円盤が無いときは何もしない
  push(@_,$_[0]-1);       # 一つ上の円盤を求める
  h(@_[-1,1,3,2,4]);      # 上の円盤をワークの塔へ移動
  $_[4]->(@_);            # 対象の円盤を移動する(コールバックルーチン)
  h(@_[-1,2,1,3,4]);      # 上の円盤をワークから目的の塔へ移動
}
h(pop,A..C,sub {say "$_[1]($_[0])=>$_[3]";})          # N個の円盤をA塔からC塔へ移動する

ソート処理

クイックソート

適当な値(ピボットという)を選択し (この場合はデータの総数の中央値が望ましい)ピボット値より小さい値の組と大きい値の組に分けてそれぞれに同じ処理を繰り返しソートを行う。

perl -E 'sub qsrt{my $op=shift;my $n=int(rand(@_+0));(@_+0)<=1?@_:(qsrt($op,grep{$op->($_,$_[$n])<0} @_),(grep{$op->($_,$_[$n])==0} @_),qsrt($op,grep{$op->($_,$_[$n])>0} @_))} say join ",",qsrt(sub {$_[1]<=>$_[0]},0..10,2..5,undef)'  

ワンライナーをばらすと…

sub qsrt{
  my $op=shift;
  my $n = int(rand(@_+0));                              # ピボットを求める
  (@_+0) <= 1 ? @_                                      # 一件以下の場合はそのまま返す
              :(qsrt($op,grep{$op->($_,$_[$n])<0} @_),  # ピボット値より小さい値の組をソートする
               (grep{$op->($_,$_[$n])==0} @_),          # ピボット値と同じ値の組はそのまま返す
                qsrt($op,grep{$op->($_,$_[$n])>0} @_))  # ピボット値より大きい値の組をソートする
}
 say join ",",qsrt(sub {$_[1]<=>$_[0]},0..10,2..5,undef)

マージソート

配列を分割していき、最小単位に分割した配列をマージする事によりソートする。

perl -E 'sub marge{my $f=shift;my @m;while(@{$_[0]}+0 and @{$_[1]}+0){$a=$_[0]->[0];$b=$_[1]->[0];push(@m,$f->()?shift(@{$_[0]}):shift(@{$_[1]}))};@m,@{$_[0]},@{$_[1]};} sub msrt{my $f=shift;@_+0>1?marge($f,[msrt($f,@_[0..int(@_/2)-1])],[msrt($f,@_[int(@_/2)..@_-1])]):@_} say join ",",msrt(sub {$b <= $a},0..10,2..5,undef)'

ワンライナーをばらすと…

sub marge{
  my $f = shift;
  my @m;                                # マージする配列よ用意する
  while(@{$_[0]}+0 and @{$_[1]}+0){     # 片方の配列がなくなるまでマージを繰り返す
    $a=$_[0]->[0];                      # 配列1の1つ目の要素をセーブ(大小判断用)
    $b=$_[1]->[0];                      # 配列2の1つ目の要素をセーブ(大小判断用)
    push(@m,$f->() ? shift(@{$_[0]})    # 小さい方の配列より要素を1つ削除し
                   : shift(@{$_[1]})    # 新しい配列へ追加する
    )
  };
  @m,@{$_[0]},@{$_[1]};                 # 新しい配列と残りの配列をマージする
}

sub msrt{
  my $f = shift;
  @_+0 > 1 ? marge($f,[msrt($f,@_[0..int(@_/2)-1])]
                     ,[msrt($f,@_[int(@_/2)..@_-1])])        # 配列を分割しマージする
           : @_                         # 配列の要素が1つ以下の場合はそのまま返す
}
say join ",",msrt(sub {$b <= $a},0..10,2..5,undef)

挿入ソート

perl -E 'sub ins{$op=shift;return $_[0] if(@{$_[1]}==0); $a=$_[0];$b=shift(@{$_[1]});my $x=$b;$op->()?($_[0],$x,@{$_[1]}):($x,ins($op,$_[0],$_[1]))} sub isrt{my $f=shift;return @_ if(@_+0<=1);my $x=shift;ins($f,$x,[isrt($f,@_)])} say join ",",isrt(sub {$b <= $a},0..10,2..5,undef)'

ワンライナーをばらすと…

sub ins{
  $op=shift;
  return $_[0] if(@{$_[1]}==0);
  $a=$_[0];
  $b=shift(@{$_[1]});
  my $x=$b;
  $op->() ? ($_[0],$x,@{$_[1]})
          : ($x,ins($op,$_[0],$_[1]))
}
sub isrt{
  my $f=shift;
  return @_ if(@_+0<=1);
  my $x=shift;
  ins($f,$x,[isrt($f,@_)])
}
say join ",",isrt(sub {$b <= $a},0..10,2..5,undef)
perl -E 'sub isrt{my $f=shift;my @x = @_;for(my $i=1;$i<=$#x;$i++){my $j=$i;while($j){($a,$b)=@x[$j-1,$j];last if($f->());@x[$j-1,$j]=@x[$j,$j-1];$j--;}}return @x;}say join ",",isrt(sub {$b < $a},0..10,2..5,undef,1..100)'

ワンライナーをばらすと…

sub isrt{
  my $f=shift;
  my @x = @_;
  for(my $i=1;$i<=$#x;$i++){
    my $j=$i;
    while($j){
      ($a,$b)=@x[$j-1,$j];
      last if($f->());
      @x[$j-1,$j]=@x[$j,$j-1];
      $j--;
    }
  }
  return @x;
}
say join ",",isrt(sub {$b > $a},0..10,2..5,undef,1..100)

シェルソート

挿入ソートの発展形で爆速です

perl -E 'sub ssrt{my $f=shift;my @x=@_;my $h=1;for(;$h<$#x/9;$h=$h*3+1){}for(;$h>0;$h=int($h/3)){for(my $i=$h;$i<=$#x;$i++){my $j=$i;while($j>=$h){($a,$b)=@x[$j-$h,$j];last if($f->());@x[$j-$h,$j]=@x[$j,$j-$h];$j-=$h;}}}return     @x;}say join ",",ssrt(sub {$b > $a},0..10,2..5,undef,1..10000)'
sub ssrt{
  my $f=shift;
  my @x = @_;
  my $h = 1;
  for(;$h<$#x/9;$h=$h*3+1){}      # 間隔hを求める。
  for(;$h>0;$h=int($h/3)){        # 間隔が1になるまで間隔を狭めていく
    for(my $i=$h;$i<=$#x;$i++){   # この下はほとんど挿入ソート
      my $j=$i;
      while($j>=$h){
        ($a,$b)=@x[$j-$h,$j];
        last if($f->());
        @x[$j-$h,$j]=@x[$j,$j-$h];
        $j-=$h;
      }
    }
  }
  return @x;
}
print join ",",ssrt(sub {$b > $a},0..10,2..5,undef,1..10000)

perlの組み込みソート

当然ながら組み込みのソートとは勝負にならない

perl -E 'say join ",",sort {$b <=> $a} (0..10,2..5,undef)'

バイナリーサーチ

perl -E 'sub BinarySearch{my $l=$_[3]||0;my $r=$_[4];my $r=@{$_[1]}-1 if($r eq "");my $f=$_[2]||sub{$a<=>$b};my($x,$m);while(){return $x,$m if($l>$r);$m=int(($l+$r)/2);($a,$b)=($_[0],$_[1]->[$m]);$x=$f->();return $x,$m if(!$x);($x<0)?($r=$m-1):($l=$m+1);}}say join ",",BinarySearch(5,[1..10]);'
sub BinarySearch{                   # BinarySearch($x,\@xs,sub{比較内容},右端,左端
  my $l=$_[3]||0;                   # 最初から
  my $r=$_[4];                      # 
  my $r=@{$_[1]}-1 if($r eq "");    # 最後まで
  my $f=$_[2]||sub {$a <=> $b};     # 比較内容
  my ($x,$m);
  while(){
    return $x,$m if($l>$r);         # Not Found
    $m = int(($l+$r)/2);            # 真ん中を計算
    ($a,$b) = ($_[0],$_[1]->[$m]);  # 比較用ワーク
    $x=$f->();                      # 大小比較
    return $x,$m if(!$x);           # 見つかったよ!!
    ($x<0)?($r=$m-1)                # もっと前
          :($l=$m+1);               # もっと後
  }
}
print join ",",BinarySearch(5,[1..10]);
perl -E 'sub BinarySearch{my $l=$_[3]||0;my $r=$_[4];my $r=@{$_[1]}-1 if($r eq "");my $f=$_[2]||sub{$a<=>$b};my($x,$m);while(){return $x,$m if($l>$r);$m=int(($l+$r)/2);($a,$b)=($_[0],$_[1]->[$m]);$x=$f->();return $x,$m if(!$x);($x<0)?($r=$m-1):($l=$m+1);}}for $i (18..42){say join ",",BinarySearch($i,[reverse(map {$_*5}(4..8))],sub {$b<=>$a});}'

フィボナッチ数列

最初の二項は0,1と定義され、以後どの項もその前の2つの項の和となっている。

0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610, 987, 1597, 2584, 4181, 6765, 10946, …

perl -E 'sub f{$_[0] < 2?$_[0]:f($_[0]-1)+f($_[0]-2)} say join ",", map {f($_)} (0..10)'

ワンライナーをばらすと…

sub f{
  $_[0] < 2 ? $_[0]                     # 0,1の場合はそのまま返す
            : f($_[0]-1)+f($_[0]-2)     # f(n) = f(n-1) + f(n-2) を返す
}
say join ",", map {f($_)} (0..10)'

考え方(定義)

f(0) = 0
f(1) = 1
f(2) = f(1) + f(0)
f(3) = f(2) + f(1)
     ・
     ・
f(n) = f(n-1) + f(n-2)
  • 計算量が多いので1度計算した値を再利用する
perl -E 'my @x;sub f{$x[$_[0]]=$x[$_[0]]?$x[$_[0]]:$_[0] < 2?$_[0]:f($_[0]-1)+f($_[0]-2)} say join ",", map {f($_)} (0..30)'
my @x;                                           # 計算した値をキャッシュする配列
sub f{
  $x[$_[0]] = $x[$_[0]] ? $x[$_[0]]              # 計算済みの場合はその値を返す
            : $_[0] < 2 ? $_[0]                  # 0,1はそのまま返す
                        : f($_[0]-1)+f($_[0]-2)  # f(n-1) + f(n-2) を返す
}
say join ",", map {f($_)} (0..30)
  • こっちの方が正しいか
perl -E 'sub f{$_[0] < 1?$_[2]:f($_[0]-1,$_[1]+$_[2],$_[1])} say join ",", map {f($_,1,0)} (0..30)'

指数が整数のべき乗

perl演算子'**'で良いのだが…

perl -E 'sub pow{my ($x,$n)=@_;return $n<0?1/pow($x,$n*-1):$n==0?1:$x if($n<2);my $y=pow($x,int($n/2));$y*=$y;$n%2?$y*$x:$y;} say pow(2,9)'

ワンライナーをばらすと…

sub pow{
  my ($x,$n)=@_;                       # 整数xと指数n
  return $n <  0 ? 1/pow($x,$n*-1) :   # 指数がマイナスの場合
         $n == 0 ? 1                   # 指数が0の場合
                 : $x  if($n<2);       # 指数が1の場合
  my $y=pow($x,int($n/2));
  $y*=$y;                              # (x**h)**2
  $n%2?$y*$x:$y;                       # 指数が奇数の場合はxを掛ける
}

say pow(2,9);

考え方

xの100乗の計算

  x ** 100 = (x ** 50) ** 2
  x **  50 = (x ** 25) ** 2
  x **  25 =((x ** 12) ** 2 )* x
  x **  12 = (x **  6) ** 2
  x **   6 = (x **  3) ** 2
  x **   3 =((x **  1) ** 2 )* x
  x **   1 = x