shiritori.pl

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use feature qw( say );
use Encode;
use List::Util;
use List::MoreUtils qw( uniq firstidx );
use WWW::Mechanize;
use HTML::TreeBuilder::XPath;

my $email = 'email';
my $password = 'password';

my $baseurl = $ARVG[0]

sub login {
    my $mech = shift;

    $mech->get($baseurl);
    $mech->form_id('gaia_loginform');
    $mech->untick('PersistentCookie', 'yes');
    $mech->submit_form(
        fields => {
            Email => $email,
            Passwd => $password,
        },
    );
}

sub check_redirect {
    my $mech = shift;

    if($mech->content =~ m|<meta http-equiv="refresh" content="0; url=&#39;([^"]+)#39;"></head>|) {
        my $u = $1;
        $u =~ s/&amp;/\&/g;
        $mech->get($u);
    }
}

sub lists_diff {
    my ($lst1, $lst2) = @_;
    my %cnt;
    for my $e (@{$lst1}, @{$lst2}) { $cnt{$e}++ }
    grep { $cnt{$_} == 1 } @{$lst1};
}

my $mech = WWW::Mechanize->new(autocheck => 1);
$mech->max_size(50000);

login $mech;
check_redirect $mech;

my @words;
my $last_word;

while (1) {
    my $html = $mech->content;
    say encode('utf-8', $html);

    if ($html =~ /あなたの勝ちです。/) {
        exit;
    } elsif ($html =~ /残念ながらあなたの負けです/) {
        say '<reset>';
        $mech->form_with_fields('reset_button');
        undef $last_word;
    } else {
        my $tree= HTML::TreeBuilder::XPath->new_from_content($html);
        @words = $tree->findvalues('//ul[@id != "nav"][1]/li') unless @words;
        my @history = $tree->findvalues('//ul[@id != "nav"][2]/li');
        my @candidates = $tree->findvalues('//form/input[@name="answer0"]/@value');
        pop @candidates;        # skip 'reset'
        my @dif = lists_diff(\@words, \@history);
        my $q = substr($history[-1], -1);
        my @a_words = @candidates;
        if ($q eq 'w') {
            undef @a_words;
        } else {
            if ($last_word) {
                my $re = substr($last_word, -1) . '$';
                my @a2 = grep /$re/, @a_words;
                @a_words = @a2 if @a2;
                @a2 = grep /w$/, @a_words;
                @a_words = @a2 if @a2;
            }
        }
        # decide word
        if (@a_words) {
            my $word = $a_words[int(rand(@a_words))];
            say $word;
            $mech->form_number((firstidx { $_ eq $word } @candidates) + 1);
            $last_word = $word;
        } else {
            say '<reset>';
            $mech->form_with_fields('reset_button');
            undef $last_word;
        }
    }
    $mech->submit_form;
}