Sep 09, 2013
Perl で grep.pl
UNIX/Linux のコマンドに lv/lgrep というのがあります。ぽちは UTF-8 や CP932、EUC-JP や 7bitJIS の各日本語文字エンコーディングに跨ってテキストファイルの中身を検索するのに使っています。この lgrep を、ぽちが普段使う機能の範囲だけ、Windows上の Emacs を通して使えるように、Perl で書いてみました。
grep.pl
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Encode qw/ encode decode /;
use Encode::Guess qw/ euc-jp cp932 iso-2022-jp utf8 /;
use Encode::Locale;
use Getopt::Std;
my %opts;
getopts 'n', \%opts;
my $expr = decode 'console_in', shift @ARGV;
my @trg = map { glob } @ARGV;
for my $file ( @trg ) {
-f $file or next;
open my $fh, '<', $file or die "Couldn't open $file: $!";
my $str = join '', <$fh>;
close $fh;
$str or next;
my $encobj = Encode::Guess->guess( $str );
my $enc;
unless ( ref $encobj ) {
$enc = 'utf8';
warn "Couldn't guess: $encobj. $file is decoded by $enc.\n";
} else {
$enc = $encobj->name;
}
my @decoded = split "\n", decode $enc, $str;
my ( $i, @linum, @greped, @maped );
for my $line ( @decoded ) {
++$i;
if ( $line =~ /$expr/g ) {
push @greped, $line;
push @linum, $i;
}
}
for my $greped ( @greped ) {
my $linum = shift @linum;
if ( $#trg > 0 ) {
if ( $opts{ n } ) {
push @maped, "$file:$linum:$greped";
} else {
push @maped, "$file:$greped";
}
} else {
if ( $opts{ n } ) {
push @maped, "$linum:$greped";
} else {
push @maped, $greped;
}
}
}
my $encoded = encode 'console_out', join "\n", @maped;
print $encoded, "\n" if $encoded;
}
__END__
使い方はこんな感じ。
C¥> perl grep.pl -n 金剛 kiniro_mosaic_utf8.txt kongou_mosaic_euc-jp.txt kan_colle_cp932.txt sasebo_kaigunbochi_7bitjis.txt
kongou_mosaic_euc-jp.txt:3:英国生まれの金剛デース！！ kan_colle_cp932.txt:7:金剛 「Hi！今日も良い天気ネー！」 sasebo_kaigunbochi_7bitjis.txt:14:地元住民には海軍墓地として知られる佐世保市東公園には、金剛・加賀・飛龍・瑞鳳・大鷹・矢矧の慰霊碑が存在する。
第一引き数には正規表現を受け取るので、正規表現のメタ文字が含まれる文字列をそのままの形で検索したい場合には、メタ文字をバックスラッシュでエスケープしてあげて下さい。
Sep 03, 2013
Perl で cat.pl
UNIX/Linux のコマンドに cat というのがあって、ぽちは主にテキストファイルの中身を表示させたり、バイナリファイルを結合するのに使っています。先日、Windows上でバイナリファイルを結合しなければならなくなり、Unixコマンドの cat相当のものを Perl でざっと書いてみました。
cat.pl
#!/usr/bin/env perl
use strict;
use warnings;
binmode STDOUT;
while ( <@ARGV> ) {
open my $fh, '<', $_ or die "Couldn't open $_: $!";
binmode $fh;
print while <$fh>;
close $fh;
}
コードを見ての通りですけども、こんな感じで使います。
C¥> perl cat.pl file1 file2 file3 > catenated_file
Windows上でバイナリファイルを扱わなきゃいけないので、ファイルハンドルを通しての遣り取りでは binmode を使っています。
と、ここまでは良かったのですけども、これを書いた直後に Windows のコマンドの copy で、
C¥> copy /b file1+file2+file3 catenated_file
とバイナリファイルの結合が出来る事が発覚して、全部無意味になってしまいました……。
Nov 13, 2011
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
Oct 27, 2011
Windows の Perl でテキストファイルの文字コードを変換
2011年11月12日追記：ぽち＊ぷ〜ちのいさましいちびのツールたち unzip.pl untar.pl enc.pl に enc.pl についてもう少しだけ詳しく書きました。
父の Vista機に Strawberry Perl をインストールして Windows上で Perl を使っていると、ぽちの Linux機で書いた日本語のテキストファイルを読みたい場合があったりします。けれども、それぞれのファイルシステムで使われている日本語文字コードが異なると、文字コードを変換しないままでは文字化けしてしまう事があります。高機能なテキストエディタがインストールしてあれば、わざわざ文字コードを変換したりしなくても読めるのですが、父の Vista機にはテキストエディタはメモ帳しか入っていません。メモ帳は Windows で使われている CP932以外にも UTF-8 ならそのまま表示出来るのですけども、日本語のメールで使われている ISO-2022-JP や、古いUNIX/Linux で使われている EUC-JP は文字コードを変換しないと読めません。
ものぐさなぽちは、文字コードや改行コードを自分で指定するのがめんどくさいので、unzip.pl や untar.pl の文字コード自動推測部分を流用して、こんなのを書いて楽をしています。
enc.pl
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Encode;
use Encode::UTF8Mac; # utf-8-mac は fオプションと tオプションでしか使えません。
use Encode::Guess qw/ euc-jp cp932 iso-2022-jp utf8 /; # 自動推測の対象
use Encode::Locale;
use Path::Class;
use Getopt::Std;
my %opts;
getopts('f:t:', \%opts);
@ARGV or die "Usage: enc.pl [-f encoding_name] [-t encoding_name] text_file\n";
foreach ( @ARGV ) {
my $file = file $_;
my $reader = $file->openr or die "Couldn't open $file for reading: $!\n";
my $content = $file->slurp;
$reader->close;
rename $file, "$file.bak";
my ( $from, $to );
if ( $opts{ f } ) {
$from = $opts{ f };
} else {
my $f_obj = Encode::Guess->guess( $content );
ref $f_obj ? $from = $f_obj->name : die "Couldn't guess: $f_obj\n";
}
if ( $opts{ t } ) {
$to = $opts{ t };
} else { $to = 'locale_fs'; }
$content = encode( $to, decode( $from, $content ) );
$from =~ /cp932|iso-2022-jp/ and $content =~ s/\r\n/\n/g;
$to =~ /cp932|iso-2022-jp/ and $content =~ s/\n/\r\n/g;
my $writer = $file->openw or die "Couldn't open $file for writing: $!\n";
$writer->print( $content );
$writer->close;
}
exit;
C¥> perl enc.pl [-f エンコード名] [-t エンコード名] テキストファイル
基本的には fオプションや tオプションも無くても適切に変換します。変換前の文字コードの推測に失敗してエラーが出た時には fオプションで、変換後の文字コードをファイルシステムのロケールにしたくない場合には tオプションで文字コードを指定して下さい。
一応、Mac で使われてる UTF-8-MAC も扱えますけども、UTF-8 と UTF-8-MAC の判別が難しいので、自動推測の候補には入れていません。UTF-8-MAC を扱う場合にはオプションで指定して下さい。
Oct 22, 2011
Strawberry Perl 5.12.3.0 をインストール
2011年11月12日追記：ぽち＊ぷ〜ちのいさましいちびのツールたち unzip.pl untar.pl enc.pl に untar.pl についてもう少しだけ詳しく書きました。
Windows上で使う Perl に疎いぽちは、Perl で書いたコードを Windows上で実行可能な単独の exeファイルに纏める PAR、PAR::Packer というモジュールがある事を最近知りました。これらのモジュールは何も Windows の exe形式だけに限らず単独の実行形式ファイルを作るのに使えるのですけども、Windows上で Perl のコードから単独で実行可能な exeファイルを作るのは、Perl をインストールさせる事なく、Perl で書いたものを気軽に「これ使ってね♪」と渡せるという点ではとっても便利そうな気がします。
そこでぽちは、父が年賀状作成と孫たちの動画の保管や写真のプリントにしか使っていない、インターネット回線にさえ繋げる気が無い Windows Vista機に Strawberry Perl 5.12.3.0 を入れる許可を得て、インストールしてみました。Strawberry Perl自体は msi に纏められているので、オフラインでもぽちの Linux機でダウンロードしたものを持って来て簡単にインストール出来るのですけども、追加でインストールしたいモジュールは CPAN Search で個別に探してダウンロードして、それぞれ CPAN Dependencies で依存関係を確認しながら、必要なものから順序良く手動で入れるという作業をする事になってしまいました。
父の Vista機を回線に繋げられれば、わざわざこんな作業をしなくても cpanm なり、cpanm -f なりで済んでしまうんですけど、自分の PC じゃ無い以上「回線には繋げるな」という父の意向を無視するわけにはいきません。今時、私用の PC をスタンドアローンで使うなんていうセキュリティ確保の方法は現実的じゃない気がしますが…ぽちが言っても耳を貸してくれませんでした。
Vista機は数年前の購入時のままの状態で、Perlモジュールの圧縮形式、tar.gzファイルを展開するツールなんて入っていません。そこで入れたばっかりの Perl を利用してコマンドプロンプトから
C¥> perl -MArchive::Extract -e "$ae = Archive::Extract->new(archive => q/Path-Class-0.24.tar.gz/); $ae->extract;"
こんなふうにワンライナーで展開してみました。
これで充分用は足りるんですけども、ついでなのでぽちの unzip.pl を Archive::Tar で書き換えてこんな感じにしてみました。
untar.pl
#!/usr/bin/env perl
use strict;
use warnings;
use Archive::Tar;
use utf8;
use Encode;
use Encode::UTF8Mac; # utf-8-mac は fオプションでしか使えません。
use Encode::Guess qw/ euc-jp cp932 iso-2022-jp utf8 /; # 自動推測の対象
use Encode::Locale;
use Path::Class;
use Getopt::Std;
my %opts;
getopts('f:', \%opts);
@ARGV or die "Usage: untar.pl [-f encoding_name] tar_file\n";
foreach ( @ARGV ) {
my $file = file $_;
my $tar = Archive::Tar->new();
$tar->read( "$file" ) or die "Couldn't read: $file\n";
my $str;
$str .= $_ foreach ( $tar->list_files );
my $enc_name;
if ( $opts{ f } ) {
$enc_name = $opts{ f };
} else {
my $enc = Encode::Guess->guess( $str );
ref $enc ? $enc_name = $enc->name : die "Couldn't guess: $enc\n";
}
foreach ( $tar->list_files ) {
my $file = file( encode( 'locale_fs', decode( $enc_name, $_ ) ) );
my $dir = $file->parent;
-d $dir or dir( $dir )->mkpath;
print "extract $file ...";
$tar->extract_file( $_, "$file" );
print "done.\n";
}
}
exit;
見ての通り対象となるファイルのアーカイブ・圧縮形式が違うだけで、使い方は unzip.pl と同じです。
C¥> perl untar.pl [-f エンコード名] tarファイル
追加したモジュールですけども、文字コードが cp932 の日本語版Windows上で Encode::Locale のテストの t/env.t が通らないのは有名みたいですね。
- Bug #69256 for Encode-Locale: env.t fails on Win32
- [perl #89904] Build test FAIL on t/env.t of Encode-Locale-1.02
調べたらこんな感じだった。
env.t
> Encode::Locale::reinit("cp1252");
Windowsではコードページの変更が出来ない
> $ENV{"m\xf6ney"} = "\x80uro";
・コードページ"cp932"(日本標準)ではこの設定ができない
・なぜかPerlが落ちる
・コードページが元から"cp1252"(西欧標準)の場合は上手く行く
英語版のWindowsだと問題を把握できないかも。
とりあえずテストの失敗を無視して入れてもきちんと動いているようです。
Oct 19, 2011
Perl で unzip.pl
2011年11月12日追記：ぽち＊ぷ〜ちのいさましいちびのツールたち unzip.pl untar.pl enc.pl に unzip.pl についてもう少しだけ詳しく書きました。
UNIX/Linux で zipファイルの展開に使われる unzip という有名な展開ツールがありますが、ファイルシステムのロケールに設定された文字コードが異なる環境で作成された zipファイルで、日本語ファイル名が含まれているものを展開すると、ファイル名が文字化けしてしまいます。C で書かれた unzip のソースコードに、マルチバイト文字のファイル名に対応するパッチを当てれば文字化けしないようになるのですけども、Perl大好きなぽちはずっと以前から、狐の王国の Suganoさんが書かれた unzip.pl をもとに、ぽちが使い易いようにちまちま改造を加えたものを zipファイルの展開に使っています。最近のぽちの unzip.pl はこんな感じです。
unzip.pl
#!/usr/bin/env perl
use strict;
use warnings;
use Archive::Zip qw/ :ERROR_CODES /;
use utf8;
use Encode;
use Encode::UTF8Mac; # utf-8-mac は fオプションでしか使えません。
use Encode::Guess qw/ euc-jp cp932 iso-2022-jp utf8 /; # 自動推測の対象
use Encode::Locale;
use Path::Class;
use Getopt::Std;
my %opts;
getopts('f:', \%opts);
@ARGV or die "Usage: unzip.pl [-f encoding_name] zip_file\n";
foreach ( @ARGV ) {
my $file = file $_;
my $zip = Archive::Zip->new();
$zip->read( "$file" ) == AZ_OK or die "Couldn't read: $file\n";
my $str;
$str .= $_->fileName foreach ( $zip->members );
my $enc_name;
if ( $opts{ f } ) {
$enc_name = $opts{ f };
} else {
my $enc = Encode::Guess->guess( $str );
ref $enc ? $enc_name = $enc->name : die "Couldn't guess: $enc\n";
}
foreach ( $zip->members ) {
my $file = file( encode( 'locale_fs', decode( $enc_name, $_->fileName ) ) );
my $dir = $file->parent;
-d $dir or dir( $dir )->mkpath;
print "extract $file ...";
$zip->extractMember( $_->fileName, "$file" );
print "done.\n";
}
}
exit;
使い方は、
$ ./unzip.pl [-f エンコード名] zipファイル
基本的に fオプションは必要なく、zipファイルの中のファイル名からエンコードされている文字コードを推測して、そのファイル名をファイルシステムのロケールに合わせて変換してから展開してくれます。たまに推測に失敗する時もありますが、そんな時はエラーメッセージを見て fオプションで適切な文字コードを指定してあげます。
今 Archive::Zip の POD を読んでみたら、「展開するだけなら Archive::Zip じゃなくて Archive::Extract を使ってね？」なんて書いてありますね。けど Archive::Extractって一度展開した後でないと内容物のファイル名を取得出来ないんで、文字コードの変換をするにはちょっと不便なんですよねえ。
Aug 01, 2011
IRCダイスボットへの道 - IRCダイスボットをもう少し実用的に
Perl で IRCダイスボットへの道第五回は、第四回のシンプルな 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 @results;
my @comments;
my @args = split /\s+/, $e->decode( $_[0] );
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(100|30|20|12|10|8|6|4|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サーバの設定したチャンネルに接続します。接続を終える時は、実行中に Ctrl + c で停止させるか、実行したターミナルエミュレータのウィンドウを閉じて停止させます。
同じチャンネルに接続した IRCクライアントから
>pochi< (1d8+3d6+1d100-2)*2
と発言すると、
<dice_smp> pochi: 158
のようにロールの結果を合計して返してくれます。ダイスコマンドの後に半角または全角スペースを挟むと、それ以後はダイスロールについてのコメントとして、ロール結果と一緒に再び表示されます。
>pochi< 1d100 SANチェック <dice_smp> pochi: 75 SANチェック
ダイスロールの内訳が必要な場合には、演算子の代わりに半角スペースを空けてダイスコマンドを発言してあげるとこんな感じになります。
>pochi< 1d8 1d6 1d10 1d100 <dice_smp> pochi: 4 3 9 45
>pochi< (1D8+3D6+1D100-2)*2 1d8+1d6+2 1D100-20 <dice_smp> pochi: 192 11 35
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 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 09, 2011
Perlモジュールの作り方
こないだ勉強がてら、テストファーストでオブジェクト指向の Perlモジュールを書いて、その過程（？）をニコニコ動画に置いていたのですけれども、今日、その修正版を投稿しました。
『仕様を落とし込んだテストを先に書いてから、そのテストを通過するようにモジュールを書いていく』という流れを紹介するのが目的の動画なので、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 ならではの方法まであったり…。
Apr 28, 2011
SDL Perl をいじってみた (3)
今回はスコア表示を変更してゲームオーバー条件を付け、ゲームオーバー状態から RETURNキーを押すと最初から再スタート出来るようにしてみました。←→キーで左右の移動、qキーまたは ESCキーで終了するのは前のままです。
ライブラリは前回同様、SDL に加えて png画像の読み込みに SDL_image、truetypeフォントの読み込みに SDL_ttf を利用しています。また、Perl で使っている SDL Perl のバージョンは 2.532 です。2.2.6以前のバージョンでは動きません。残念な事に debian や ubuntu の SDL Perlパッケージ、libsdl-perl のバージョンは現時点では一番新しくても 2.2.5 なので、CPAN からインストールするしかありません。
ゲームオーバーの条件を付けた事で、だらだらとなんとなくソウルジェムを受け止めるだけの何かが、また少しだけゲームに近付いた気がします。
madoka.png と soul_gem.png
ソウルジェム以外のアイテム、例えばティーカップやきゅぅべえとかもランダムなタイミングでいくつも降らせてみたり、何かの条件を付けてまどかに矢を射させたりしてみたいのですけども、そもそもゲームの作り方を良く知らないぽちなので、実現するにはまだまだ知識が必要なようです。
教えて、ゲームのすごいひと！
#!/usr/local/bin/perl
use strict;
use warnings;
use SDL;
use SDL::Events;
use SDLx::App;
use SDLx::Rect;
use SDLx::Sprite;
use SDLx::Text;
my $error_limit = 10; # ゲームオーバーになるエラー数
# ウィンドウ全体の準備
my $app = SDLx::App->new(
width => 512,
height => 384,
title => 'Catch the Soul Gem!',
dt => 0.02,
exit_on_quit => 1,
);
# 自キャラの準備
my $player = {
rect => SDLx::Rect->new( $app->w / 2 - 16, $app->h / 5 * 4, 32, 32 ),
v_x => 0,
catch => 0,
error => 0,
};
# 自キャラ画像を入れる
my $player_character = SDLx::Sprite->new(
image => 'madoka.png', # 画像置き場へのパス
rect => $player->{rect},
);
# アイテムの準備
my $item = {
rect => SDLx::Rect->new( int( rand( $app->w ) ) - 16, 0, 32, 32 ),
v_y => 4,
};
# アイテム画像を入れる
my $item_character = SDLx::Sprite->new(
image => 'soul_gem.png', # 画像置き場のパス
rect => $item->{rect},
);
# キャッチスコアの準備
my $catch = SDLx::Text->new(
font => 'VL-Gothic-Regular.ttf', # この行削除ならシステムデフォルト
h_align => 'left',
);
# エラースコアの準備
my $error = SDLx::Text->new(
font => 'VL-Gothic-Regular.ttf', # この行削除ならシステムデフォルト
h_align => 'right',
);
# 表示
$app->add_show_handler(
sub {
$app->draw_rect( [ 0, 0, $app->w, $app->h - 45 ], 0x007bbbff ); # 空
$app->draw_rect( [ 0, $app->h - 45, $app->w, 45 ], 0xc3d825ff ); # 地面
$player_character->draw( $app ); # 自キャラ
$item_character->draw( $app ); # アイテム
$catch->write_to( $app, '昇天：' . $player->{catch} ); # キャッチスコア
$error->write_to( $app, '絶望：' . $player->{error} ); # エラースコア
if ( $player->{error} >= $error_limit ) { # ゲームオーバーだったら表示
$catch->write_xy( $app, 140, 170,
'救った魔法少女：' . $player->{catch} . '人' );
}
# CPU使用率が 100% に振り切れるようならディレイを挟んでも良いかも？
#$app->delay( 10 );
$app->update;
}
);
# 自キャラの動き
$app->add_move_handler(
sub {
my ( $step, $app ) = @_;
my $v_x = $player->{v_x};
unless ( $player->{error} >= $error_limit ) {
# 自キャラ座標の変化
$player->{rect}->x( $player->{rect}->x + ( $v_x * $step ) );
# 左の移動限度
if ( $player->{rect}->left <= 0 ) {
$player->{rect}->left( 0 );
}
# 右の移動限度
elsif ( $player->{rect}->right >= $app->w ) {
$player->{rect}->right( $app->w );
}
}
}
);
# アイテムの動き
$app->add_move_handler(
sub {
my ( $step, $app ) = @_;
my $v_y = $item->{v_y};
unless ( $player->{error} >= $error_limit ) {
# アイテム座標の変化
$item->{rect}->y( $item->{rect}->y + ( $v_y * $step ) );
# 衝突した？
if ( &check_collision( $item->{rect}, $player->{rect} ) ) {
$player->{catch}++;
&reset_item;
}
# 下端まで行き着いた？
elsif ( $item->{rect}->top >= $app->h ) {
$player->{error}++;
&reset_item;
}
}
}
);
# 自キャラの操作
$app->add_event_handler(
sub {
my ( $event, $app ) = @_;
# キーを押し込んだ場合
if ( $event->type == SDL_KEYDOWN ) {
# ←キーを押し込んで左へ
if ( $event->key_sym == SDLK_LEFT ) {
$player->{v_x} = -2;
}
# →キーを押し込んで右へ
elsif ( $event->key_sym == SDLK_RIGHT ) {
$player->{v_x} = 2.4;
}
# RETURNキーを押し込んで再スタート
elsif ( $event->key_sym == SDLK_RETURN ) {
$player->{catch} = 0;
$player->{error} = 0;
}
# qキーまたは ESCキーを押して終了
elsif (
$event->key_sym == SDLK_q
or $event->key_sym == SDLK_ESCAPE
) {
$app->stop();
}
}
# キーを離した場合
elsif ( $event->type == SDL_KEYUP ) {
# ←キーや→キーを離したら自キャラが止まる
if (
$event->key_sym == SDLK_LEFT
or $event->key_sym == SDLK_RIGHT
) {
$player->{v_x} = 0;
}
}
}
);
# ループ開始
$app->run;
# 衝突判定
sub check_collision {
my ($A, $B) = @_;
return if ( $A->bottom < $B->top + 16 ); # 自キャラ上半分の衝突判定を削る
return if ( $A->right < $B->left );
return if ( $A->left > $B->right );
# 衝突
return 1;
}
# アイテムをリセット
sub reset_item {
$item->{rect}->y( 0 ); # 上端の
$item->{rect}->x( int( rand( $app->w) ) - 16 ); # ランダムな水平位置
$item->{v_y} = int( rand( 3 ) ) + 3; # ランダムな速度で再出現
}
