[perl] 複雑なデータ構造のvalue を一気に書き換える方法
ハッシュと配列の参照が入り交じったような複雑なデータ構造の、全value を均等に加工したかったので次の様にしてみました。
use strict; use Perl6::Say; use Data::Dumper; sub cook_hash { my ( $rh, $rf_cook ) = @_; my %tmp; for ( keys %$rh ) { if ( ref $rh->{$_} eq '' ) { $tmp{$_} = $rf_cook->( $rh->{$_} ); # ここで加工を実行 } elsif ( ref $rh->{$_} eq 'HASH' ) { $tmp{$_} = cook_hash( $rh->{$_}, $rf_cook ); } elsif ( ref $rh->{$_} eq 'ARRAY' ) { $tmp{$_} = cook_array( $rh->{$_}, $rf_cook ); } else { # SCALAR, CODE, REF, GLOB, Objects は加工しないで元の値を採用 $tmp{$_} = $rh->{$_}; } } return \%tmp; } sub cook_array { my ( $ra, $rf_cook ) = @_; my @tmp; for (@$ra) { if ( ref $_ eq '' ) { push @tmp, $rf_cook->($_); # ここで加工を実行 } elsif ( ref $_ eq 'HASH' ) { push @tmp, cook_hash( $_, $rf_cook ); } elsif ( ref $_ eq 'ARRAY' ) { push @tmp, cook_array( $_, $rf_cook ); } else { push @tmp, $_; } } return \@tmp; } my $rh_testdata = { 'a' => 1, 'b' => { 'aa' => 1, 'ab' => [ 1, 2, 3, \'test', 5 ], 'ac' => 3, }, 'c' => 3, 'd' => 4, 'e' => 5, }; # 実行 say Dumper cook_hash( $rh_testdata, sub { 'cooked' . shift } );
cook_hash とcook_array がそれぞれ再帰になっており、かつお互いに呼び合うような構造でもあり、ちょっと面白いなと思いました。
実行結果は次の通り。
perl test.pl $VAR1 = { 'e' => 'cooked5', 'c' => 'cooked3', 'a' => 'cooked1', 'b' => { 'ab' => [ 'cooked1', 'cooked2', 'cooked3', \'test', 'cooked5' ], 'ac' => 'cooked3', 'aa' => 'cooked1' }, 'd' => 'cooked4' };
意図したようにvalue が処理されています。ホクホク。
すでに似たモジュールがある気が激しくしています！
ご存知でしたらぜひ教えてくださいませ。
[vim][perl] vim でperldoc viewer なプラグインを導入する
編集中に、Foo::Bar なキーワード上でK とやるだけでperldoc が読めるようになるプラグインがあります。
perldoc.vim - #生存戦略 、それは - subtech
私は今まであまり真面目にプラグインを導入したことがなかった（入れて動けばそれでいいし、動かなければ放置!w)ので、きちんと使うために設定するにあたって、いくつかハマりどころがありました。
今日はvim のプラグイン導入初心者のために、そのメモと解決法をば。
perldoc.vim をダウンロードして、~/.vim/plugin/ 下に格納する
基本的にvim のプラグインはここに格納するだけでOK です。
そのフォルダがなければ作成しちゃいましょう。
※Windows の場合は$HOME/vimfiles/plugin になります。$HOME ってどこ？という場合は、vim から:e $HOME としてみればどのフォルダかが分かるはずです。
~/.vim/ftplugin/perl/init.vim を設定
ftplugin とは、ftp のplugin ではなくて、ファイルタイププラグインです。
ファイルの種類に応じて有効にするプラグインや設定はここに設置します。
今回はK キーを押したらperldoc.vim の機能が発動するように設定をするだけになります。
" K キーを押したらPerldoc が起動するように設定 noremap K :Perldoc<CR> " vim が認識する単語境界の文字の種類を設定 setlocal iskeyword-=/ " Perl のモジュール名全体(Foo::Bar)を単語として認識させたいため、: を追加 setlocal iskeyword+=:
私の場合、三行目の設定（: を追加）が無いとFoo::Bar 全体を認識せず、Foo だけで検索しようとしてうまく動作しませんでした。ハマりどころかと思いますので強調しておきます。
司会を担当させていただきました。
素人くさいSICP読書会からの奇縁で、Shibuya.lisp テクニカルトーク#1 に続き、先日の2009/2/28(土)、テクニカルトークの第二回でも司会を勤めさせていただきました。
そもそも司会をやることは初めてのことですので、このようなズブの素人がどのようなやり方をしたかということを今後のノウハウとしてまとめておこうと思います。
司会とは？
司会と言ってもいろいろな切り口があるので、悩むところから始まりましたが、ある時に見つけた「司会は裏方に徹すべきである」ということが大きなヒントになりました。
この時点で、地味な司会をやるという方針を固めました。
原稿を用意する
裏方に徹する司会ではアドリブなどは不要のこと、それよりもきちんと案内ができるかどうかが問題ですので、事前に原稿を用意することにしました。
これによって、当日は読むことだけに集中すればよいようになりました。
また、発表者にも原稿をお渡しすることで、どういう文脈で自分が登壇したらよいのかを知る道しるべにもなったように思います。
最終確認
- 読み方を確認する
発表者のお名前（ハンドル名）、発表のタイトルのよみがなの確認です。
タイトルについては直前に変更がないかの確認も行います。
また、海外の方の発表には特に注意を要しました。
- 会場の案内が十分であるか
ネットワークがつかえるかどうか、お手洗いの場所、飲食の自由、等、必要最低限の会場案内を行います。
歓談スペースの場所については、休憩時間毎に繰り返し案内するようにしました。
また、当日、スタッフから「○○の案内をしてほしい」とフィードバックがあった時は織り込むようにしました。
やはり事前準備ではわからないこともあります。
当日のフォロー体制
基本的に原稿を読むだけですので、不測の事態には、関係者のフォローをお願いしました。
優秀なメンバーがいるわけですから、私ができないことをフォローしていただくというのは正しいことだと思います。
はっきりと話す
私はしゃべるのが苦手で、緊張をほぐすのとマイク通りの良い声をどうしたらいいかを調べるために自分では生まれて初めてカラオケに行きました。普段歌を歌う事を絶対にしない私ですから、ものすごく緊張し、またセルフイメージにない事をやるため鬼のように恥ずかしかったです。
しかし、マイクで声を出すとこんな風に聞こえるというのが体感して分かって安心でき、あとは自宅での朗読をやりました。
声に出すと分かることがいっぱいあって、読み方の補助線を引いたものが本番で役立ちました。
また、声というものはいきなり出るのではなく、３０分くらい練習してやっと出る声があるということが分かりました。これは大きな経験になりました。
よって、当日の朝もちょっと早起きをして朝練をして望みました。本番30分前のリハーサルでは、声出しというよりも、朝あたためてきた声が出ていることを確認する事と、自分が緊張せずに読めることを自分自身に言い聞かせるため行いました。
それでも、#2 では当日書き加えた原稿が、緊張で見えなくなる（印刷した文字だけ読み上げて、大事な手書きの禁止事項がまるまる無視されてしまった）という現象も起き、なるべくなら事前準備で済ませるべきであったろうと、反省点もあります。
「LISP を使わない奴ほどLISP を語りたがる」なんて言葉に赤面してしまうような私ですが、LISP を使いこなせるようになりたい。そんなアコガレを大事に思っていますので、いつかShibuya.lisp でプレゼンできる事を夢見ています。
こんな私にも、ひとまずお役に立てる機会を作っていただいたShibuya.lisp に深く感謝です。
引数の名前を知る方法 Data::Dumper::Names
みんなの好きなprint 文デバッグに、ちょっとした悩みがあるとしたら、冗長で"こダサい" ということかもしれません。
こんな風に書いたことがあるでしょう？
print '$target: ' . "$target\n";
これを簡単にするために、専用のサブルーチンを用意してみます。
# デバッグプリント sub h(@){ map {print $_ . "\n"} @_; } # 使ってみる $target = 'test'; h $target; ＜実行結果＞ test
しかし、最初のprint 文で書いた例を再現しようとすると、依然として
h '$target: ' . "$target";
と書かなくてはいけません。
h $target;
だけで、
$target: 'test'
のように表示できるようにすることはできないのでしょうか。
そして、せっかくですから次に挙げるものがどのように表示できるかも確認してみたいと思います。
# 見たいものたち 123; # 即値 'abc'; # 即値 [1,2]; # 無名配列 {a=>1,b=>2}; # 無名ハッシュ my $s = '123'; # スカラー my @a = qw/1 2 3 4/; # 配列 my %h = qw/A 1 B 2/; # ハッシュ our $o = 'our'; # our 変数 local $l = 'local'; # local 変数 $g = 'global'; # グローバル変数 sub {}; # 無名サブルーチン sub func {'x'}; # サブルーチン
最初に結論を書いてしまうと、さすがに上に挙げたものすべてを適切に表示するのは難しいということでした。
- my 変数と、our 変数以外は名前は取れない
- my 変数と、our 変数とでは名前の取得方法が異なるので、統一的に扱うことが難しい
- （これは当たり前だが）即値、無名系は名前が取れない
しかしながら、実用上差し支えないと思われる程度には可能でした。
その扉を開くのに、yokohama.pm のみなさんのお力をお借りしました。
irc(irc.freenode.net の#yokohama.pm) で質問をさせていただいた次第です。
Devel::ArgNames
まずZIGOROu さんからは、Devel::ArgNames(http://search.cpan.org/dist/Devel-ArgNames/lib/Devel/ArgNames.pm)でした。
18:42:51 zigorou: っぽぃのが出たので
18:42:58 zigorou: 内容は良く知りません＞＜
18:54:25 nekokak: use Devel::ArgNames;
18:54:26 nekokak: sub hoge {
18:54:26 nekokak: warn 'hoge() called with arguments:'
18:54:26 nekokak: . join(", ", map { defined() ? $_ : "" } arg_names(@_) );
18:54:26 nekokak: }
18:54:26 nekokak: my $moge = 'moge';
18:54:28 nekokak: &hoge($moge, 'uhe');
18:54:30 nekokak: で
18:54:32 nekokak: できますね
18:54:35 nekokak: ＞Devel::ArgNames
18:54:50 nekokak: hoge() called with arguments:$moge,
18:54:51 nekokak: とでますた
なるほど、いけそうですね。
自分でもやってみる。
use Devel::ArgNames; my $s = '123'; # スカラー my @a = qw/1 2 3 4/; # 配列 my %h = qw/A 1 B 2/; # ハッシュ our $o = 'our'; # our 変数 local $l = 'local'; # local 変数 $g = 'global'; # グローバル変数 sub {}; # 無名サブルーチン sub func {'x'}; # サブルーチン sub test1 { warn 'test1() called with arguments:' . join(", ", map { defined() ? $_ : "<unknown>" } arg_names() ); } test1(123,'abc',[1,2],{a=>1,b=>2},$s,\$s,\@a,\%h,$o,\$o,$l,\$l,$g,\$g,sub{},&func,\&func); } ＜実行結果＞ test1() called with arguments:<unknown>, <unknown>, <unknown>, <unknown>, $s, <unknown>, <unknown>, <unknown>, $o, <unknown>, <unknown>, <unknown>, <unknown>, <unknown>, <unknown>, <unknown>, <unknown> at test.pl line 14.
Devel::ArgNames は、確かに$s や$o の名前が取れているものの、（実用性としてはこれでもいいと思う）
その他ではちょっと寂しい感じになりました。
PadWalker(http://fleur.hio.jp/perldoc/mix/lib/PadWalker.mix.html)
18:46:38 kazeburo____: Padwalker？
18:46:45 nekokak: PadWalker ですね
18:52:36 bonnu: $args{var_name(1, \$_)} = $_ for @_ とかで一覧になりそうですね。PadWalker
PadWalker も、ドキュメントを読みながら試してみたのがこちら。
なお、なるべく親切な表示ができないかなと表示仕分けを試みてみています。
#!/usr/bin/perl use PadWalker qw(peek_my peek_our peek_sub closed_over var_name); my $s = '123'; # スカラー my @a = qw/1 2 3 4/; # 配列 my %h = qw/A 1 B 2/; # ハッシュ our $o = 'our'; # our 変数 local $l = 'local'; # local 変数 $g = 'global'; # グローバル変数 sub {}; # 無名サブルーチン sub func {'x'}; # サブルーチン sub test2{ for(@_){ if(ref $_ eq 'SCALAR'){ print var_name(1, $_); } elsif(ref $_ eq 'ARRAY'){ print var_name(1, $_) || "無名配列"; } elsif(ref $_ eq 'HASH'){ print var_name(1, $_) || "無名ハッシュ"; } elsif(ref $_ eq 'CODE'){ # 無名サブルーチンの場合はなぜか& が返ってくる print ((var_name(1, $_) eq '&') ? '無名サブルーチン' : "サブルーチン"); } else{ print "即値"; } print ":$_\n"; } } test2(123,'abc',[1,2],{a=>1,b=>2},$s,\$s,\@a,\%h,$o,\$o,$l,\$l,$g,\$g,sub{},&func,\&func); <実行結果> 即値:123 即値:abc 無名配列:ARRAY(0x86fb66c) 無名ハッシュ:HASH(0x86fb69c) 即値:123 # ここの変数名は取れてもいいのにな $s:SCALAR(0x868b72c) # 参照渡しだと名前が取れている @a:ARRAY(0x868b75c) %h:HASH(0x868b78c) 即値:our # ここの変数名は取れてもいいのにな :SCALAR(0x86fb2d0) # our 変数はvar_name では取れないようだ 即値:local # local, またglobal 変数の名前の取り方は無かった :SCALAR(0x86fb660) # 〃 即値:global # 〃 :SCALAR(0x86fb318) # 〃 無名サブルーチン:CODE(0x86fb5e8) 即値:x サブルーチン:CODE(0x86fb39c) # サブルーチンについても名前を取る事ができなかった
ここで使ったvar_name ではour 変数の名前がうまく取得できないようです。
our 変数の名前を取るのには専用のpeek_our があったりしますので、それを工夫して作り込めばなんとかわかるというところでしょうか。
また、local 変数、global 変数はそもそも取得できないようです。そのような機能がありませんでした。
Data::Dumper::Names
後日ZIGOROu さんがmiyagawa さんに教わったといって教えてくれたのがこれ。
use Data::Dumper::Names; my $s = '123'; # スカラー my @a = qw/1 2 3 4/; # 配列 my %h = qw/A 1 B 2/; # ハッシュ our $o = 'our'; # our 変数 local $l = 'local'; # local 変数 $g = 'global'; # グローバル変数 sub {}; # 無名サブルーチン sub func {'x'}; # サブルーチン sub test3{ print Dumper @_; } test3(123,'abc',$s,\$s,$our,\$our,$global,\$global,\@a,[1,2],\%h,{a=>1,b=>2},sub{},\&func,&func); ＜実行結果＞ $VAR1 = 123; $VAR2 = 'abc'; $VAR3 = [ 1, 2 ]; $VAR4 = { 'a' => 1, 'b' => 2 }; $s = '123'; # PadWalker の時は、ここの変数名は取れていなかった $s = \$s; @a = ( '1', '2', '3', '4' ); %h = ( 'A' => '1', 'B' => '2' ); $VAR9 = 'our'; # our 変数は残念ながら変数名は取れていない $VAR10 = \$VAR9; $VAR11 = 'local'; # local, global 変数も同様 $VAR12 = \$VAR11; $VAR13 = 'global'; $VAR14 = \$VAR13; $VAR15 = sub { "DUMMY" }; $VAR16 = 'x'; $VAR17 = sub { "DUMMY" };
PadWalker の例との違いは(表示がDump 形式であるという大きな見た目上の違いとは別に)、$s がちゃんと取れている事です。
PadWalker 版のテストでは、$s は即値として評価されていました。\$s として渡して初めて'$s' と表示されたのでした。
まとめ
さあ、まとめたいと思います。
PadWalker を使い、いろいろ作り込む事で自分好みにあった表示が作れることはtest2.pl で示しました。
その気になればour 変数も表示できるようになるはずですので、そういうものを用意するのもいいでしょう。
しかし、local 変数やglobal 変数やサブルーチンの名前など、そもそも変数名を取得できない限界があります。
それならばこそ、Data::Dumper::Names の容易さはとても大きな魅力であると思いました。
モジュール名もピンと来るもので、いいですよね。
というわけで、私はData::Dumper::Names を推します！
モンテカルロ法でサイコロ関数を検証
モンテカルロ法をご存知でしょうか？
初めての方に、ちょっとだけ私から解説をさせてください！
例えば、サイコロの目。
サイコロを振って、今出た目が３、だったとしましょう。
この時、３が出た確率は（一回しか振ってないので)100% ですが、更に何回か振ると３以外の目が出て％は下がって行きますよね。
しかし、下がるとは言っても、サイコロですからそれぞれの出目の確率は1/6。最終的には1/6…約16% に落ち着いていくはずです。
振る回数が多いほど1/6 に近くなるというところがポイントで、このように一回の出目はランダムでも、たーーくさんの回数を稼いで期待する答えを導き出すという考え方がモンテカルロ法です。
実際にこれを確かめるPerl プログラムを書いてみました。
このプログラムでは、サイコロを振る関数dicing を、何回も(ENOUGH_MANY_TO_TRY回) 振ってみて、各出目の確率が1/6 に近いか(1/6 との差が0.001 より小さいか) をテストしています。
-[dice_test.pl]--- use Test::More qw/no_plan/; use strict; use constant ENOUGH_MANY_TO_TRY => 1000000; # サイコロ関数 our @dice = qw/1 2 3 4 5 6/; sub dicing{ return $dice[ int rand @dice ]; } # テスト monte_carlo:{ my %play; for(1..ENOUGH_MANY_TO_TRY){ $play{&dicing} ++; # %play に各出目の回数を保存しておく } for(values %play){ my $delta = abs( (1/6) - ($_ / ENOUGH_MANY_TO_TRY) ); # 期待する値1/6 との差を取得 is((0.001 > $delta), 1, "1/6 の値と、出目の確率の差が僅少か？($delta)"); } } --- 実行結果 % perl dice_test.pl ok 1 - 1/6 の値と、出目の確率の差が僅少か？(0.000158666666666668) ok 2 - 1/6 の値と、出目の確率の差が僅少か？(8.33333333333242e-06) ok 3 - 1/6 の値と、出目の確率の差が僅少か？(1.23333333333364e-05) ok 4 - 1/6 の値と、出目の確率の差が僅少か？(0.00018866666666667) ok 5 - 1/6 の値と、出目の確率の差が僅少か？(0.000297666666666668) ok 6 - 1/6 の値と、出目の確率の差が僅少か？(0.000624333333333338) 1..6
まあサイコロの各出目が1/6 ということはモンテカルロ法を持ち出すまでも無く、直感レベルで分かるわけですが、円周率πを算出（これはもともとモンテカルロ法の例としては有名）するのに使ったり、破壊力のある応用も出来るわけです。
そういう応用を知ると、大胆な考え方が上手くマッチしていて実にシビレます。
モンテカルロ法の応用例
ちょっと前になりますが、2008年11月28日(金) にYokohama.pm #3 というPerl のテクニカルトークの発表会があり、その中のモンテカルロ法の話題も興奮しました。
Perl でモンテカルロ法 ?最強の○×ゲームエンジン開発?(id:jukuin2000さん)
http://en.yummy.stripper.jp/?eid=1112130
なんと、モンテカルロ法を応用してゲームのAI まで作れてしまうということなんです。
これはビックリした！
そんな興奮を、ぜひ上のBlog から、スライド資料をご覧になって味わってください。
たくさんの試行錯誤の果てに、どこかにたどり着いた。こんな味わいを、モンテカルロ法は感じさせてくれます。
「なんだよ、俺の人生みたいだな。」
ってセリフでキメる瞬間は*今*ですよ！
一次元配列同士の比較のいろいろなやり方
問題
@a = (1,2,3); @b = (1,2,3);
のような配列があったとして、これらの中身が同じ(@a = @b) であることを確認したいと思います。
細かい条件として、値は正の数字のみ(負はない、)で並び順は気にしない、かつ同じ番号はないという事にします。
かんたんに考えると、次の二つの条件を満たせればいいはずです。
- 二つの要素の数が同じであること
- 先頭から比較して、末尾までの各項目の内容が等しいこと
素直にコーディングすると...
sub is_same($$){ my($a,$b) = @_; # (1)二つの要素の数が同じであること return 0 if @$a != @$b; # (2)先頭から比較して、末尾までの内容が等しいこと for (0..$#$a){ return 0 if $a->[$_] != $b->[$_]; } return 1; }
というサブルーチンとして問題なく書けます。
しかし、こんな単純なことは単純に済ませてしまいたい。
「配列@a と@b はいっしょ？」と聞くように「@a == @b ?」のように表現してやさしくしておきたいというのが今回のモチベーションです。
いろいろなやり方
このような場合にどんなやり方があるのか、yokohama.pm のみなさんにirc(irc.freenode.net の#yokohama.pm) で素朴な疑問をぶつけてみました。
さすがに、たくさんの答えをいただきました。
その答えの紹介をするとともに、実際に具体的なやり方を調べていってみましょう!
Array::Diff
19:01:05 tomyhero: typester先生の Array::Diff ではないでしょうか
perlsh を使って調べてみましょう。
[harupiyo@localhost ~]$ perlsh main[2]$ use Array::Diff main[2]$ Array::Diff->diff([1,2,3],[1,2,3])->count 0 # 違いがない main[3]$ Array::Diff->diff([1,2,3],[1,9,3])->count 1 # 一個違う
count メソッドで違いの数が数えられますので0 であれば相違いないということになります。
List::Compare
19:14:12 nekokak: http://search.cpan.org/~jkeenan/List-Compare-0.37/lib/List/Compare.pmとかもつかえそげ（つかったことないけども
これはドキュメントがすごく大きいですね！*1
Array::Diff が軽量級とするなら、List::Compare は超ヘビー級といえます。
思わずびびってしまいますが、get_symdiff が使えそうです。
main[3]$ use List::Compare main[4]$ @a = (1,2,3); @b = (1,2,3); @c = (1,3,5); 1 3 5 main[5]$ $lc = List::Compare->new(\@a,\@b) main[8]$ $lc->get_symdiff # 違いはない main[9]$ $lc = List::Compare->new(\@a,\@c) main[10]$ $lc->get_symdiff 2 # 違いが発見された 5
is_deeply
19:02:50 typester: is_deeply \@a, \@b
こちらはTest::More のis_deeply ですね。
is_deeply は、単なる一次元配列だけでなく、配列やハッシュが入れ子になっているより複雑な構造も比較できます。
main[1]$ use Test::More qw/no_plan/ main[2]$ @a = (1,2,3); @b = (1,2,3); @c = (1,3,5); 1 3 5 main[3]$ is_deeply(\@a, \@b) ok 1 1 main[4]$ is_deeply(\@a, \@c) not ok 2 # 違う時はこんな風に怒られます # Failed test at (eval 7) line 1. # Structures begin differing at: # $got->[1] = '2' # $expected->[1] = '3' 0
eq_array
20:03:41 miyagawa: Test::More の eq_array
20:03:48 miyagawa: がまさにそれなのだがuseするとtestモードになってしまう
先ほどと同様にTest::More モジュールですが、更に適切なメソッドeq_array がありました。
ところで、確かにTest::More をuse したらtest モードになるという問題がありますね。is_deeply でも、use するときにqw/no_plan/ を指定しないとis_deeply が動いてくれないという問題でもありました。
miyagawa さんからはこの指摘の後で、require するか、use する場合でも何もインポートしないのであればtestモードにならないのでいいかなというアドバイスをいただきました。
試してみます。
[harupiyo@localhost ~]$ perlsh main[j]$ require Test::More 1 main[2]$ Test::More::eq_array([1,2,3],[1,2,3]) 1 main[3]$ exit [harupiyo@localhost ~]$ perlsh main[1]$ use Test::More main[2]$ Test::More::eq_array([1,2,3],[1,2,3]) 1 main[3]$ exit
いい感じで使えています。Test::More を使うならeq_array がいいですね。
join
19:03:23 nekokak: join(',',@aaa) eq join(',',@bbb)
19:05:48 nekokak: join("\0",@aaa) eq join("\0",@bbb)
19:05:50 nekokak: とかｗ
これは、(1,2,3) という配列を、'1,2,3' という文字列に変換して、文字列として比較しています。
配列の中身がソート済みであれば重複の要素があってもOK、イメージしやすく、簡潔でいいですね。
なお、区切り文字はカンマでなくても良いわけです。上では"\0"なんてのも指定していますし、下のように"nekokak" なんて文字列でも、あの子への淡い想いでもいいわけです。遊び心があります。
main[11]$ join('nekokak',(1,2,3)) eq join('nekokak',(1,2,3)) 1
Data::Dumper, JSON
19:07:20 kan_fushihara: Data::Dumper; Dumper(@a) eq Dumper(@b)
19:07:37 nekokak: それをいったらJSONで（ｒｙ
こちらもDumper で変数の中身を文字列にして比較しています。
Dumper は一次元配列だけでなく、複雑な構造もきちんと書き出してくれますから、上で取り上げたis_deeply の性質も併せ持っています。
同様にJSON にもto_json メソッドがあり、これを使って文字列にできますのでData::Dumper 同様の書き方ができます。
ちょっとto_json の動きを確認しておきましょう。
main[33]$ use JSON main[34]$ to_json([ 1, 2, [1,2,3], {4=>5,6=>[7,8]} ]) [1,2,[1,2,3],{"6":[7,8],"4":5}]
to_json を使えば上手くいきそうですね。
unique
19:07:10 zigorou_: Array::Utils qw(unique) で簡単に書けそう
unique は、渡された@a と@b の中から数の種類を選び出します。
main[12]$ unique(1,2,3) 1 3 2 main[13]$ unique(1,2,3,4,1,2,3) 4 1 3 2
表示される順番は変わっていますが、ちゃんとunique なものだけになっています。
で、これを使って、"@a と@b を合わせた種類の数"と、"@a の要素数" が等しくなれば良いはずです。
（重複した数字はないという条件ですので。）
よって、
scalar(unique(@a,@b)) == scalar(@a)
と書けます。
ちょっとやってみましょう。
main[55]$ @a = (1,2,3) 1 2 3 main[56]$ @b = (1,2,3) 1 2 3 main[57]$ unique(@a,@b) 1 3 2 main[58]$ scalar(@a) 3 main[59]$ scalar(unique(@a,@b)) 3 main[61]$ scalar(unique(@a,@b)) == scalar(@a) 1 # マッチした main[61]$ scalar(unique(@a,@b,9)) == scalar(@a) # マッチしない main[63]$ unique(@a,@b) == @a 1 # この書き方でもOK
難読unique
19:24:27 junichir_: CPAN 使わなければ、
19:24:30 junichir_: my %c;
19:24:30 junichir_: if (scalar( grep { ($c{$_}++ eq 1) } ( @a, @b )) eq scalar(@a) ) {
19:24:31 junichir_: }
19:24:37 junichir_: はい、カオス。
こういう難読なのも不思議度が増して好きですw
こちらも、unique と同様、ユニークなものの個数を数えるやり方です。
grep では、(@a,@b) から、ふたつある要素を抜き出しています。ふたつあるかどうかを管理するために、%c を使っています。
Array::Utils のunique もそうですがユニークなものの個数を数えるやり方は、あくまで重複がないことが保証されていて、かつ並び順は気にしなくても良い配列のみの比較しかできないということに注意してください。
おわりに
…さて、何で今回こんな配列の比較をやりたいと思ったのかと言うと、データベースに入っているデータが範囲指定した中で連続かどうか調べたいためでした。
たとえば100〜150番目のレコードが途中削除されたりせずに存在しているかどうかを調べたかったので、
@a = (100..150);
@b = (100〜150 を指定して取ってきたレコードの連番を配列にしたもの)
として、@a と@b が同じかを調べたかったというわけでした。
朝、シャワーを浴びながら「そういえばあれって…」と気づいたことがあります。
「取ってきたレコードの数が５０かどうか調べればいいんだよな。」
…厳粛な事実に、湯気のなかでｼｮﾎﾞｰﾝとしたのでした。
*1:Array::Diff に対するmiyagawa さんのレビュー (http://cpanratings.perl.org/dist/Array-Diff) にも、そのことが取り上げられています。
[SICP] 問題4.51
計算機プログラムの構造と解釈
posted with amazlet at 08.11.10
紙と鉛筆と計算機と
内容最高。翻訳
食わず嫌いでした。permanent-set! をどのように実装したらいいかを考えました。
そもそも、この元にすべきset! はどうだったのかな？
set! はch4-mceval.scm で実装されていて、評価器に組み込みの特殊形式でした。
よって、ch4-mceval.scm を参考に、次のように評価器に組み込みを開始します。
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
((quoted? exp) (analyze-quoted exp))
((variable? exp) (analyze-variable exp))
((permanent-assignment? exp) (analyze-permanent-assignment exp)) ;; これを追加！
((assignment? exp) (analyze-assignment exp))
((definition? exp) (analyze-definition exp))
((if? exp) (analyze-if exp))
((lambda? exp) (analyze-lambda exp))
((begin? exp) (analyze-sequence (begin-actions exp)))
((cond? exp) (analyze (cond->if exp)))
((let? exp) (analyze (let->combination exp))) ;**
((amb? exp) (analyze-amb exp)) ;**
((application? exp) (analyze-application exp))
(else
(error "Unknown expression type -- ANALYZE" exp))))
;; こちらも追加
(define (permanent-assignment? exp)
(tagged-list? exp 'permanent-set!))
(define (permanent-assignment-variable exp) (cadr exp))
(define (permanent-assignment-value exp) (caddr exp))この評価を実行する、analyze-permanent-assignment を定義します。
set! は失敗継続を扱うようにわざわざ工夫されたものなので、その"やり戻し" の部分を無効にしたものとして作ればよいはず。
set! の評価を実行するanalyze-assignment(P.257) を参考に、次のように作ってみました。
;; set! のanalyze-assignment （参考にする方） (define (analyze-assignment exp) (let ((var (assignment-variable exp)) (vproc (analyze (assignment-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) ; *1* (let ((old-value (lookup-variable-value var env))) (set-variable-value! var val env) (succeed 'ok (lambda () ; *2* (set-variable-value! var ;; ここでやり戻し処理を行っている old-value env) (fail2))))) fail)))) ;; 新しく用意したもの (define (analyze-permanent-assignment exp) (let ((var (permanent-assignment-variable exp)) (vproc (analyze (permanent-assignment-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (begin (set-variable-value! var val env) (succeed 'ok fail2))) ;; やり戻しをしないようにごっそり削除 fail))))
準備できた。
問題にあるコードを流してみる。
(require とan-element-of は動作に際して必要なので実際に流すコード全体は次の通りです)
(define (require p) (if (not p) (amb))) (define (an-element-of items) (require (not (null? items))) (amb (car items) (an-element-of (cdr items)))) (define count 0) (let ((x (an-element-of '(a b c))) (y (an-element-of '(a b c)))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count))
実行結果はこうなりました。
;;; Starting a new problem ;;; Amb-Eval value: (a b 2) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (a c 3) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b a 4) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b c 6) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c a 7) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c b 8) ;;; Amb-Eval input: try-again ;;; There are no more values of (let ((x (an-element-of '(a b c))) (y (an-element-of '(a b c)))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count))
うまく動いている！
続いてもう一つの問いについても答える。
「permanent-set! の代わりにset! を使ったらどうなるか？」ということだが、set! のやり戻しが発生するため、count 値がそのたびに1 に戻るはずだ。
やってみよう。
;;; Starting a new problem ;;; Amb-Eval value: (a b 1) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (a c 1) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b a 1)
できた。
