ぽち＊ろぐ

IRCダイスボットへの道 - POE から AnyEvent へ

Perl で IRCダイスボットへの道第六回は、第四回・第五回と IRCサーバに接続するのに使っていた POE::Component::IRC を AnyEvent::IRC に置き換えます。

今回 POE::Component::IRC から AnyEvent::IRC に置き換えるのは、どどんとふにも使われている IRCダイスボットボーンズ＆カーズを書かれた Facelessさんに、「POE はあんまり信用出来なくて……」と言われたから、なんてわけでもありません。

実は Perl界隈では POE は以前から、妙にこんがらがり過ぎてコードが難読化してウザイとか、独特の書き方をしないといけないのがウザイとか、評判が良くありませんでした。POE は Perl Obfuscation Engine や Portal Of Evil の略だなんて言われたりもしています。ぽちがずっと前に最初の IRCダイスボットを書いた時に POE::Component::IRC を使ったのは、その時の選択肢には Net::IRC か POE::Component::IRC ぐらいしか見当たらず、Net::IRC を使った IRCダイスボットは既に書いている方がいたから、というごくごく単純な理由からでした。

今はそんな二択じゃないし、今書くのなら評判良さげなのを使っちゃえば良いじゃない！！

というわけで、なんとなく評判の良さげな気がする AnyEvent::IRC に置き換えちゃいます。

simpledicebot.pl

2012年 5月31日追記：irc.cre.jp系IRCサーバ群の文字コードが ISO-2022-JP から UTF-8 に変更された為、初期設定例の接続先IRCサーバの文字コードを UTF-8 に変更しました。

2012年 6月 6日追記：ダイスコマンドの引き数の個数に制限を加えました。

#!/usr/bin/env perl

use strict;
use warnings;
use utf8;
use Encode;
use AnyEvent;
use AnyEvent::IRC::Client;
use Parse::RecDescent;
use Data::Transformer;
use Math::Random::MT;

my $irc_server = 'localhost';   # 接続先IRCサーバ
my $room       = '#犬小屋';     # 接続先チャンネル
my $name       = 'dice_smpl';   # IRCサーバでのダイスボット名
my $encoding   = 'utf8';        # 接続先IRCサーバの文字コード

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(?:120|100|60|30|24|20|16|12|10|8|6|4|3|2)/i
val: /\d{1,2}/
end: /\s*$/
GRAMMER

my $parser = Parse::RecDescent->new( $grammar ) or die 'Bad grammar';

my $seed = time ^ ( $$ + ( $$ << 15 ) );
my $gen  = Math::Random::MT->new( $seed );

my $c = AnyEvent->condvar;
my $irc = AnyEvent::IRC::Client->new;

$irc->reg_cb(
    irc_privmsg => sub {
	my ($self, $msg) = @_;
	if ( $msg->{ params }->[-1] =~ /^\(?[1-9]\d?d(?:120|100|60|30|24|20|16|12|10|8|6|4|3|2)/i ) {
	    my $result = dice( $msg->{ params }->[-1] );
	    $msg->{ prefix } =~/^(.*)!/;
	    defined $result
		and $irc->send_chan( $e->encode( $room ), 'PRIVMSG', $e->encode( $room ), "$1: $result" );
	}
    }
);

$irc->reg_cb (
    connect => sub {
	my ( $irc, $err ) = @_;
	defined $err and print "Couldn't connect to server: $err\n";
    },
    registered => sub {
	my ( $self ) = @_;
	print "registered\n";
	$irc->enable_ping( 60 );
    },
    disconnect => sub {
	print "disconnected: $_[1]\n";
    }
);

$irc->send_srv( 'JOIN', $e->encode( $room ) );

$irc->connect(
    $irc_server,
    6667,
    { nick => $name, user => $name, real => $name },
);

$c->wait;

sub dice {
    my @results;
    my @comments;
    my @args = split /\s+/, $e->decode( $_[0] );

    scalar( @args ) > 15 and return;

    foreach ( @args ) {
        if ( my $parsed = $parser->expression( $_ ) ) {
            my $dt =  Data::Transformer->new( normal => \&roll );
            $dt->traverse( $parsed );
            push @results, gathering( $parsed->{ left } );
        }
        elsif ( @results ) {
            push @comments, $_;
        }
        else {
            return;
        }
    }

    if ( !@comments ) {
        return join ' ', @results;
    }
    else {
        my $comment;
        foreach ( @comments ) {
            $comment = $comment . "$_ ";
        }
        chop $comment;
        return ( join ' ', @results )  . ' ' . $e->encode( $comment );
    }
}

sub roll {
    my $val = shift;
    if ( $$val =~ /^([1-9]\d?)d(120|100|60|30|24|20|16|12|10|8|6|4|3|2)$/i ) {
        my $dices;
        my ( $counts, $planes ) = ( $1, $2 );
        while ( $counts ) {
            my $a_dice = int $gen->rand( $planes ) + 1;
            $dices += $a_dice;
            $counts--;
        }
        $$val = $dices;
    }
    undef;
}

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サーバの設定したチャンネルに接続します。接続先IRCサーバや接続先チャンネル、IRCサーバでのダイスボット名は適切に書き換えて使って下さい。接続を終える時は、実行中に Ctrl + c で停止させるか、実行したターミナルエミュレータのウィンドウを閉じて停止させます。

同じチャンネルに接続した IRCクライアントから

>pochi< (1d8+3d6+1d100-2)*2

と発言すると、

<dice_smpl> pochi: 158

のようにロールの結果を合計して返してくれます。ダイスコマンドの後に半角または全角スペースを挟むと、それ以後はダイスロールについてのコメントとして、ロール結果と一緒に再び表示されます。

>pochi< 1d100 SANチェック
<dice_smpl> pochi: 75 SANチェック

ダイスロールの内訳が必要な場合には、演算子の代わりに半角スペースを空けてダイスコマンドを発言してあげるとこんな感じになります。

>pochi< 1d8 1d6 1d10 1d100
<dice_smpl> pochi: 4 3 9 45

>pochi< (1D8+3D6+1D100-2)*2 1d8+1d6+2 1D100-20
<dice_smpl> pochi: 192 11 35