2015-07-29

飛び出せPerl6

飛び出せperl6

アスキーでステレオグラム。ワンライナーで『パール6』を浮き出させる。いまいち飛び出ないか…。もっとガンガレ…

$ perl6 -e 'sub MAIN($x,$y){ for 1..10 -> $i { for 1..7 -> $j { print ($i==9 and $j==6)??"$y "!!"$x ";}; print "\n";}}' ...perl... ..perl6...
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ..perl6... ...perl... 
...perl... ...perl... ...perl... ...perl... ...perl... ...perl... ...perl... 
$

2015-07-19

多項式の因数分解（factorization）

高校の数学の本を元にアルゴリズム(algorithm)の備忘録として

使い方

$ perl factor.pl '8x^3+12x^2-2x-3'
(2x-1)(2x+1)(2x+3)
$  perl factor.pl ' x^4+x^2+1 '
(x^2+x+1)(x^2-x+1)
$

【計算】

[factor.pl]

$str = shift || ' 8x^3+12x^2-2x-3 ';        #<----- 

$str =~ s/\s//g;
print factor($str)."\n";
sub factor{
    my @a = arrange(shift);     # 式の整理 次数でまとめる
    if((my $i = arrayGcd(@a)) > 1){
        for(@a){ $_ /= $i;}
        return ed2(ed($i).factor(array2expr(@a)));
    }
    return factor_div(@a) if($#a > 2);  #３次以上の時は因数定理？除算の定理？で求める
    return ed2("x(".ed($a[2])."x".ed($a[1]).")") unless($a[0]);
    my @a0 = measure($a[0],1);  # 約数を求める a0 = (b1,b2)...
    my @a2 = measure($a[2],0);  #   "          a2 = (c1,c2)...
    for (@a0){                  # (a0,a1,a2)=(b1,c1)(b2,c2)
        my ($b1,$b2) = split ",";   # a1=b1*c2+b2*c1となるb1,b2,c1,c2を求める
        for(@a2){
            my ($c1,$c2) = split ",";
            return ed2("(".ed($c1)."x".ed($b1).")(".ed($c2)."x".ed($b2).")")
                    if($a[1] == $b1*$c2+$b2*$c1);
            return ed2("(".ed($c2)."x".ed($b1).")(".ed($c1)."x".ed($b2).")")
                    if($a[1] == $b1*$c1+$b2*$c2);
        }
    }
    return "(".array2expr(@a).")";  # 数値を式に変換 -> a2 x^2 + a1 x + a0 
}
sub factor_div{             # 因数定理？　除算の定理？
    my @a = @_;
    my ($tmp,$tmp1,$k);
    for my $z (1..abs($a[$#a])){
        for(my $i=1;$i<=abs($a[0]);$i++){
            $tmp = $tmp1 = 0;
            $k = 0 - $i;
            for(my $j=0;$j<=$#a;$j++){
                my $z2 = ($j) ? $z : 1;
                $tmp += $a[$j]*($i**$j)/($z2**$j);
                $tmp1 += $a[$j]*($k**$j)/($z2**$j);
            }                                                      # 誤差調整の為、sprintfを追加
            return ed2("(".ed($z)."x".ed(0-$i).")".factor(array2expr(div($z,0-$i,@a)))) 
                                                                   unless(sprintf("%f",$tmp)+0);
            return ed2("(".ed($z)."x".ed(0-$k).")".factor(array2expr(div($z,0-$k,@a)))) 
                                                                   unless(sprintf("%f",$tmp1)+0);
        }
    }
    if($a[0]==0){
        shift @a;
        return ed2("x".factor(array2expr(@a)));
    }
    if(@a==5 and $a[1]==0 and $a[2]==0 and $a[3]==0 and
           $a[4] >= 0 and $a[4] == (int(sqrt($a[4])))**2){
        my @b = (@a[0],0,1);
        my $n=sqrt(@a[4]);
        my $ans = factor(array2expr(@b));
        if($n == 1){$n="";};
        if($ans =~ s/x([+-])/${n}x\^2$1/g){
            return $ans;
        }else{
            return "(".array2expr(@a).")";
        }
    }elsif(@a==5 and $a[1]==0 and $a[3]==0){
        my @b = @a[0,2,4];
        my $ans = factor(array2expr(@b));
        if($ans !~ /(\(.+\)){2,}/){            # X^2をXと置いてa^2-b^2=(a+b)(a-b)の公式にて ※1
            if($b[0] >= 0 and $b[2] == 1 and $b[1]+1 == sqrt($b[0])*2){ 
                return "(" . array2expr(sqrt($b[0]),1,1) . ")(" . array2expr(sqrt($b[0]),-1,1) . ")" ;
            }
            return "(" . array2expr(@a) . ")";
        }
        $ans =~ s/x/x^2/g;
        return $ans;
    }else{
        return "(".array2expr(@a).")";
    }
}
sub div{
    my ($x,$z,@a) = @_;
    my @b;
    for (my $i = $#a;$i>0;$i--){
            $b[$i-1]=$a[$i]/$x;
            $a[$i-1]-= $z*$b[$i-1];
    }
    return @b;
}
sub arrange{                # 式の整理
    my $str = shift;
    my @a = (0,0,0);
    my ($b,$c);
    while($str =~ s/([+-]*[\d\.]*)x\^([\d\.]*)//){
        $b=$2;
        $c=$1;
        $a[$b] += ($c =~ /^[+-]*$/) ? "$c" . "1" : $c;
    }
    while($str =~ s/([+-]*[\d\.]*)x//){
        $c = $1;
        $a[1] += ($c =~ /^[+-]*$/) ? "$c" . "1" : $c;
    }
    while($str =~ s/([+-]*[\d\.]{1,})//){
        $a[0] += $1;
    }
    return @a;
}
sub measure{               # 約数を求める
    my ($a,$flag) = @_;
    my $n = abs($a);
    my @ans = ();
    for (my $j = int(sqrt($n)); $j > 0;$j--){
        unless ($n % $j){
            if($a<0){
                push(@ans,join(",",$j,$n/$j*(-1)));
                push(@ans,join(",",$j*(-1),$n/$j));
            }else{
                push(@ans,join(",",$j,$n/$j));
                push(@ans,join(",",$j*(-1),$n/$j*(-1))) if($flag);
            }
        }
    }
    return @ans;
}
sub array2expr{            # 数値を式に変換
    my @a = @_;
    my $new = "";
    for (my $i = $#a ; $i>=0;$i--){
        next if($a[$i] ==0);
        $new .= ed($a[$i]);
        if($i == 1){
            $new .= "x";
        }elsif($i > 1){
            $new .= "x^".$i;
        }
    }
    return ed2($new);
}
sub arrayGcd{
#    my @a = @_;
    my $ans = 0;
    for(@_){ $ans = gcd($ans,$_);}
    return abs($ans);
}
sub gcd{
    my ($x,$y) = @_;
    return $y ? gcd($y,$x % $y) : $x ;
}

sub ed{
    my $n = shift;
    return ($n >= 0) ? "+" . $n : $n;
}
sub ed2{
    my $str = shift;
    $str =~ s/([+-])1(x)/$1$2/g;
    $str =~ s/^\+//;
    $str =~ s/\(\+/\(/g;
    my $sub = 1;
    if ($str =~ s/xx(\^(\d+))/XX/){
        $sub = $2;
    }
    while($str =~ s/xx/X/i){$sub++;}
    $str =~ s/X/x^$sub/ ;
    return $str;
}

※1 複２次式の因数分解 / 数学I by ふぇるまー｜マナペディア｜を参照

2015-07-08

perl6 memo

array etc..

編集

$ perl6 -e 'say ("a".."z")[5]'
f
$ perl6 -e 'say first-index { $_ > 5 }, (1..10)'
5
$ perl6 -e 'say [+] 1..10'
55
$ perl6 -e 'say join ",", 1..10 '
1,2,3,4,5,6,7,8,9,10
$ perl6 -e 'for 1..10 -> $x {say "[$x]";}'
[1]
[2]
[3]
[4]
[5]
[6]
[7]
[8]
[9]
[10]
$ perl6 -e '(1..10).reverse.say'
10 9 8 7 6 5 4 3 2 1
$ perl6 -e 'say join ":",map {$_ * 2}, (1..10).reverse'
20:18:16:14:12:10:8:6:4:2
$ perl6 -e 'my @x=(1..4);unshift(my @y,pop(@x));push(@y,shift(@x));say join ",",@y'
4,1
$

hash etc..

編集

$ perl6 -e 'my %hash = "a"=>1,"i"=>2,"u"=>3,"e"=>4,"o"=>5;for %hash.kv -> $k,$v { say "$k:$v"}'
a:1
i:2
u:3
e:4
o:5
$ perl6 -e 'my %hash = "a"=>1,"i"=>2,"u"=>3,"e"=>4,"o"=>5;say %hash'
("a" => 1, "e" => 4, "i" => 2, "o" => 5, "u" => 3).hash
$ perl6 -e 'my %hash = "a"=>1,"i"=>2,"u"=>3,"e"=>4,"o"=>5;say %hash<u>'
3
$ perl6 -e 'my %hash = "a"=>1,"i"=>2,"u"=>3,"e"=>4,"o"=>5;say %hash.keys'
a i u e o
$ perl6 -e 'my %hash = "a"=>1,"i"=>2,"u"=>3,"e"=>4,"o"=>5;say %hash.values'
1 2 3 4 5
$

tertiary operator

編集

$ perl6 -e 'say map {($_%3??""!!"foo") ~ ($_%5??""!!"baz") or $_},1..31'
1 2 foo 4 baz foo 7 8 foo baz 11 foo 13 14 foobaz 16 17 foo 19 baz foo 22 23 foo baz 26 foo 28 29 foobaz 31
$

perl5 vs perl6

編集

微妙な違いがあって…

$ perl -E 'say join ",",map {$_*2} (1..5) x 2'
2,4,6,8,10,2,4,6,8,10
$
$ perl6 -e 'say join ",",map {$_*2},(1..5) xx 2'
2,4,6,8,10,2,4,6,8,10
$
$ perl -E 'say "ABC" . "DEF"'
ABCDEF
$
$ perl6 -e 'say "ABC" ~ "DEF"'
ABCDEF
$

コマンドライン

編集

ハノイの塔（う～ん。なんか面倒くさい）

$ 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]";})' 3
A(1)=>C
A(2)=>B
C(1)=>B
A(3)=>C
B(1)=>A
B(2)=>C
A(1)=>C
$ perl6 -e 'sub h{return if !@_[0] ;push(@_,@_[0]-1);h(@_[5,1,3,2,4]);@_[4].(@_);h(@_[5,2,1,3,4]);};sub MAIN($x){h($x ,"A".."C",sub {say "@_[1]\(@_[0]\) =\> @_[3]";})}' 3
A(1) => C
A(2) => B
C(1) => B
A(3) => C
B(1) => A
B(2) => C
A(1) => C
$

コマンドラインの引数をチェックしてくれるらしい

$ perl6 -e 'sub MAIN($a,$b){say $a**$b;}'
Usage:
  -e '...' <a> <b> 
$ perl6 -e 'sub MAIN($a,$b){say $a**$b;}' 2
Usage:
  -e '...' <a> <b> 
$ perl6 -e 'sub MAIN($a,$b){say $a**$b;}' 2 4
16
$ perl6 -e 'sub MAIN($a,$b){say $a**$b;}' 2 4 5
Usage:
  -e '...' <a> <b> 
$

ディスパッチ

$ perl6 -e 'multi MAIN("add",$x,$y){say $x+$y};multi MAIN("sub",$x,$y){say $x-$y;};multi MAIN("div",$x,$y){say $x/$y;}' add 2 3
5
$ perl6 -e 'multi MAIN("add",$x,$y){say $x+$y};multi MAIN("sub",$x,$y){say $x-$y;};multi MAIN("div",$x,$y){say $x/$y;}' sub 2 3
-1
$ perl6 -e 'multi MAIN("add",$x,$y){say $x+$y};multi MAIN("sub",$x,$y){say $x-$y;};multi MAIN("div",$x,$y){say $x/$y;}' div 2 3
0.666667
$

正規表現で素因数分解する

編集

$ perl -E 'sub f{my $x=shift;my @ans =();my $N=('o' x $x);for(;$N=~/^(oo+?)\1+$/;$N=~s/$1/o/g){push(@ans,length($1));}push(@ans,length($N)); join("x",@ans);} say f(102);'
2x3x17
$
$ perl6 -e 'sub f($x){my @ans =();my $N= "o"x$x;my $s;loop (;$N ~~ /^(oo+?)$0+$/;$N ~~ s:g/$s/o/) {$s=$0;push(@ans,chars($s));};push(@ans,chars($N)); join("x",@ans);} ;say f(102);'
2x3x17
$

無精・短気・傲慢

2015-06-19

PERL6

「ラブ・ストーリーは突然に」

編集

突然、PERL6（パールシックス）が気になってきた。今年(2015)はラリーからのクリスマスプレゼントがあるらしい（わくわく）

[wikipediaより]

言語仕様は現在のPerl (Perl 5)と互換性がなく、既存のPerl 5のソフトウェアをPerl 6用に「アップグレード」するのは極めて困難である。したがって現在はPerl 5とPerl 6は別の言語であると考えられており、Perl 6はPerl 5の次期バージョンではないとされている。換言すれば、Perl 6はPerl 5から移行対象とはみなされていない。

ところが、inline::perl5とはなんだ……気になる

Perl の現状より

Perl に未来があるか

Perl が有効で、優れた働きをしていることは確かです。Perl 6 の開発チームは、次世代のPerl 言語を定義するため、精一杯の仕事をしています。別のチームの開発者は、Perl 6 の次世代の実行時エンジンである Parrot で精一杯の仕事をしています。Parrot は、Perl 6 のような動的な言語をサポートするだけでなく、Python や Ruby などもサポートするようにデザインされています。Perl 6 は、既存の Perl 5 コードの透過的な移行もサポートしています。
Perl の成功を、他の何らかの言語の失敗に基づいて述べることはできません。Perl の成功は、あなたの仕事を終わらせるのを助けてくれるかどうかにかかっているのです。

セカンドシステム症候群にまつわる3つの話―Perl 6, Python 3, PHP 6
Perl の現状（古いが…）
perl6 wikipedia

perl6は仕様、実装はrakudoとかparrotとか

ubuntuにセットアップ

編集

$ sudo apt-get install rakudo

$ perl6 -v
This is perl6 version 2014.07 built on parrot 6.6.0 revision 0
$ 
$ perl6 -V
parrot::git_describe=0
parrot::sha1=0
parrot::a=.a
parrot::ar=ar
parrot::ar_extra=
parrot::ar_out=
parrot::archname=i686-linux-gnu-thread-multi-64int
 .
 .
 .
perl6::name=rakudo
perl6::version=2014.07
perl6::release-number=
perl6::codename=
perl6::build-date=2014-12-02T21:01:35Z
$ 
$ parrot -V
This is Parrot version 6.6.0 built for i386-linux
Copyright (C) 2001-2014, Parrot Foundation.

This code is distributed under the terms of the Artistic License 2.0.
For more details, see the full text of the license in the LICENSE file
included in the Parrot source tree

$

hello world

編集

やっぱり最初は

$ perl6 -e 'say "Hello world"'
Hello world
$ 
$ perl6 -e "say 'こんにちは世界'"
こんにちは世界
$

１から10までを加算する

$ perl6 -e 'sub f($n){$n>1 ?? $n+f($n-1)!!$n};say f(10)'
55
$ perl6 -e 'say [+] 1..10'
55
$

[配列、ハッシュ、関数]のリファレンス

$ perl6 -e 'my $x = sub{say "hello!"};$x.();$x=(1..10);say $x.reverse;$x={A=>41,B=>42};say $x.values'
hello!
10 9 8 7 6 5 4 3 2 1
41 42
$

shell sort

編集

まだ、いまいち（理由解らん！）

[shellsort.pl6]

say join ( ',',ssrt ( sub ($a,$b) { $b gt $a } ,0..10));
  
sub swap ($f,$j,$h,$x) {
  loop ( ; $j>=$h ; $j-=$h ) {
     return $x if($f.( $x.[ $j-$h ],$x.[ $j ] ) );
     $x.[ $j-$h ],$x.[ $j ] = $x.[ $j ],$x.[ $j-$h ];
  }
} 
sub loop1 ($f,$h,$x) {
  loop (my $i=$h ; $i<=$#x ; $i++i) {
    swap ($f,$i,$h,$x);
  }
}
sub ssrt {
  my $f=shift;
  my @x=@_;
  my $h=1;
  loop ( ;$h < @x / 9 ; $h=$h*3+1 ) { };
  loop ( ;$h > 0 ; $h=int($h/3) ) { 
    loop1 ($f,$h,@x);
  } 
  return @x;
} 
__END__

$ perl6 shellsort.pl6
===SORRY!=== Error while compiling shellsort.pl6
Unable to parse quote-words subscript; couldn't find right angle quote
at shellsort.pl6:27
------> <BOL>&#9167;<EOL>
   expecting any of:
       postfix
$

エラーの意味が解らん。誰かおしえて！！！ - John (2015年06月23日 20時51分44秒)

my ($f,$h,@x); 
say join  ',',ssrt ( anon sub op ($a,$b) { $a gt $b } , (0..100));
  
sub swap (@x1) {
  my ($j,$h) = @x1;
  loop ( ; $j>=$h ; $j-=$h ) {
     return 0 if($f.( @x[ $j-$h ], @x[ $j ] ) );
     (@x[ $j-$h ],@x[ $j ]) = (@x[ $j ],@x[ $j-$h ]);
  }
} 
sub loop1 ( $h ) {
  loop (my $i=$h ; $i <= +@x ; $i++) {
    swap ($i,$h);
  }
}
sub ssrt ( @x1 ){
say @x1;
  ($f,@x) = (@x1);
  my int $h=1;
  loop ( ;$h < (@x / 9) ; $h=$h*3+1 ) { };
  loop ( ;$h > 0 ; $h=Int($h/3) ) { 
    loop1 ( $h );
  } 
  return @x;
}

$ perl6 shellsort.pl6
sub op (Any $a, Any $b) { #`(Sub|287108521) ... } 0..100
use of uninitialized value of type Any in string context  in sub op at shellsort.pl6:2

use of uninitialized value of type Any in string context  in sub op at shellsort.pl6:2

use of uninitialized value of type Any in string context  in sub op at shellsort.pl6:2

99,98,97,96,95,94,93,92,91,90,9,89,88,87,86,85,84,83,82,81,80,8,79,78,77,76,75,74,73,72,71,70,7,69,68,67,66,65,64,63,62,61,60,6,59,58,57,56,55,54,53,52,51,50,5,49,48,47,46,45,44,43,42,41,40,4,39,38,37,36,35,34,33,32,31,30,3,29,28,27,26,25,24,23,22,21,20,2,19,18,17,16,15,14,13,12,11,100,10,1,0
$

とりあえず動いた!!!
- まだ解らない亊
  - サブルーチンシグネチャの使い方
  - shift,unshift,pop,pushとか
  - ワンライナで";"が必要な亊

my ($f,$h,@x); 
say join  ',',ssrt ( anon sub op ($a1,$b1) { $a1 gt $b1 } , (0..10));
  
sub swap (@x1) {
  my ($j,$h) = @x1;
  loop ( ; $j>=$h ; $j-=$h ) {
     return 0 if $f.(@x[$j-$h], @x[$j]);
     @x[$j-$h,$j] = @x[ $j,$j-$h];
  }
} 
sub loop1 ($h) {
  loop (my $i=$h ; $i < +@x ; $i++) {
    swap ($i,$h);
  }
}
sub ssrt ( @x1 ){
  ($f,@x) = (@x1);
  my int $h=1;
  loop ( ;$h < (@x / 9) ; $h=$h*3+1 ) { };
  loop ( ;$h > 0 ; $h=Int($h/3) ) { 
    loop1 ( $h );
  } 
  return @x;
} 
=begin END
perl6 -e 'my ($f,$h,@x); sub swap (@x1) { my ($j,$h) = @x1; loop ( ; $j>=$h ; $j-=$h ) { return 0 if $f.(@x[$j-$h], @x[$j]); @x[$j-$h,$j] = @x[ $j,$j-$h]; } } ;sub loop1 ($h) { loop (my $i=$h ; $i < +@x ; $i++) { swap ($i,$h); } } ;sub ssrt ( @x1 ){ ($f,@x) = (@x1); my int $h=1; loop ( ;$h < (@x / 9) ; $h=$h*3+1 ) { }; loop ( ;$h > 0 ; $h=Int($h/3) ) { loop1 ( $h ); } ;return @x; };say join  ",",ssrt ( anon sub op ($a1,$b1) { $a1 gt $b1 } , (0..10));'

$ perl6 shellsort.pl6
9,8,7,6,5,4,3,2,10,1,0
$

http://outer-inside.blogspot.jp/2011/02/perl-5-to-6.html?m=1 参照 - john (2015年06月29日 11時41分43秒)

3の倍数でfoo、5の倍数でbazと数える

編集

$ perl6 -e 'say map {($_%3??""!!"foo") ~ ($_%5??""!!"baz") or $_},1..31'
1 2 foo 4 baz foo 7 8 foo baz 11 foo 13 14 foobaz 16 17 foo 19 baz foo 22 23 foo baz 26 foo 28 29 foobaz 31
$

正規表現で素因数分解

編集

遅い…

$ perl6 -e 'sub f($x){my @ans =();my $N= "o"x$x;my $s;loop (;$N ~~ /^(oo+?)$0+$/;$N ~~ s:g/$s/o/) {$s=$0;push(@ans,chars($s));};push(@ans,chars($N)); join("x",@ans);} ;say f(10920);'
2x2x2x3x5x7x13
$

http://d.hatena.ne.jp/perlcodesample/touch/20150210/1423530354 - john (2015年07月10日 12時31分49秒)

無精・短気・傲慢

2015-05-30

再帰(recursion)

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

最初の一歩　等差数列の和（1から１０までの合計を求める。）

編集

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; #（最初の数＋最後の数）×（全体の個数）÷２
}
say f(1,10)

考え方

（最初の数＋最後の数）×（全体の個数）÷２
 (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つの数を除算し余りが０になるまで繰り返すと最大公約数が求められる。これをユークリッドの互除法（ユークリッドのごじょほう、英: Euclidean Algorithm）と言うらしい。

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

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

sub gcd{
  $_[1] ? gcd($_[1],$_[0]%$_[1])   # 引数２、引数２と引数１の余りで再計算する
        : $_[0];                   # 引数２が０（余り無し）の場合は引数１が解である
}
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つ目の要素をセーブ（大小判断用）
    $b=$_[1]->[0];                      # 配列２の1つ目の要素をセーブ（大小判断用）
    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])])        # 配列を分割しマージする
           : @_                         # 配列の要素が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)){        # 間隔が１になるまで間隔を狭めていく
    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

2015-05-16

アルゴリズム(algorithm)

再帰(recursion)などでONELINERで書ける物を集めてみる

1～10までを足す

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

・1回で計算出来ればその方が良いに決まっている

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

2つの数字の最大公約数

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

3の倍数で'foo',5の倍数で'baz'と1から30まで数える

perl -E 'map{say $_%15?$_%5?$_%3?$_:"baz":"foo":"foobaz"}(1..30)'

perl -E 'say +(foo)[$_%3] . (baz)[$_%5]||$_ for 1..30 '

4段のハノイの塔を積む

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

5つのソート

・クイックソート

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)'

・マージソート

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)'

・挿入ソート

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)'

・・再帰の排除

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)'

・シェルソート

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)'

・やっぱり組み込みのソートは早い

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]);'

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});}'

フィボナッチ数列

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

・計算量が多いので計算した値を再利用する

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)'

・こっちの方が正しいか

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

指数が整数のべき乗

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)'

素因数分解

【デモ】

$ perl -E 'my @a;sub f{my ($x,$y)=@_[0,1];if ($y > sqrt($x)){return push(@a,$x);}if($x%$y){f($x,$y+1);}else{push(@a,$y);f($x/$y,$y)}} f(pop,2);say join "x",@a' 102
2x3x17
$ 
$ perl -E 'sub f{$x=pop;@a=();for($y=2;$y**$y<=$x;){$x%$y?$y++:{push(@a,$y),$x/=$y}}push(@a,$x);@a}say join "x",f(pop)' 102
2x3x17
$

正規表現で素因数分解

$ perl -E 'sub f{my $x=shift;my @ans =();my $N=('o' x $x);for(;$N=~/^(oo+?)\1+$/;$N=~s/$1/o/g){push(@ans,length($1));}push(@ans,length($N)); join("x",@ans);} say f(102);'
2x3x17
$

すぎゃーんメモより

75文字とはすごい!!

$ perl -e'print$b,($a/=$b)-1?"*":$/while$b=(grep{not$a%$_}1..($a||=pop))[1]' 60
2*2*3*5

モンテカルロ法で円周率を求めるワンライナーすぎちゃんめもより

$ perl -E 'for (1..pop) {rand()**2+rand()**2 <=1 &&$x++; /^1[0]+$/ && say $_,",",$x*4/$_}' 1000000
10,3.2
100,3.16
1000,3.164
10000,3.154
100000,3.13716
1000000,3.142384
10000000,3.1422264
$ perl -E 'for (1..pop) {rand()**2+rand()**2 <=1 &&$x++; /^1[0]+$/ && say $_,",",$x*4/$_}' 1000000
10,2.8
100,3.24
1000,3.22
10000,3.1776
100000,3.15128
1000000,3.141972
10000000,3.1414164
$

C言語で数値計算（２）モンテカルロ法による円周率算出（近似計算）より

一辺の長さが1の正方形の中にランダムに点を打つ。
この正方形の左下の点(0,0)を中心とする半径1の扇形の面積がπ/4である事を考えると、n個のランダムな点のうちm個が扇形の中に入っているとするとm:n≒π/4:1になるはずである。
つまりπ=4xm/nと計算できる。

for $i (1 .. pop){rand()     ** 2 + rand()    ** 2  <= 1 && $x++;　$i=~/^1[0]+$/ && say "$i,@{[ $x * 4 / $i]}"}' 10000000
                  |----| X座標      |----| Y座標                                                                 -------- 実行回数
                  |-------------------------------------| 三平方の定理で扇形の中を判断        |---------| π = 4 x m / n (πを求める)

ずんどこきよし

$ perl -lE 'while($x !~ /ずんずんずんずんドコ$/) {say $y= rand()*10%2?"ずん":"ドコ";$x.=$y} say "きよし"'
ずん
ずん
ずん
ドコ
ずん
ずん
ずん
ずん
ずん
ドコ
きよし
$

その他

ワンライナーで書けないので別ページへ

2015-05-15

無精・短気・傲慢

無精(Laziness)

エネルギーの総支出を減らすために、多大な努力をするように、あなたをかりたてる性質。こうして労力を省くために書いたプログラムは他人も使うようになり、そのプログラムに関する質門にいちいち答えずに済むようにドキュメントを書くようになる。それゆえ、プログラマにとって最も重要な資質である。

短気(Impatience)

コンピュータがサボっているときに感じる怒り。あなたの命令に反応するだけでなく、実際に指令を予測する -- あるいは、少なくともそのようなふりをする -- プログラムを書く原動力になる。それゆえに、プログラマにとって２番目に重要な資質である。

傲慢(Hubris)

ゼウスの怒りにふれるほど、プライドが高いこと。また、他人にケチを付けられないようなプログラムを書く（そして維持する）ための原動力になるもの。それゆえ、プログラマにとって３番目に重要な素質である。

飛び出せperl6

使い方

[factor.pl]

array etc..

hash etc..

tertiary operator

perl5 vs perl6

正規表現で素因数分解する

「ラブ・ストーリーは突然に」

ubuntuにセットアップ

shell sort

3の倍数でfoo、5の倍数でbazと数える

正規表現で素因数分解

最初の一歩 等差数列の和（1から１０までの合計を求める。）

最大公約数を求める

ハノイの塔を積む

ソート処理

挿入ソート

perlの組み込みソート

バイナリーサーチ

指数が整数のべき乗

1～10までを足す

2つの数字の最大公約数

3の倍数で'foo',5の倍数で'baz'と1から30まで数える

4段のハノイの塔を積む

5つのソート

バイナリーサーチ

指数が整数のべき乗

モンテカルロ法で円周率を求めるワンライナー すぎちゃんめもより

ずんどこきよし

その他

無精(Laziness)

短気(Impatience)

傲慢(Hubris)

最初の一歩　等差数列の和（1から１０までの合計を求める。）

モンテカルロ法で円周率を求めるワンライナーすぎちゃんめもより