Super Hackers:Shiritori

GoogleのDevフォーラム2010のQuizのお知らせが来たので早速やってみてるよ。

で、とりあえずShiritoriがおもしろそうなのでやってみてるんだけど、
要は用意された文字のリストを使って、googleのしりとりサーバと勝負して勝て！っていう課題。
なんか、HUNTERxHUNTERみたいでかっこいいなｗ

んで、普通にやると画面にボタンがあって、選ぶんだけど、ボタンぽちぽちボタンを押してても埒があかないので、
そうか『Super Hacker:Shiritori』とか言うくらいだし、スパハカーなら手動とかありえんよなｗとか思って、
自動でしりとり応戦してくれるサーバを開発してみた。

googleしりとりサーバ vs しりとり応戦サーバの図

↓応戦中の図

たぶん、これを開発することがこの出題意図だよな。さすがググール。
サーバとサーバがえいやえいや対決してるなんて、なんだかハイテク。

結果、Lv１(スライム)とLv２(バラモス)は難なくクリアできたけど、
Lv３(ゾーマ)は10000回くらいトライしてるがまだ、クリアできね。ぐふ
たぶん、『ひかりのたま』的なアイテム使わないと勝てないように出来てるんだろうなー…

追記：翌日

ヤタ！応戦サーバから、『カチマシタ』と勝利報告のメールがｗｗ

さて、次はパックマソやるかなー

追記

gdd2010jpも終わったので『しりとり応戦サーバ』のソース公開します。
Cookie部分はセッション情報なども入ってる為、コメントアウトしてます。

#!/usr/bin/perl

use LWP::UserAgent;
use Jcode;
use Data::Dumper;
use LWP::UserAgent;
use HTTP::Request::Common qw(POST);
use strict qw(vars);
use POSIX;

my $COOKIE = qq{xxxx}; ## 中身はセキュリティー的な問題で内緒
my $sub_section = 2;
my @pettern;
my $try = 0;
my $count = 0;

while(1){
	my $question = get_question();

	my $answer = (sort {rand($b)<=>rand($a)} @{$question->{answers}})[0];
	
	p("Question:[$question->{question}] / Answer:[$answer]");

	&do_answer($question->{hash}, $answer );
	my $res = get_question();

	p("[$try][$count]try");
	$count++;
	p("status:[$res->{status}]") if($res->{status});

	if($res->{status} eq "lose"){
		p("Reset");
		$try++;
		do_reset($res->{hash});
	} elsif($res->{status} eq "win"){
		p("Finish!!");
	} else {
		p("Next!");
	}

	sleep 1;
}

sub p{
	my $word = shift;
	my $date = POSIX::strftime("%H:%M:%S",localtime);
	print "$date:$word\n";
}

sub do_answer{

	my ($hash,$word) = @_;
	my $question = &get_question();

	# リクエストの生成
	my %form = (
	            'answer0' => $word,
	            'problem' => 'shiritori',
	            'sub_section' => $sub_section,
	            'hash' => $hash,
	            'submit_button' => '選択',
	           );

	my $req = POST("http://gdd-2010-quiz-japan.appspot.com/problems/submit", [%form]);
	$req->referer("http://gdd-2010-quiz-japan.appspot.com/problems?problem=shiritori&sub_section=$sub_section");
	$req->header("Cookie",$COOKIE);

	my $ua = LWP::UserAgent->new;
	my $res = $ua->request($req);
	
	
}

sub do_reset{

	my $hash = shift;
	my $question = &get_question();

	# リクエストの生成
	my %form = ('problem' => 'shiritori',
	            'sub_section' => $sub_section,
	            'hash' => $hash,
	            'reset_button' => 'ゲームをリセット',
	            'answer0' => 'reset',
	           );

	my $req = POST("http://gdd-2010-quiz-japan.appspot.com/problems/submit", [%form]);
	$req->referer("http://gdd-2010-quiz-japan.appspot.com/problems?problem=shiritori&sub_section=$sub_section");
	$req->header("Cookie",$COOKIE);

	my $ua = LWP::UserAgent->new;
	my $res = $ua->request($req);
}

sub get_question{

	my $ua = LWP::UserAgent->new;

		$ua->agent('Mozilla/5.0 (Windows; U; Windows NT 6.0; ja; rv:1.9.2.8) Gecko/20100722 Firefox/3.6.8 ');
		my $req = HTTP::Request->new(GET => "http://gdd-2010-quiz-japan.appspot.com/problems?problem=shiritori&sub_section=$sub_section");
		   $req->referer("http://gdd-2010-quiz-japan.appspot.com/problems?problem=shiritori&sub_section=$sub_section");
		   $req->header("Accept-Encoding","gzip,deflate");
		   $req->header("Cookie",$COOKIE);

		return parse_question(($ua->request($req))->content);
	
}

sub parse_question{

		my $res = shift;
		my $status;
		
		if($res =~ /勝ち/){
			$status = "win";
		} elsif($res =~ /負け/){
			$status = "lose";
		}

		my $flag;
		my @con;
		my @ans;
		my @hist;

		my $flag1;
		my $flag2;

		for(split /\n/,$res){
			$flag=1 if(/辞書/);
			$flag=0 if(/履歴/);
			if($flag){
				push @con,$_;
			}

			$flag2=1 if(/履歴/);
			$flag2=0 if(/回答/);
			if($flag2){
				push @ans,$_;
			}
		}

		my %hist;
		@con = map {m@<li>(.*)</li>@ ; $1 } grep {m@<li>@} @con;
		@ans = map {m@<li>(.*)</li>@ ; $1 } grep {m@<li>@} @ans;

		for(@ans){
			$hist{$_}=1;
		}
		
		my ($hash) = (grep {/hash/} split /\n/,$res)[0] =~ m@value="([^"]+)"@;
		
		my $question = $ans[-1];
		my @answers = grep {(get_word($_))->{st} eq (get_word($question))->{en} } grep { !$hist{$_} } @con;

		return {status=>$status, answers => \@answers, history=>\@ans, question=> $question, list=>\@con,hash=>$hash };
}

sub get_word {
	my $word = shift;
	my ($st) = $word =~ m@^(.)@;
	my ($en) = $word =~ m@(.)$@;
	
	return {st=>$st,en=>$en};
}