ブログが続かないわけ

この日記のはてなブックマーク数
Webエンジニアが思うこと by junichiro on Facebook

ECCUBE の売上集計をメールで通知する

このエントリーを含むはてなブックマーク hateb

ECCUBE で売上集計、毎日見ていますか?

ネットショップをメインで運用する方は、そりゃあ毎日のように管理画面にアクセスすると思うのです。ところが、売上集計のような数値は、運用担当の方よりもっと上層の方々が知りたい数字だったりします。そういう人たちは管理画面にログインして数字を見るのが億劫だということも、ままあります。それを解消するために、メールで売上集計を自動通知するスクリプトを作りました。

飽きもせず、またスクレイピングです。

しかも、ECCUBE というPHP を使う人たちを前提としているツールを前にして、Perl での実装です。ニーズもへったくれもありませんが、やったことだけでも記しておこうと思います。

---
cookie: lwpcookies.txt
from_email: test@en.yummy.stripper.jp
to_email: mymail@en.yummy.stripper.jp
subject: テストショップレポート
uri: https://www.example.com/admin/index.php
id: eccube_login_id
password: eccube_login_password
設定のyaml はこんな感じです。
use strict;
use warnings;
use WWW::Mechanize;
use Web::Scraper;
use HTTP::Cookies;
use Email::Sender::Simple 'sendmail';
use Email::MIME;
use Email::MIME::Creator;
use Encode qw/encode decode from_to/;
use Time::Piece;
use YAML;
use utf8;

my $config_file = $ARGV[0] || 'config/shop.yaml';
my $config = YAML::LoadFile($config_file);

my $cookie = HTTP::Cookies->new( file => $config->{cookie}, autosave => 1 );
my $mech = WWW::Mechanize->new();
$mech->cookie_jar($cookie);
$mech->agent_alias('Mac Safari');

# login
$mech->get( $config->{uri} );
$mech->form_number(1);
$mech->field( login_id => $config->{id} );
$mech->field( password => $config->{password} );
$mech->click();

$mech->follow_link( url_regex => qr/admin¥/total/ );
$mech->form_name('search_form1');

$mech->field( mode                => 'search' );
$mech->field( form                => '1' );
$mech->field( search_startyear_m  => 2011 );
$mech->field( search_startmonth_m => 6 );
$mech->click_button( name => 'subm' );

my $items = scraper {
    process 'td', 'data[]' => 'TEXT';
};
my $scraper = scraper {
    process 'tr.fs12', 'result[]' => $items;
};
my $res = $scraper->scrape( $mech->content, $mech->uri );
my ( $formatted_res, $body );
for ( @{ $res->{result} } ) {
    $formatted_res .= sprintf( "%s%s% 5s%s% 8s¥n",
        $_->{data}[0], "¥t", $_->{data}[1], "¥t", $_->{data}[8] );
}
for ( @{ $res->{result} } ) {
    $_->{data}[1] =~ s/件//msgx;
    $_->{data}[8] =~ s/[円¥,]//msgx;
}

$body .= $formatted_res;

my $mail = Email::MIME->create(
    header => [
        From    => $config->{from_email},
        To      => $config->{to_email},
        Subject => encode( 'MIME-Header-ISO_2022_JP' => $config->{subject} ),
    ],
    attributes => {
        content_type => 'text/plain',
        charset      => 'ISO-2022-JP',
        encoding     => '7bit',
    },
    body => encode( 'iso-2022-jp' => $body ),
);
sendmail($mail);

読み返してみると、何月分のレポートを取得するかとかがハードコードされててひどいですね。でもまあ、このくらいはいい感じに書きかえるなりして、参考にして頂ければ幸いです。基本は、「Amazon アフィリエイトのレポートをメールで自動で受けとる 2011年版」と同じで、Mech で売上集計を表示するところまでたどって、そこのHTML を丸ごとWeb::Scraper に渡すというだけです。

参考にした書籍はもちろん「Perl CPANモジュールガイド 」。

繰り返しになりますが、この1冊があれば、Perl でやりたいことのほとんどは実現できるのではないでしょうか。本当におすすめです。

Net::POP3 でサーバ上にあるメールを一括削除

このエントリーを含むはてなブックマーク hateb

会社のアカウントのメールは全部Gmail に転送しているつもりなのですが、なぜか転送されずにもとのメールサーバに残り続けてしまうものがあります。もしかしたらスパムと判定されたものは、転送すらしない仕様なのかもしれません。

いままでは定期的になにか適当なメーラーで受信して、サーバのものを削除していたのですが、結構無駄な作業に思えてきていましたので、Net::POP3 を使って一括で削除することにしました。

#!/usr/bin/perl
use strict;
use warnings;
use Net::POP3;

my $args = {
    pop3 => 'pop.example.com',
    user => 'yourname',
    pass => 'yourpass',
};

my $mbox = Net::POP3->new( $args->{pop3} ) or die 'Connection failed.';
$mbox->login( $args->{user}, $args->{pass} ) or die 'Login failed.';
my ($index) = $mbox->popstat;
$index-- while ( my $msg = $mbox->delete($index) );

参考にした書籍はもちろん「Perl CPANモジュールガイド」。

この1冊があれば、Perl でやりたいことのほとんどは実現できるのではないでしょうか。本当におすすめです。

Web::Scraper を使ってURL からtitle を含んだ a タグを作成する

このエントリーを含むはてなブックマーク hateb

タイトルの通りです。先日、Emacs でブログを書くときの補助ツールとして、URL から「タイトル付きのa タグを生成する」方法を紹介しました。そのときは、LWP 系が動かないというわけのわからないトラブルがあったため、WWW::Curl を使ったのですが、もともとはURI::Title を使っていました。

[参考] URI::Title が動かなくなったので代替手段を探った | ブログが続かないわけ

スクレイピングをするときにはいつでも問題になる文字コードですが、それはここでも例外ではありませんでした。そこで、文字コードの問題を内部的に解決できていて、かついろいろとつぶしが効くWeb::Scraper を使ったほうがいいと教えて頂いたので、それを使うことにしました。

Twitter / トミール: @jun_ichiro URITitleを覚えておく ...

@jun_ichiro URITitleを覚えておくくらいならW:Scraper覚えておいた方がつぶしがきくとか、lwpベースならdecoded_contentが自動判別ルーチンを持ってるから(EncodeGuessという大失敗作使う必要ない)とか色々言いたいので本を買うように!

Web::Scraper はもともと結構使っていたので、あっという間にできました。

標準入力からURI を受けつけて、a タグを標準出力に吐きだすだけです。

Web::Scraper 版にするときについでに、複数行のURL を処理できるように修正しました。

これ、ホントに便利なので、使用イメージを伝えたいと思い、7秒ほどの動画を作りました。埋め込みじゃなくて申し訳ないのですが、是非ご覧ください。

Emacs でURL から a タグに変換する動画

Web::Scraper の使い方は下記を参考にしてください。

Amazon アフィリエイトのレポートをメールで自動で受けとる 2011年版

このエントリーを含むはてなブックマーク hateb

Amazon のアフィリエイトのレポートは毎回ログインしないと見れないのがわずらわしいです。僕のブログなんてどうせ、という気分で頑張ってログインすると、だいたい、ほんとになにもありません。デイリーレポートなんて存在意義すらわからないです。レポート対象期間を長めに設定して見なおして、過去の実績で溜飲を下げるという無駄な時間を過ごすのもいいかもしれません。ですが、それもむなしくなると、もうログインもしなくなっちゃいます。

でも、これじゃダメですよね。向こうからレポートが自動で送りつけられてくれば、見るクセもつくだろうという目論見のもと、たしか誰かそういうことやってたよな、ってのを思い出しまして、探してみました。

Amazon アフィリエイトレポート: blog.bulknews.net
これはmiyagawa さんのやつですね。当時見たのはこれかもしれないけど、さすたに7年も前の記事なので、アマゾンのアフィリエイトページのデザインもこの頃とはだいぶ変わっていて、そのままは使えません。

しげふみメモ : PlaggerでAmazonアソシエイトレポートをGmailへ送る
それからこれ。Plagger です。かっこいいですね。手元の環境にはPlagger を入れていなかったのですが、Plagger を入れるってのもなんだかおおげさ過ぎます。それに、もし入れてから、動かなかったらへこみます。

というわけで、前者のを参考に2011年版として新たに作りました。

なにこれ...
なんでこんな長くなるの。
僕が書くとどうして、こうなっちゃうの。教えて!

しかも届くレポートは見づらいので、ちゃんと見たいときはExcel とかNumbers にコピペするといいと思います。僕は送信先のメールアドレスをEvernote にして蓄積しています。

レポートの種類は @reportType の配列で取捨選択できます。また、期間も $preSelected で指定できます。使える選択肢はコメントで入れておきました。

どうでもいいことですが叫びます。
Scraping 好きだ!
WWW::Mechanize チューしたい!

こんなのはこの本を読むだけですぐできちゃいます。

もっと本格的なScraping をするなら、Web::Scraper を使うのもおすすめです。
Web::Scraper 使い方(超入門) | ブログが続かないわけ

URI::Title が動かなくなったので代替手段を探った

このエントリーを含むはてなブックマーク hateb

Emacs でブログを書くときの補助ツールとして、選択したurl をそのページのタイトルつきで、リンクのタグに変換するPerlスクリプトを使っていたのですが、いつからか動かなくなってしまっていました。

ちなみに、Lisp がわからなくても選択範囲に対してPerl などを実行するのは結構簡単にできます。
[参考] Lisp はわからないけどEmacs で選択範囲に対してごにょごにょしたい

話が少しそれてしまいましたが、状況をよくよく確認してみると、LWP系がまったく動かなくなってしまっていました。なぜだかわからないのですが、原因究明から逃げて、なんとか代替手段を手にいれました。WWW::Curl でお茶を濁すということです。まったくモダンな感じがしないうえに、文字コードの変換もいまさらこんなのを書いていいものか不安です。とにかく目的は達成できましたし、なんでもさらしたほうがいいってことなので、あげておきます。

いろいろと叩いてください。こころ優しいかたは、Twitter のDM とかで教えてくださっても構わないですよ!

Perl 忘れてる!

2011/02/25 追記
気がついたらまた動くようになっていたので、原因不明。別件でWWW::Mechanize を入れたタイミングで直ったっぽいのですが、詳細は不明のままです。

[Perl][JavaScript]JavaScript とPerl で○×ゲームを作った

このエントリーを含むはてなブックマーク hateb
OpenSocial とかで遊ぶためにもJavaScript は必須で、いままで避けて通ろうとしていたのが、そろそろそうは行かなくなってきた。そのため、今月はmixi hackathon もあることだし、それまでにしっかりとJavaScript を身につけるため、js 特訓月とした。

今日は、そのトレーニングの一環として、○×ゲーム(英名: TicTacToe)を作った。
【こちらで遊べます→】TicTacToe

tictactoe.html
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<link rel="stylesheet" href="css/tictactoe.css">
<script src="lib/jquery/jquery-1.3.2.min.js" type="text/javascript"></script>
<script src="lib/tictactoe.js" type="text/javascript"></script>
<title>JavaScript Training (TicTacToe)</title>
</head>
<body>
<h1>TicTacToe</h1>
<div id="field"></div>
<div id="result"></div>
<div id="retry"></div>
</body>
</html>

HTML にはプレースホルダーとなるdiv をいくつか書いただけで、あとはjs で書くことにした。

lib/tictactoe.js
if( typeof( window.TicTacToe ) == "undefined") {

// TicTacToe コンストラクタ
var TicTacToe = function() { return this; };

// Version
TicTacToe.VERSION = '0.01';

// TicTacToe オブジェクトのプロパティ
TicTacToe.prototype.cgiurl = 'tictactoe.cgi';
TicTacToe.prototype.result = '#result';
TicTacToe.prototype.level = '1000';
TicTacToe.prototype.data = [
0, 0, 0,
0, 0, 0,
0, 0, 0,
];
TicTacToe.prototype.lock = '0';

TicTacToe.prototype.init = function ( arg ) {
var __this = this;
__this.data = [0, 0, 0, 0, 0, 0, 0, 0, 0]
$('#result').empty();
$('#retry').empty();
__this.display();
}

TicTacToe.prototype.event_init = function( arg ) {
var __this = this;
$("table.game-field tr td").mouseover(function(e) {
__this.mouseover(e);
});
$("table.game-field tr td").mouseout(function(e) {
__this.clear_color(e);
});
$("table.game-field tr td").click(function(e) {
if( __this.lock == '0' ) {
__this.hit(e);
__this.lock = '1';
}
});
}

// 着手計算結果
TicTacToe.prototype.expr = function ( arg ) {
// CGI に渡すパラメータオブジェクトを生成
var param = {
q: arg,
l: this.level,
// debug: '1'
};
// コールバック関数無いではthis が使えないのでコピー
var __this = this;
// JSON データを受取るコールバック関数
var func = function ( data ) {
// alert( data.debug );
__this.data = data.field;
__this.display( data.field );
$(__this.result).text(data.result);
if( data.status != '0' ) __this.finish( data.status );
__this.lock = '0';
};
// CGI を呼び出して、JSON データを受取る
jQuery.getJSON( this.cgiurl, param, func );
}

TicTacToe.prototype.mouseover = function ( arg ) {
var obj = jQuery(arg.currentTarget);
var txt = obj.text();
if(txt == '') {
obj.css('cursor', 'pointer');
obj.css('background-color', '#FFE7A1');
}
else {
obj.css('cursor', 'no-drop');
}
}

TicTacToe.prototype.clear_color = function ( arg ) {
var obj = jQuery(arg.currentTarget);
obj.css('background-color', '#FFFFFF');
}

TicTacToe.prototype.hit = function ( arg ) {
var td = arg.currentTarget;
if(td.textContent != '') return;
var data = this.data;
var sub = td.id.split('-')[1];
data[sub] = 1;
this.data = data;
this.display( data );
this.expr( data );
}

TicTacToe.prototype.display = function ( arg ) {
$('#field').empty();

var data;
if( arg && arg.length == 9 ) {
data = arg;
}
else {
data = this.data;
}

var field = document.getElementById('field');
var div = document.createElement('div');
var tab = document.createElement('table');
tab.setAttribute('class', 'game-field');

var tr = new Array();
var td = new Array();
for ( var i=0; i<3; i++) {
tr[i] = document.createElement('tr');
for ( var j=0; j<3; j++) {
var sub = i*3+j;
var text;
if(data[sub] == '1') {
text = document.createTextNode('○');
}
else if(data[sub] == '2') {
text = document.createTextNode('×');
}
else {
text = document.createTextNode('');
}
td[j] = document.createElement('td');
td[j].id = 'id-'+sub;
td[j].appendChild(text);
tr[i].appendChild(td[j]);
}
tab.appendChild(tr[i]);
}

div.appendChild(tab);
field.appendChild(div);
this.event_init();
}

TicTacToe.prototype.finish = function( status ) {
var __this = this;
var color = {1: '#DDDDFF', 2: '#FFDDDD', 3: '#DDDDDD'};
$("table.game-field tr td").unbind();
$("table.game-field tr td").css('background-color', color[status]);

var btn = document.createElement('input');
btn.type = 'button';
btn.value = 'リトライ';
jQuery(btn).click(function(e) {
__this.init();
});
var retry = document.getElementById('retry');
retry.appendChild(btn);
}

}

// main
$(document).ready(function(){
var ttt = new TicTacToe();
ttt.init();
});

サーバサイドは、以前モンテカルロ法の調査をしているときに作ったAI で○×ゲームのcomp 側を実装した。
tictactoe.cgi
#!/usr/bin/perl
use strict;
use warnings;
use Data::Dumper;
use CGI;
use JSON;
use Games::TicTacToe;

my $out = {};
my $cgi = CGI->new();
my @data = $cgi->param('q');
my $level = $cgi->param('l') || '200';

# debug
$cgi->param('debug') and $out->{debug} = Dumper(¥@data);

# initialize
scalar(@data) != 9 and @data = qw/0 0 0 0 0 0 0 0 0/;

# output header
print $cgi->header( -type => 'text/plain', -charset => 'utf-8' );

# calculate
my $ttt = Games::TicTacToe->new(@data);
&is_finished($ttt, $out);
if ( $out->{status} eq '0' ) {
my $result = $ttt->is_finished();
$ttt->level($level);
my $score = $ttt->calc_next_matrix();
my $next_location = $ttt->next_location($score);
$data[$next_location] = $ttt->player;
$ttt->hit($next_location);
&is_finished( $ttt, $out );
}

# response
$out->{field} = ¥@data;

# output json
print JSON::objToJson($out), "¥n";

sub is_finished {
my ($ttt, $out) = @_;
my $result;
if ( $result = $ttt->is_finished() ) {
my %res = ( '1' => 'You win!', '2' => 'You lose...', '3' => 'Draw' );
$out->{result} = $res{$result};
$out->{status} = $result;
}
else {
$out->{result} = '';
$out->{status} = '0';
}
return $out;
}

Games::TicTacToe の中身はgithub にあげてある。
junichiro's games-tictactoe at master - GitHub

[Perl]Regexp::Assemble を使って連想配列のキーに正規表現を使う

このエントリーを含むはてなブックマーク hateb
連想配列のキーに正規表現を使いたくなることってあるじゃない。
my @strings = qw/
カナダ
インド
イギリス
ニッポン
ルーマニア
チュウゴク
イタリア
スペイン
ウクライナ
アルゼンチン
アメリカ
/;
こんな配列があるとする。これをア行、カ行...などにグループ分けして、例えば次のような出力を得たい場合を例にしてみよう。
カ行: カナダ
ア行: インド
ア行: イギリス
ナ行: ニッポン
ラ行: ルーマニア
タ行: チュウゴク
ア行: イタリア
サ行: スペイン
ア行: ウクライナ
ア行: アルゼンチン
ア行: アメリカ

一番すぐ思いつきそうなのが次のコードかもしれない。
for my $str (@strings) {
print &grouping($str), ": $str¥n";
}

sub grouping {
return 'ア行' if(m/^[ア-オ]/);
return 'カ行' if(m/^[カ-コ]/);
return 'サ行' if(m/^[サ-ソ]/);
return 'タ行' if(m/^[タ-ト]/);
return 'ナ行' if(m/^[ナ-ノ]/);
return 'ハ行' if(m/^[ハ-ホ]/);
return 'マ行' if(m/^[マ-モ]/);
return 'ヤ行' if(m/^[ヤ-ヨ]/);
return 'ラ行' if(m/^[ラ-ロ]/);
return 'ワ行' if(m/^[ワ-ン]/);
}
これでももちろん問題ない。if で分岐させるのがあまり好きでない方は、これを連想配列で処理したいと考えるかもしれない。その場合、まず、それぞれの行にマッピングするために、正規表現をキーとした、下記のような連想配列を用意する必要がある。
my %map = (
qr/^[ア-オ]/ => 'ア行',
qr/^[カ-コ]/ => 'カ行',
qr/^[サ-ソ]/ => 'サ行',
qr/^[タ-ト]/ => 'タ行',
qr/^[ナ-ノ]/ => 'ナ行',
qr/^[ハ-ホ]/ => 'ハ行',
qr/^[マ-モ]/ => 'マ行',
qr/^[ヤ-ヨ]/ => 'ヤ行',
qr/^[ラ-ロ]/ => 'ラ行',
qr/^[ワ-ン]/ => 'ワ行',
);

もちろん、このままでは例えば $map{カナダ} としてもカ行が返されるわけではない。そのため、連想配列のキーにあたる正規表現にマッチするかをチェックして、マッチしたらその値を返すというような処理が必要になる。例えば、下記のようなコードになるだろうか。
STR: for my $str (@strings) {
for my $regexp (keys %map) {
$str =~ $regexp and print $map{$regexp} and next STR;
}
}

ここで、Regexp::Assemble を使うと、もっと直感的な書き方ができる。
my $re = Regexp::Assemble->new->track->add(keys %map);
for my $str (@strings) {
$re->match($str) and print $map{$re->matched}, ": $str¥n";
}

この例では、Regexp::Assemble の良さがあまり伝わらないかもしれないが、ディスパッチテーブル等を使って、連想配列の値にコードリファレンスを持つような場合、その連想配列のキーを正規表現でも記述できるというのは、結構便利かもしれない。

詳細はPERL HACKS に載ってるので、興味のある方はご覧下さい。
chromatic, Damian Conway, Curtis "Ovid" Poe, 株式会社ロングテール/長尾 高弘 ¥ 3,150
Perl Hacker になるための一冊
アイディア本

JPA セミナー #1 に行ってきた

このエントリーを含むはてなブックマーク hateb

はじめに

以前は勉強会に行った後は、遅ればせながらもまとめエントリを書いていたんだけど、最近はセミナー中に走り書きしたものをまとめるというモチベーションがわかなくて、ついついほったらかしになってしまっていた。ほったらかしにするくらいなら、まとめないまでもその走り書きをそのままアップする方がまだマシじゃないかと思って、今日はそれをそのままあげてみる。ほとんど断片的なもので、自分用の備忘録とか今後のTODO みたいなものになってしまっているので、あまり参考にならないかもしれない。

Better Perl Practice(JShirely)

  • テストはゴールではない
  • API 設計からはじめる

  • バージョンコントロールの使い方には精通した方がいい

    • branch を使うとかは少しでも早く身に付けるべき
  • 大事なのは

    • 設計 - テスト - リファクタリング
    • (リファクタリングは後ではなく、その場で)
  • これを習慣化

    • 大変だと思わせない
    • 正しいことはしやすく
    • 間違ったことはしづらく
  • スモークサーバを社内に用意するのはどうか

    • 1時間程度でできるんじゃない?

※スモークサーバとはCPAN のようなモジュールをアップしてテストを共有できるような環境?

  • module だけでなくPerl のコミュニティのテスト体制等はCPAN の財産のひとつ

  • テストの仕方

    • スキーマクラス
    • SQLite
    • Unit Test
    • アプリケーション
    • Test::Class, Test::FITesque
    • ワークフローテスト
  • テストしづらいのはAPI がつかいづらいということに他ならない

    • つまり設計が悪いということ
  • ユニークである必要はない

    • 同じようなことをしようとするひとは他にもいる
    • CPAN の中を探そう
  • ベースクラスを利用しよう

MooseX::SimpleConfig

with 'MooseX::SimpleConfig';
with 'MooseX::Getopt';
has +configfile => (
default =>
(
grep { defined $_ and -f $_ }
@places_to_look
)[0] || ""
);

  • Class::MOP

    • Moose はこれのシンタックスシュガー
    • Moose = ベターAPI
  • Moose

    • まともなアクセッサ
    • 初期化コードの遅延評価
    • コードは少なく
    • テストは多く

Catalyst改

  • デバッグ

    • ?dump_info=1
  • Config は使い過ぎくらいでちょうどいい

  • Catalyst::Controller::DBIC::API

    • おすすめ
  • Chained を理解する肝

    • Action != URI
    • とにかく一度Chained を使ってみること!
  • mod_perl よりFastCGI ?

  • もしくはHTTP::Prefork ?

  • Log

    • Catalyst::Log
    • Catalyst::Log::Log4perl
    • $c->log->_dump();
  • Catalyst::Controller::ActionRole

  • Catalyst::Action::REST

  • ベースコントローラを使う

感想

Catalyst のところの話が、相当よかった。もっと入門向けの話かなと思ったら、随分と参考になった。おそらく、Jshirley にとってはこれが入門向けだったのだろう...最近は仕事の関係で、Catalyst もMoose もほとんど触っていないし、プライベートでもアルゴリズムの勉強とかOpenSocial の勉強をしているので、Perl でWebアプリを作らなくなって久しい。せっかくCatalyst 5.8 がリリースされたので、何か作ってみようか。


その他のJPAセミナ#1 に関するエントリ

[Perl][PHP]配列に値を追加するときはpush を使うけど、Perl とPHP では微妙に異なる

このエントリーを含むはてなブックマーク hateb
スタック(要は配列)の一番後ろに値を追加するのは、push という操作になる。Perl ではpush という関数があるし、PHP ではarray_push という関数がある。ところが、Perl とPHP ではこれらの関数の使い方、挙動が若干異なるので、簡単にまとめておく。push 以外の配列操作関数(pop, shift, unshift)もほとんど同じ考え方なので、これが参考になると思う。
array1: a, b, c
array2: d, e, f
こういう3つの要素を持つ、1次元の2つの配列があるとする。これらの配列を用いて、2次元の配列を作りたいときにPerl, PHP ではそれぞれどのように書けばいいのだろうか。

Perl
Perl では厳密には多次元配列を扱うことはできない。配列の要素に、配列のリファレンス(これ自体はスカラー値)を持たせることで、擬似的に多次元配列を表現する。慣れてしまえば、多次元配列を扱う感覚で、問題なく使える。さきほどの問題の解答はこうだ。
# 配列定義
my @array1 = ('a', 'b', 'c');
my @array2 = ('d', 'e', 'f');

# 2次元に連結(push を使う)
my @res;
push(@res, ¥@array1, ¥@array2);
これで@res には2次元配列が格納された。
$VAR1 = [
[
'a',
'b',
'c'
],
[
'd',
'e',
'f'
]
];
push の引数にはLIST をとることができるので、リファレンスにした@array1 と@array2 を順番に格納している。多次元配列を表現するために、リファレンスにしているところがポイントだ。

PHP
PHPは多次元配列を扱えるので、リファレンスなどを考える必要はない。こう書けば良い。
# 配列定義
$array1 = array('a', 'b', 'c');
$array2 = array('d', 'e', 'f');

# 2次元に連結(push を使う)
$res = array();
array_push($res, $array1, $array2);
array_push の引数に配列をそのまま渡していることに注意してほしい。

では、今度は最初に与えられた配列を直列に連結した下記のような配列を作りたいときはどうすればいいのだろうか。
res: a, b, c, d, e, f

Perl
Perl では簡単だ。
# 直列に連結
my @res;
push(@res, @array1, @array2);
push にあたえる引数をリファレンスにしなければ、それぞれLIST として展開されるため、これで@res は要素を6つ持つ1次元配列になる。
$VAR1 = [
'a',
'b',
'c',
'd',
'e',
'f'
];

PHP
PHPではarray_push にあたえる引数はとくに展開されたりすることはないので、array_push では実現できない。こういうことをやりたい場合は、array_merge という別の関数の力を借りる必要がある。
# 直列に連結
$res1 = array();
$res1 = array_merge($array1, $array2);
Array
(
[0] => a
[1] => b
[2] => c
[3] => d
[4] => e
[5] => f
)
array_push を使ったときの失敗例は各自で確認してみてほしい。

ちなみに、いまは説明の便宜上res という新しい変数で結果を取得しているが、もとのarray1 にarray2 を直列に連結させたければ、Perl/PHP それぞれでの書き方はこうなる。

Perl
push(@array1, @array2);

PHP
$array1 = array_merge($array1, $array2);

push は第1引数で与えられた配列に影響を与えるのに対して、array_merge では引数で与えられた変数には影響を与えず、戻り値として結果を返すというところが異なるのがわかる。Perl とPHP は「似たように書けるけど、実は結果が異なる」というものがいくつかあるので、PHP とPerl の両方を触る場合は注意しなければならない。

[Perl]クラスに同じ誕生日の子供が1組以上いる確率をImager でグラフにする

このエントリーを含むはてなブックマーク hateb
[Perl]クラスに同じ誕生日の子供が1組以上いる確率をImager でグラフにする

クラスの中に同じ誕生日の人がいる確率が、想像以上に高いというところはみんなどこかで聞いたことがあると思う。高校の確率の授業等では、計算をさせられたりすることもある。ただ、実際に手で計算してみると、電卓を使ってもかなり面倒な計算になる。これをPerl で書いてしまえばとても簡単に計算できる。

これを求めるために、簡単な計算の方針を示す。
1. クラスに同じ誕生日の子供が1組も存在しない確率を計算する
2. その逆を計算する(上記の確率を1から引く)

1. を求めるのはそんなに難しくない。
クラスの子供をひとりずつ選び出して、その子がそれまでに選んだ子供と同じ誕生日でない確率を掛け合わせていけばよい。
例えば、1人目の子は誕生日がいつでも良いので、365 / 365 となる。
2人目の子供は、1人目の子供と違う誕生日であればよいので、(365 - 1) / 365
3人目の子供は、1人目と2人目の子供と違う誕生日であればよいので、(365 - 2) / 365
以下同様に、n人目の子供の誕生日は( 365 - (n-1) ) /365 となる。

これらを掛け合わせたものが、クラスに同じ誕生日の子供が1組も存在しない確率となる。
これを1 から引けば、少なくとも1組以上の同じ誕生日の子供が存在することになる。
ここまでわかればこれをコードにすることは簡単だ

クラスの人数を$class_num とした。
sub get_propability {
my $class_num = shift;
my $p = 1;
for ( 1 .. $class_num ) {
$p = $p * ( 365 - ( $_ - 1 ) ) / 365;
}
return 1 - $p;
}
これだけでは面白くないので、クラスの人数の変化とそれに伴う確率の変化をグラフに表現してみる。グラフの描画にはImager を使う。もっとグラフをつくるためのモジュールもあるのだが、最適なものを探すのも面倒だったし、このくらいの簡単な物はImager でも直感的にかけてしまうので、今回はImager しか使わない。

■前半
#!/usr/bin/perl
use strict;
use warnings;
use Imager;

our %scale = ( x => 4, y => 3 );
our %size = (
x => 100 * $scale{x},
y => 100 * $scale{y},
);

my @dot =
map {
[
$_ * $scale{x},
$size{y} - get_propability($_) * 100 * $scale{y},
]
} ( 1 .. 100 );
write_graph(¥@dot);
まず、グラフのスケールとサイズを決める定数を定義する。これはいくつでもいいけど、適当な数値に設定してグラフが奇麗にみえるサイズにした。次に、さっきのget_propability を使ってグラフ上の点を計算して@dot という配列に格納する。Imager で作成する画像は左上が原点で、右方向にxが増加、下方向にyが増加となっているので、そのままグラフにすると都合が悪い。そのため、ちょっと計算して左下が原点、右方向にxが増加、上方向にyが増加するようにしている。得られた点の集合をwrite_graph という関数に渡して、グラフを描画している。

■write_graph
sub write_graph {
my $dot = shift;
my $img = Imager->new(
xsize => $size{x},
ysize => $size{y},
);
$img->box( filled => 1, color => 'skyblue' );
push( @$dot, [ $size{x}, $size{y} ] );
$img->polygon ( points => $dot, color => 'blue' );
$img = write_axis($img);
$img->write( file => 'tutorial.png' );
}
write_axis というのはグラフを見やすくするために、格子状の線を入れている部分だ。本題にはあまり関係ないが、参考までにソースを載せておく。

■write_axis
sub write_axis {
my $img = shift;
for ( 1 .. 9 ) {
$img->line(
color => 'black',
x1 => 10 * $scale{x} * $_,
x2 => 10 * $scale{x} * $_,
y1 => 0,
y2 => $size{y},
aa => 1,
endp => 1
);
$img->line(
color => 'black',
x1 => 0,
x2 => $size{x},
y1 => 10 * $scale{y} * $_,
y2 => 10 * $scale{y} * $_,
aa => 1,
endp => 1
);
}
return $img;
}


■結果


この図では左下が原点、右方向(x軸)がクラスの人数の増加、上方向が同じ誕生日の子がいる確率となっている。数字がふっていないのでわかりにくいが、座標の格子はx軸はクラスの人数が10人単位で引いていて、y軸は確率10%単位で引いている。クラスの人数が40人くらいのときはだいたい90% くらいになっていることがわかると思う。

僕たちが子供の頃は、中学も高校も人クラスの人数が45〜50人だったので、だいたい90%以上の確率で同じ誕生日の子がいたことになる。なるほど、数学の教科書に書いてあることは本当だ。しかし、少子化で1クラスの人数が少なくなってきている昨今では、なかなかそうとも言いがたい結果となっていることがわかる。例えば1クラスの人数が30人くらいだと70%くらいになるし、もし1クラスの人数が20人になってしまうと、40% くらいまで落ち込んでしまう。

まあ、それがどうした。といわれれば、どうもしないんだけど。