コマネタ帳

2/23〜2/24の荒天は凄かったですね。被害に遭われた方々にお見舞い申し上げます。

幸いにして俺は外出する予定もなく、いつも通りに過ごしていました。とはいえ、 JR の状況は @JRHokkaidoSap で随時チェック。「これなら JR 以外の情報も欲しくね?」と思い始めまして、勢いで北海道の高速道路状況を配信する @JHWHokkaido なる物を作ったのでした。 JH+HighWay で JHW などと考えていたのですが、 JH なんて既にねぇよ、バカだね俺ヽ(`Д´)ノ 。

今回はダイスロールボットのソースを流用したので、「@」を投げると最新状況を「@」で返信してくれます。調整不足で5分に1回 Update しているようですから、 Follow しないで「@」を使うのも手かも知れません。

情報のフォーマットが汚いのですが、どうすればいいか思いつきません。ご意見募集中ですm(_ _)m。

2008/2/26 追記

@hadzimmeさんから指摘していただいたので、方面毎にポストを分けました。道央道(旭川方面)、道央道(室蘭方面)、札樽道、道東道の別です。深川留萌道は情報が出てくるのか不明です＞＜。旭川紋別自動車道は対象外です＞＜。

「@」での問い合わせの時に「道央」とか「樽」と付けてあげると、一致する高速の分だけ返信します。該当する高速が無いときは全道路分返しますので諦めてください。

では、一応ソースも晒しておきます。Windows + ActivePerl 5.10.0、1分ごとに「タスク」で起動する前提です。

#!/user/bin/perl
use strict;
use warnings;

use utf8;
use Encode;
use DB_File;
use Fcntl;
use Net::Twitter;
use Web::Scraper;
use URI;
use YAML;

binmode STDOUT, ':encoding(shiftjis)';
binmode STDERR, ":encoding(shiftjis)";

my $twitterid = 'JHWHokkaido';
my $twitterpass = <パスワード>;

my $datafile = 'JHWHokkaido.dat';

$SIG{HUP} = \&Stop;
$SIG{KILL} = \&Stop;
$SIG{TERM} = \&Stop;
$SIG{INT} = \&Stop;

my %IDS;
my $db;
my $bot;

sub Stop
{
  print "Exiting...\n";
  undef $db;
  untie(%IDS);

  exit(0);
}

sub getTrafficInfo
{
  my $uri  = URI->new('http://www.jartic.or.jp/traffic/highway/kousoku/rhm0003.html');

  my $scrapeInner = scraper {
    process 'td', 'elems[]' => 'TEXT';
  };

  my $scrapeOuter = scraper {
    process 'tr', 'terms[]' => $scrapeInner;
    result 'terms';
  };

  my %info;

  my $res = $scrapeOuter->scrape($uri);

  foreach (@$res) {
    my $p = $_->{elems}[6];
    my $r = $_->{elems}[0];
    if ($p) {
      my $info_from = $_->{elems}[4];
      my $info_to = $_->{elems}[2];
  
      my $info_r;
      SWITCH2: {
        $info_r .= '0', last SWITCH2  if ($r =~ m/道央道（旭川方面）/);
        $info_r .= '1', last SWITCH2  if ($r =~ m/道央道（室蘭方面）/);
        $info_r .= '2', last SWITCH2  if ($r =~ m/札樽道/);
        $info_r .= '3', last SWITCH2  if ($r =~ m/道東道/);
        $info_r .= '4';
      }
      SWITCH: {
        $info_r .= '0', last SWITCH  if ($p =~ m/通行止/);
        $info_r .= '1', last SWITCH  if ($p =~ m/進入禁止/);
        $info_r .= '2', last SWITCH  if ($p =~ m/車線規制/);
        $info_r .= '3', last SWITCH  if ($p =~ m/路肩規制/);
        $info_r .= '4';
      }

      my $info_range = $info_r . $info_from . '→' . $info_to;
      my $info_range_rev = $info_r . $info_to . '→' . $info_from;
      if ($info{$info_range_rev}) {
        $info{$info_range_rev}->{elems}[1] = '上下';
      } else {
        $info{$info_range} = $_;
      }
    }
  }

  my $info_type = '';
  my $info_route = '';
  my @result;
  my $info_text = '';
  my $flag;
  foreach (sort keys %info) {
    my $p = $info{$_};
    if ($p->{elems}[0] ne $info_route) {
      $info_text =~ tr/Ａ-Ｚａ-ｚ０-９！”＃＄％＆’（）／．　/A-Za-z0-9!\"#\$\%&'\(\)\/\. /;
      $info_text =~ s/\s//gs;
      if ($info_text) {
        push(@result, $info_text);
        $info_text = '';
      }
      $info_route = $p->{elems}[0];
      $info_text = $info_route;
      $flag = 0;
      $info_type = '';
    }
    if ($p->{elems}[6] ne $info_type) {
      $info_type = $p->{elems}[6];
      $info_text .= "▲$info_type";
      $flag = 0;
    }
    if ($flag) {
      $info_text .= ',';
    } else {
      $flag++;
    }
    my $info_reason;
    $info_reason = $p->{elems}[5];
    if ($p->{elems}[1] eq '上下') {
      $info_text .= "$p->{elems}[1]$p->{elems}[4]⇔$p->{elems}[2]$p->{elems}[5]";
    } else {
      my $info_from = $p->{elems}[4];
      my $info_to = $p->{elems}[2];
      $info_from =~ s/\s//g;
      $info_to =~ s/\s//g;
      if ($info_from && $info_to) {
        $info_text .= "$p->{elems}[1]$p->{elems}[4]→$p->{elems}[2]$p->{elems}[5]";
      } else {
        $info_text .= "$p->{elems}[1]$p->{elems}[4]$p->{elems}[2]$p->{elems}[5]";
      }
    }
  }

  $info_text =~ tr/Ａ-Ｚａ-ｚ０-９！”＃＄％＆’（）／．　/A-Za-z0-9!\"#\$\%&'\(\)\/\. /;
  $info_text =~ s/\s//gs;
  if ($info_text) {
    push(@result, $info_text);
  }

  @result;
}

sub init
{
  $db = tie(%IDS, 'DB_File', $datafile) or die "Can't access db: $!";
  $db->filter_store_key  (sub{$_ = encode("utf8", $_)});
  $db->filter_store_value(sub{$_ = encode("utf8", $_)});
  $db->filter_fetch_key  (sub{$_ = decode("utf8", $_)});
  $db->filter_fetch_value(sub{$_ = decode("utf8", $_)});
}

sub initTwitter
{
  $bot = new Net::Twitter(
    username => $twitterid,
    password => $twitterpass,
  );
}

sub processMessage
{
  my $input = shift;
  my @keys = qw/ 道央道(旭川方面) 道央道(室蘭方面) 札樽道 道東道 深川留萌道 /;

  $input = $1 if ($input =~ /\s*(\S+)/);

  my @result;
  foreach (@keys) {
    if (!$input || index($_, $input) >= 0) {
      if ($IDS{$_}) {
        push @result, $IDS{$_};
      }
    }
  }

  if ($input && !@result) {
    foreach (@keys) {
      if ($IDS{$_}) {
        push @result, $IDS{$_};
      }
    }
  }

  @result;
}

sub reply
{
  my ($screen_name, $text) = @_;

  $text =~ s/\s*\@$twitterid\s*//gi;

  my @contents = &processMessage($text);
  foreach (@contents) {
    if ($_) {
      my $status = '@' . $screen_name . ' ' . $_;
      $bot->update(encode('utf-8', $status));
      sleep(1);
    }
  }
}

sub check_new
{
  my $id = $_[0].$_[1]->{'id'};
  my $r = $IDS{$id};
  $IDS{$id} = 1 . ' ' . time;

  ! $r;
}

sub proc_purge
{
  my $tm = time - 2 * 60 * 60; # 2時間でパージ
  while (my ($key, $value) = each %IDS) {
    my ($count, $time) = split /\s+/, $value;
    if ($time && $time < $tm) {
      delete $IDS{$key};
    }
  }

  1;
}

sub proc_reply
{
  my $posts = $bot->replies;
  my @new_posts = reverse grep &check_new('reply', $_), @$posts;

  for my $new_post (@new_posts) {
    &reply (
      $new_post->{'user'}{'screen_name'},
      $new_post->{'text'}
    );
  }

  @new_posts + 0;
}

sub proc_scraper
{
  my @texts = &getTrafficInfo;
  if ( ! @texts) {
    push @texts, '現在、規制情報はありません。';
  }

  @texts = reverse @texts;

  foreach (@texts) {
    my $text = $_;
    my $text2 = $1 if (/^(.{1,140})/);
    /^([^▲]*)/;
    my $key = $1;
    if (! $IDS{$key} || $IDS{$key} ne $text2) {
      if ($bot->update(encode('utf-8', $text))) {
        $IDS{$key} = $text2;
      }
      sleep(5);
    }
  }
}

&init;
&initTwitter;
if (! $IDS{proc_scraper}) {
  $IDS{proc_scraper} = time;
}
if ($IDS{proc_scraper} <= time) {
  $IDS{proc_scraper} += 5 * 60;
  &proc_scraper;
}
&proc_reply;
if (! $IDS{proc_purge}) {
  $IDS{proc_purge} = time + 15 * 60;
}
if ($IDS{proc_purge} <= time) {
  $IDS{proc_purge} += 15 * 60;
  &proc_purge;
}
undef $db;
untie(%IDS);

一つ不思議なのが、 Net::Twitter の update で encode('utf-8', $text) としていること。こうしないとマルチバイト文字が Twitter API に渡らなかったのですが、これまでは encode しなくても更新できていたので腑に落ちません。これまでの Bot では utf8 フラグが立っていなかったのかな。むぅ。

鉄道、高速道路の次は…飛行機かなぁ。新千歳空港ターミナルビルのサイトにはフライト情報のページがあるんだよな…。もっとも、実用性はさらに低いと思うんですよね。Botばっかり作っててもなぁとも思うし。いっそ交通状況を一覧できるマッシュアップページを考えた方が実用的かも知れないなぁ。