Jul 28, 2011
IRCダイスボットへの道 - ダイス目や修正値を集計してみる
Perl で IRCダイスボットへの道第三回は、ダイスの目や修正値を集計してみます。
Perlモジュールの Parse::RecDescent を使ってダイスコマンド文字列をパースして無名ハッシュのリファレンスに収め、Data::Transformer を使ってそのままの状態でダイスだけ転がしてみました。乱数には Perl の標準関数 の rand ではなく、Math::Random::MT を使ってメルセンヌ・ツイスタを利用しています。前回との違いは、集計用のサブルーチンを追加して集計結果を表示させてる部分だけです。
diceroll.pl
#!/usr/bin/env perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Transformer;
use Math::Random::MT;
use Data::Dumper;
my $grammar = <<'GRAMMER';
expression: add end { { left => $item[1] } }
add: mult '+' add { { left => $item[1], op => '+', right => $item[3] } }
add: mult '-' add { { left => $item[1], op => '-', right => $item[3] } }
add: mult
mult: brack '*' mult { { left => $item[1], op => '*', right => $item[3] } }
mult: brack
brack: '(' add ')' { $item[2] }
brack: val
val: /[1-9]\d?d(?:100|20|12|10|8|6|4|2)/i
val: /\d{1,2}/
end: /\s*$/
GRAMMER
my $parser = Parse::RecDescent->new( $grammar ) or die 'Bad grammar';
my $text = $ARGV[0];
my $result = $parser->expression( $text ) or die 'Bad text';
my $seed = time ^ $$;
my $gen = Math::Random::MT->new($seed);
my $roll = Data::Transformer->new(
normal => sub {
my $val = shift;
if ( $$val =~ /^([1-9]\d?)d(100|20|12|10|8|6|4|2)$/i ) {
my ( $dice_counts, $dice_planes ) = ( $1, $2 );
my $dices;
while ( $dice_counts ) {
my $a_dice = int $gen->rand( $dice_planes ) + 1;
$dices += $a_dice;
$dice_counts--;
}
$$val = $dices;
}
},
);
$roll->traverse( $result );
local $Data::Dumper::Sortkeys = 1;
my $d = Data::Dumper->new( [ $result->{ left } ] );
print $d->Dump;
print &gathering( $result->{ left } ), "\n";
sub gathering {
my $val = shift;
if ( ref $val ) {
if ( $val->{ op } =~ /\+/ ) {
&gathering( $val->{ left } ) + &gathering( $val->{ right } );
}
elsif ( $val->{ op } =~ /-/ ) {
&gathering( $val->{ left } ) - &gathering( $val->{ right } );
}
else {
&gathering( $val->{ left } ) * &gathering( $val->{ right } );
}
}
else {
$val;
}
}
$ ./diceroll.pl "(1d8+3d6+1d100-2)*2"
$VAR1 = {
'left' => {
'left' => 3,
'op' => '+',
'right' => {
'left' => 11,
'op' => '+',
'right' => {
'left' => 20,
'op' => '-',
'right' => '2'
}
}
},
'op' => '*',
'right' => '2'
};
64
なんとなく強引な気はしますけども、これで一応ローカルダイスが完成した事にしてしまいます。
Jul 27, 2011
IRCダイスボットへの道 - ダイスを転がしてみる
Perl で IRCダイスボットへの道第二回は、ダイスを転がしてみます。
Perlモジュールの Parse::RecDescent を使ってダイスコマンド文字列をパースして無名ハッシュのリファレンスに収め、Data::Transformer を使ってそのままの状態でダイスだけ転がしてみました。乱数には Perl の標準関数 の rand ではなく、Math::Random::MT を使ってメルセンヌ・ツイスタを利用しています。
diceroll.pl
#!/usr/bin/env perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Transformer;
use Math::Random::MT;
use Data::Dumper;
my $grammar = <<'GRAMMER';
expression: add end { { left => $item[1] } }
add: mult '+' add { { left => $item[1], op => '+', right => $item[3] } }
add: mult '-' add { { left => $item[1], op => '-', right => $item[3] } }
add: mult
mult: brack '*' mult { { left => $item[1], op => '*', right => $item[3] } }
mult: brack
brack: '(' add ')' { $item[2] }
brack: val
val: /[1-9]\d?d(?:100|20|12|10|8|6|4|2)/i
val: /\d{1,2}/
end: /\s*$/
GRAMMER
my $parser = Parse::RecDescent->new( $grammar ) or die 'Bad grammar';
my $text = $ARGV[0];
my $result = $parser->expression( $text ) or die 'Bad text';
my $seed = time ^ $$;
my $gen = Math::Random::MT->new($seed);
my $roll = Data::Transformer->new(
normal => sub {
my $val = shift;
if ( $$val =~ /^([1-9]\d?)d(100|20|12|10|8|6|4|2)$/i ) {
my ( $dice_counts, $dice_planes ) = ( $1, $2 );
my $dices;
while ( $dice_counts ) {
my $a_dice = int $gen->rand( $dice_planes ) + 1;
$dices += $a_dice;
$dice_counts--;
}
$$val = $dices;
}
},
);
$roll->traverse( $result );
local $Data::Dumper::Sortkeys = 1;
my $d = Data::Dumper->new( [ $result ] );
print $d->Dump;
$ ./diceroll.pl "(1d8+3d6+1d100-2)*2"
$VAR1 = {
'left' => {
'left' => {
'left' => 2,
'op' => '+',
'right' => {
'left' => 15,
'op' => '+',
'right' => {
'left' => 42,
'op' => '-',
'right' => '2'
}
}
},
'op' => '*',
'right' => '2'
}
};
あとはハッシュリファレンスの深い順に op の演算子で合算していけば良いんだけど、要素をスマートに取り出す方法がパッとは思いつかなくて、とりあえず無理矢理こんな感じでダイスを転がしてみました。
Jul 26, 2011
IRCダイスボットへの道 - ダイスコマンドをパースする
Perl をはじめたての頃に IRCダイスボットを書いていたのですけども、その後の HDDクラッシュで影も形も無くなってしまいました。既にボーンズ＆カーズという高機能な IRCダイスボットが公開されている事だし、一から作り直すのも面倒でそのまま放置していたのですけども、最近なんとなく自分専用にシンプルな IRCダイスボットを作ってみたくなりました。
- ダイスコマンド文字列のパーサを書く
- パーサ組み込んだローカルダイスツールを作る
- ローカルダイスツールを IRCボットに組み込む
という手順で作ってみる予定です。
Perlモジュールの Parse::RecDescent を使ってダイスコマンド文字列のパーサを書くとこんな感じになります。
diceparser.pl
#!/usr/bin/env perl
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;
my $grammar = <<'GRAMMER';
expression: add end { $item[1] }
add: val '+' add { { left => $item[1], op => '+', right => $item[3] } }
add: val '-' add { { left => $item[1], op => '-', right => $item[3] } }
add: val
val: /[1-9]\d?d(?:100|20|12|10|8|6|4|2)/i
val: /\d{1,2}/
end: /\s*$/
GRAMMER
my $parser = Parse::RecDescent->new( $grammar ) or die 'Bad grammar';
my $text = $ARGV[0];
my $result = $parser->expression( $text ) or die 'Bad text';
local $Data::Dumper::Sortkeys = 1;
my $d = Data::Dumper->new( [ $result ] );
print $d->Dump;
$ ./diceparser.pl 1d8+1d6+1d100-2
$VAR1 = {
'left' => '1d8',
'op' => '+',
'right' => {
'left' => '1d6',
'op' => '+',
'right' => {
'left' => '1d100',
'op' => '-',
'right' => '2'
}
}
};
と、それぞれのダイスと修正値、演算子が無名ハッシュへのリファレンスに収まります。便利べんり！次回はこれを取り出してダイスをロールし結果を表示するローカルダイスツールを作ってみようと思います。
Jul 24, 2011
さよならアナロ熊
今日の正午に地上波アナログ放送が停止しました。
NHK総合を地上波アナログで観ていたのですけども、停止寸前に最後に手を振ったどーもくんがアナロ熊に見えて仕方がありませんでした。
単純なぽちは、やっぱり感傷的になってしまいます。
Jul 09, 2011
りゅうたまでゲームマスターをする？
ぽちはたまにりゅうたまという TRPG をプレイヤーとして遊んでいるのですけども、今回オンラインセッションで GM をやろうと決心して、セッションの狂言回し的なりゅうたまの独特の GM専用キャラ「竜人」を作ってみました。
黒竜：タイヴァ
化身：梟
外見：漆黒の瞳と髪の子供
性格：わがままでいたずら好き、子供特有の無邪気な残酷さも
使命：旅人が知恵を振り絞って困難を切り抜ける物語を紡ぐ
居住界：漆黒の森に沈む黒檀の東屋
レベル：1 ライフポイント：3
アーティファクト：
短剣（セッション中一度だけ NPC一人を無条件で死亡させる事が出来る）
銘：『背後の一突き』
作った竜人の傾向から分かるかもしれませんけども、ありがちなハック＆スラッシュではないシナリオを作って行きたいな、なんて野望に燃えています。
GM経験なんてほとんど無いのにイキナリ高望みして大丈夫、ぽち？
Jul 07, 2011
ぽちたて 0.1.7 をリリースしました
今夜は七夕なのにぽち地元は天気が悪く、天の川は見えそうになくてちょっと残念ですけども、ぽちたて 0.1.7 をリリースしました。
昨日、CLI の twitterクライアントを書いていて、ぽちたてではホームディレクトリを取得するのに環境変数を直接使っていた事に気がつきました。これでは Windows環境だと、環境変数を改めて自分で設定するひと手間が必要になり、そのままぽちたてを動かす事は出来ません。そこで 0.1.7 では、File::HomeDir を使ってもっとポータビリティに配慮してみました。UNIX/Linux環境でぽちたてを使われている場合には、0.1.6 のままでも実用上全く問題ありませんけども、0.1.7 の方がほんの少しだけお行儀が良いかもしれません。
Jul 06, 2011
Net::Twitter::Lite で tweetするよ
twitter を始めた勢いに任せて、
を参考にして、Perl で Net::Twitter::Lite を使った CLI の twitterクライアントアプリケーションを作ってみました。
pochitwi.pl
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Encode;
use Try::Tiny;
use Net::Twitter::Lite;
use Time::Piece;
use YAML;
use File::HomeDir;
use Path::Class;
use HTML::TreeBuilder::XPath;
use Getopt::Std;
my $yaml = file( File::HomeDir->my_home, '.pochitwi.yml' );
my $conf = YAML::LoadFile( $yaml ) or die "$yaml: $!";
my $enc = $conf->{ encoding };
my $nt = Net::Twitter::Lite->new(
consumer_key => $conf->{ consumer }{ key },
consumer_secret => $conf->{ consumer }{ secret },
ssl => 1,
);
$nt->access_token( $conf->{ access }{ token } );
$nt->access_token_secret( $conf->{ access }{ token_secret } );
my %opts;
getopts("n:t:" => \%opts);
if ( defined $opts{ n } ) {
$opts{ n } =~ /^\d{1,2}$/
or die encode( $enc, "受け取れない件数ですよ？: $opts{ n }" );
}
if ( defined $opts{ t } ) {
$opts{ t } =~ /^\d{17,}$/
or die encode( $enc, "受け取れないステータスID ですよ？: $opts{ t }" );
}
unless ( $ARGV[0] ) {
&get_twitter;
}
else {
my $text = $ARGV[0];
$text = decode( $enc, $text );
my $length = length $text;
$length <= 140
or die encode( $enc, "つぶやけるのは 140字以下ですよ？: $length" );
&post_twitter( $text, $opts{ t } );
}
sub get_twitter {
my $ht;
try {
$ht = $nt->home_timeline( { count => $opts{ n } } );
}
catch {
warn $_;
};
foreach my $line ( @{ $ht } ) {
print $line->{ user }->{ screen_name }, ' ',
encode( $enc, $line->{ user }->{ name } ), ' : ',
'(', $line->{ id }, ')',
encode( $enc, $line->{ text } ), ' ',
&to_jst( $line->{ created_at } ), ' ',
'via ', encode( $enc, &delete_html_tag( $line->{ source } ) ),
"\n";
}
}
sub post_twitter {
my ( $text, $reply_to ) = @_;
unless ( $reply_to ) {
try { $nt->update( { status => $text } ); } catch { warn $_; };
}
else {
try {
$nt->update( { status => $text,
in_reply_to_status_id => $reply_to,
} );
}
catch {
warn $_;
};
}
}
sub to_jst {
my $twitter_dt = shift;
my $t = Time::Piece->strptime( $twitter_dt, '%a %b %d %T %z %Y' );
$t += 60 * 60 * 9;
$t->datetime . '+09:00';
}
sub delete_html_tag {
my $source = shift;
my $tree = HTML::TreeBuilder::XPath->new;
$tree->parse_content( $source );
if ( my ( $node ) = $tree->findnodes( '//a' ) ) {
return $node->as_text;
}
else {
return $source;
}
$tree->delete;
}
このコードとは別に .pochitwi.yml というファイル名でホームディレクトリ直下に、こんな設定ファイルを用意します。
encoding: utf8
consumer:
key: Consumer key
secret: Consumer secret
access:
token: Access Token
token_secret: Access Token Secret
utf8 は、日本語環境の文字コードに合わせて適宜変更します。また、Consumer key、Consumer secret、Access Token、Access Token Secret は、dev.twitter.com で Twitter API を使うアプリケーションの登録を済ませて入手します。
Pure Perl で書かれた YAML を使ってるせいか遅いですけども、そこは移植性を考慮して我慢がまん。
$ ./pochitwi.pl
とすると、下の出力例のような形式で、ホームのタイムラインから最新の 20件のつぶやきを表示します。
inuyamapochimar 犬山ぽち丸 : (87846235523919872)@konafi 壁の穴が心配デス 2011-07-04T20:32:29+09:00 via ぽちつい
出力する件数を指定するには -n オプションを使います。60件表示したい場合はこうします。
$ ./pochitwi.pl -n 60
つぶやくには、
$ ./pochitwi.pl '昨日快晴だったのに今日は大豪雨！？'
誰かのつぶやきに返信するには、-t オプションで返信を付けたい対象のつぶやきの ID を指定してつぶやきます。
$ ./pochitwi.pl -t 87845668449828864 '@konafi 昨日今日と随分涼しくなりましたよ〜？'
コード量のわりにシンプル過ぎる機能しかありませんけども、ぽちもまだ twitter を始めたばかりで凝った使い方が出来るわけじゃありませんので、今のところははこんな感じでも充分間に合っていたりします。
Jun 27, 2011
twitter 始めました
タイトル通り、今更感満載ですけども twitter のアカウントを作って twitter を始めてみました。アカウントは犬山ぽち丸@inuyamapochimarです。字数制限で ID の読みが「いぬやまぽちまる」ではなく「いぬやまぽちまー」になってるのは許してやって下さいませ。まだ何一つ tweet してませんけども、twitter でもどうぞよろしくお願いします。
Jun 20, 2011
ぽちたて 0.1.6 をリリースしました
今まで、コマンドライン引き数に読み込むファイルを与えて起動した時は、ファイル内容の文字コード判定に失敗したり取り扱えないファイルだったりすると、きちんとエラーを表示して die 出来てたのですけども、ファイル選択ダイアログで読み込むファイルを与えた場合にエラーが発生すると、ファイル選択ダイアログのウィンドウがフリーズしてしまうバグがありました。そんなに変なファイルは読まないだろうとそのままにしていたのですけども、最近はぽち以外にも実際に使って下さってる方がいらっしゃいますので、大慌てできちんとエラー処理を施したぽちたて 0.1.6 をリリースしました。
実際に使って下さってる方がいると、ぽちたて作りにも張り合いが出ます。[犬]ω＜)ノ☆
Jun 09, 2011
Perlモジュールの作り方
こないだ勉強がてら、テストファーストでオブジェクト指向の Perlモジュールを書いて、その過程（？）をニコニコ動画に置いていたのですけれども、今日、その修正版を投稿しました。
『仕様を落とし込んだテストを先に書いてから、そのテストを通過するようにモジュールを書いていく』という流れを紹介するのが目的の動画なので、Perl のリファレンスやオブジェクト、モジュールについての基礎的な知識を前提にした不親切な動画になってしまいました。とはいえ、たまにはこんなのがあっても良いですよね？
May 30, 2011
最近読んだ本：Perl CPANモジュールガイド
先週、YouTube で Perl関係の動画をつらつら眺めていたら、こんな動画を見つけました。
この動画を観てなんとなく勢いで購入してしまいましたけども、ここで紹介されている Perl CPANモジュールガイドは、最近の定番モジュールの解説書です。最近の Perl について書かれた本だと、少し前にモダンPerl入門という本がありました。このモダンPerl入門、内容はとても充実している良書なのですが、とてもイキナリ初心者に読ませるような本ではありません。今までこの Perl CPANモジュールガイドのように、最近の Perl について書かれた初心者向けの本は無かったので貴重なんじゃないでしょうか？動画では cpanm について言及されていますけども、cpanm だけじゃなく perlbrew の解説もあります。きちんとこの二つのツールの解説があるのは、今から Perl本体や CPANモジュール をインストールして学ぶ方に大きな助けになると思います。この本は、初めてのPerl 第5版や続・初めてのPerl 改訂版の副読本にちょうど良いんじゃないでしょうか？
しかし、読んでると自分がいかに CAPN の便利なモジュールを使いこなしていないのかが分かって本当にヘコみます。
May 29, 2011
Open JTalk の Mei (Normal)用コマンドオプションを変更
以前ぽち＊ぷ〜ちの Open JTalk で音声合成して日本語テキスト読み上げに debian squeeze で Open JTalk を導入して音声合成をする方法を書いていましたけども、HTSボイスに Mei (Normal) を使った場合だとコマンドオプションが良くなくてあまり綺麗な声には出来ませんでした。ところが以前ニコニコ動画にアップした Open JTalk音声合成動画のコメントで、Mei (Normal) がもっとずっと綺麗な声になるオプション例を公開している、
というサイトを教えていただきました。早速そのオプションを取り入れて音声合成してみた結果がこちらです。
まだまだ Open JTalk のデモサイトの調整には及びませんけども、ちょっとびっくりするくらいに綺麗になりました。
May 12, 2011
指輪物語を読み返してみた
なんとなく思い立って十数年前に図書館で読んだ指輪物語を読み返してみる気になり、評論社の文庫版を買って読み始めてしまいました。
以前読んだ時からお気に入りキャラはトム・ボンバディルとボロミアです。トムの老荘の隠君子じみた自由闊達なところや、ボロミアの率直で人間臭いところを読むと、やっぱりこの二人はとっても大好き。映画ではトムの登場するストーリーが丸ごとごっそり割愛されていたり、ボロミアがニコニコ動画の MikuMikuDance動画でネタキャラとして扱われてるのがとっても悔しくてなりません。誰ですか、好みの振れ幅が両極端に開き過ぎてるなんて言ってるのは[犬]ω＜#)ノ！？
まだ読み返し始めてようやく半分ぐらいなのですけども、本文中の旅歩きの描写で、普段インドアなぽちも山歩きとか徒歩の旅に出たくなってしまいました。煙草が大嫌いなぽちがジッポライター必要かな？とか、ツールナイフは便利そうかな？とか、コンパスも欲しいね？とか、アウトドア用品を物色しているなんて異常事態が起きていたり…。と、最近はこんな有様なので、SDL Perl でのゲーム作りや、ぽちたて作りは完全に停滞しています。
May 06, 2011
Perl で素因数分解
先日、ニコニコ生放送で C や Lua などのプログラミング言語を使ってプロジェクト・オイラーの問題を解くのを配信している初心者の方がいました。三問目で躓いて悩んでらっしゃったのを観て、うっかり触発されて、その問題を Perl で解いてみようかな？なんて気になってしまいました。
The prime factors of 13195 are 5, 7, 13 and 29. What is the largest prime factor of the number 600851475143 ?
これは、600851475143 の素因数のうちの最大数を求める問題です。
下のコードは、600851475143 を小さい順に 2 から 600851475143 の平方根以下までの範囲の整数で割っていって、割り切れたら再帰的にまたその商を同じ手順でひたすらどんどん割り続け、最後に割り切れた商を最大の素因数として表示します。
#!/usr/bin/perl
use strict;
use warnings;
print &largest_prime_factor( 600851475143 ), "\n";
sub largest_prime_factor {
my $n = shift;
for ( my $i = 2; $i <= int sqrt $n; $i++ ) {
return &largest_prime_factor( $n / $i ) if $n % $i == 0;
}
return $n;
}
その後、素因数分解のアルゴリズムを調べてみたら、もっとスマートな方法がたくさんあるようです。正規表現のパターンマッチを使って素因数分解しちゃうという、いかにも Perl ならではの方法まであったり…。
May 03, 2011
ぽちたて 0.1.5 をリリースしました
ファイルタイプの判別に File::MMagic を使うようにした、ぽちたて 0.1.5 をリリースしました。
バージョンアップするほどの変更ではないかもしれませんが、とりあえず 0.1.4 よりは安全性は高くなった気がします。
