Jul 29, 2011
IRCダイスボットへの道 - IRCボットにローカルダイスを組み込んでみる
Perl で IRCダイスボットへの道第四回は、第三回のローカルダイスを IRCボットに組み込んでみます。
ローカルダイスは、Perlモジュールの Parse::RecDescent を使ってダイスコマンド文字列をパースして無名ハッシュのリファレンスに収め、Data::Transformer を使ってそのままの状態でダイスだけ転がした後、ハッシュリファレンスから値を取り出して集計しています。ロールの乱数には Perl の標準関数 の rand ではなく、メルセンヌ・ツイスタを使った Math::Random::MT を利用しています。今回 IRCボットに組み込むに当たっては、POE::Component::IRC を使ってみました。
simpledicebot.pl
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Encode;
use POE;
use POE::Component::IRC::State;
use POE::Component::IRC::Plugin::AutoJoin;
use Parse::RecDescent;
use Data::Transformer;
use Math::Random::MT;
my $irc_server = 'irc.trpg.net'; # 利用する IRCサーバ
my $room = '#ぽち小屋'; # IRC で入るチャンネル名
my $name = 'dice_smp'; # IRC でのダイスボットの名前
my $encoding = 'iso-2022-jp'; # 大抵これで OK、駄目な場合は utf-8 に変更
my $e = find_encoding( $encoding );
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|30|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 $seed = time ^ $$;
my $gen = Math::Random::MT->new($seed);
POE::Session->create(
package_states => [
main => [ qw/ _start irc_public / ]
]
);
$poe_kernel->run();
sub _start {
my $irc = POE::Component::IRC::State->spawn(
Nick => $name,
Server => $irc_server,
);
$irc->plugin_add( 'AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new(
Channels => [ $e->encode( $room ) ]
));
$irc->yield( register => 'join' );
$irc->yield( 'connect' );
}
sub irc_public {
my ( $sender, $who, $where, $what ) = @_[SENDER, ARG0, ARG1, ARG2];
my $nick = ( split /!/, $who )[0];
my $channel = $where->[0];
my $irc = $sender->get_heap();
if ( $what =~ /^\(?[1-9]\d?d(?:100|30|20|12|10|8|6|4|2)/i ) {
my $result = &dice( $what );
defined $result
and $irc->yield( privmsg => $channel => "$nick: $result" );
}
return;
}
sub dice {
my $arg = $e->decode( $_[0] );
my @args = split /\s+/, $arg;
my $text = shift @args;
my $data = $parser->expression( $text ) or return;
my $roll = Data::Transformer->new(
normal => sub {
my $val = shift;
if ( $$val =~ /^([1-9]\d?)d(100|30|20|12|10|8|6|4|2)$/i ) {
my ( $counts, $planes ) = ( $1, $2 );
my $dices;
while ( $counts ) {
my $a_dice = int $gen->rand( $planes ) + 1;
$dices += $a_dice;
$counts--;
}
$$val = $dices;
}
},
);
$roll->traverse( $data );
if ( !@args ) {
return &gathering( $data->{ left } );
}
else {
my $comments;
foreach ( @args ) {
$comments = $comments . "$_ ";
}
chop $comments;
return &gathering( $data->{ left }) . ' ' . $e->encode( $comments );
}
}
sub gathering {
my $val = shift;
if ( ref $val ) {
if ( $val->{ op } =~ /\+/ ) {
return &gathering( $val->{ left } ) + &gathering( $val->{ right } );
}
elsif ( $val->{ op } =~ /-/ ) {
return &gathering( $val->{ left } ) - &gathering( $val->{ right } );
}
else {
return &gathering( $val->{ left } ) * &gathering( $val->{ right } );
}
}
else {
return $val;
}
}
コマンドライン操作の
$ ./simpledicebot.pl
で、設定した IRCサーバの設定したチャンネルに接続します。接続を終える時は、実行中に Ctrl + c で停止させるか、実行したターミナルエミュレータのウィンドウを閉じて停止させます。
同じチャンネルに接続した IRCクライアントから
>pochi< (1d8+3d6+1d100-2)*2
と発言すると、
<dice_smp> pochi: 158
のようにロールの結果を合計して返してくれます。ダイスコマンドの後に半角または全角スペースを挟むと、それ以後はダイスロールについてのコメントとして、ロール結果と一緒に再び表示されます。
>pochi< 1d100 SANチェック <dice_smp> pochi: 75 SANチェック
とてもシンプルではありますけども、なんとかまた IRCダイスボットをでっちあげる事が出来ました。
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 を始めたばかりで凝った使い方が出来るわけじゃありませんので、今のところははこんな感じでも充分間に合っていたりします。
