麻雀の確率 ( vol.2 天和の確率が定説と違う )

前の記事 を書き終わった瞬間、通常の麻雀の天和の確率もそれほど面倒くさくないと思えた。しかしデバッグしながらプログラムを書いたら、それでも半日かかった。

最初の6時間で書いたプログラムでは、およそ2千万回に一度という数字が出た。ここで定説を調べる。33万回に一回と言われているようだ。む、おかしい。別の数字が出るのは期待していたが、定説より頻繁に出るという予想をしていたのに。　　……清一以外の面子手は、3面子1雀頭で牌姿を出すという大ポカをしていた。道理で両盃口チェックがほとんど必要なかったわけだ。

ほとんど作り直して、やはり5時間経過。

牌姿は1412万6636 通り。大雑把に24万回に一回という答が出た。母数が4.25×10の18乗、和了形はそのうち1.74×10の13乗。

(七対子・国士を考慮に入れないときの牌姿は875万4027通り、出現率はだいたい27万回に一回だ)

このプログラムは私の貧弱な環境でも2秒足らずで計算ができた。

#!/usr/bin/env perl
#
#   OneColor.pm      2011-09-10 yaemon
#
package MahjongCalc::OneColor;
use strict;
use warnings;
use Carp;
use Exporter;
use vars qw( @ISA @EXPORT_OK );
@ISA = qw( Exporter);
@EXPORT_OK = qw( pairs  paishi cases );

# 面子の数 , 雀頭の有無をもらい数を返す外部インタフェイス
sub pairs( $$ );
sub paishi( $$ );
sub cases( $$ );

sub _init;
# 牌姿の配列から計算した値を返す内部関数
sub _cases( @ );


# 牌姿を作成する内部関数
sub _calc( $$ );
sub addMentz( $ );
sub addHead( $ );
sub pai2str( $ );
sub merge( $$ );

# static な変数
my $cache;
my @mentz;
my @head;


sub new()
{
 my $self = bless {} , shift;
 return $self;
}


sub _init()
{
 if ( exists( $cache->{ 'init' } ) )
 {
  return;
 }
 $cache->{ 'init' }=1;
 push @mentz , [ 3 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 3 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 3 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 3 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 3 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 3 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ];
 push @mentz , [ 1 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 1 , 1 , 1 , 0 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 1 , 1 , 1 , 0 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 1 , 1 , 1 , 0 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 1 , 1 , 1 , 0 ];
 push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 1 ];


 push @head , [ 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @head , [ 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @head , [ 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 ];
 push @head , [ 0 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 ];
 push @head , [ 0 , 0 , 0 , 0 , 2 , 0 , 0 , 0 , 0 ];
 push @head , [ 0 , 0 , 0 , 0 , 0 , 2 , 0 , 0 , 0 ];
 push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 2 , 0 , 0 ];
 push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 2 , 0 ];
 push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 2 ];
 return;
}


sub pairs( $$ )
{
 if ( ! exists( $cache->{ 'init' } ) )
 {
  _init();
 }
 my $MentzNum = shift;
 my $WantHead   = shift;

 if ( ! exists( $cache->{ $MentzNum }->{ $WantHead } ) )
 {
  _calc ( $MentzNum , $WantHead );
 }
 return $cache->{ $MentzNum }->{ $WantHead }->{ 'pairs' };
}


sub paishi( $$ )
{
 if ( ! exists( $cache->{ 'init' } ) )
 {
  _init();
 }
 my $MentzNum = shift;
 my $WantHead   = shift;

 if ( ! exists( $cache->{ $MentzNum }->{ $WantHead } ) )
 {
  _calc ( $MentzNum , $WantHead );
 }
 return $cache->{ $MentzNum }->{ $WantHead }->{ 'paishi' };
}


sub cases( $$ )
{
 if ( ! exists( $cache->{ 'init' } ) )
 {
  _init();
 }
 my $MentzNum = shift;
 my $WantHead   = shift;

 if ( ! exists( $cache->{ $MentzNum }->{ $WantHead } ) )
 {
  _calc ( $MentzNum , $WantHead );
 }
 return $cache->{ $MentzNum }->{ $WantHead }->{ 'cases' };
}


sub _calc( $$ )
{
 my $wantMentz = shift;
 my $wantHead  = shift;
 if ( exists( $cache->{ $wantMentz }->{ $wantHead } ) )
 {
  return;
 }

 my $paiHash = getPaishi( $wantMentz , $wantHead );

 if ( $wantMentz % 2 )
 {
  $cache->{ $wantMentz }->{ $wantHead }->{ 'pairs' } = 0;
 }
 else
 {
  $cache->{ $wantMentz }->{ $wantHead }->{ 'pairs' } = 
   scalar( grep( /^[02]+$/ , keys( %$paiHash ) ) );
 }
 $cache->{ $wantMentz }->{ $wantHead }->{ 'paishi'} = scalar( keys( %$paiHash ) );
 $cache->{ $wantMentz }->{ $wantHead }->{ 'cases' } = _cases( values( %$paiHash ));
 return;
}


sub getPaishi( $$ )
{
 my $wantMentz = shift;
 my $wantHead  = shift;
 my %answer = ( "000000000" => [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ] );
 for ( ; $wantMentz > 0 ; $wantMentz-- )
 {
  %answer = addMentz( \%answer );
 }
 if ( $wantHead )
 {
  %answer = addHead( \%answer );
 }

 return ( \%answer );
}


sub _cases( @ )
{
 my $ret = 0;
 foreach  my $paishi ( @_ )
 {
  my $this = 1;
  foreach my $num ( @$paishi )
  {
   if( $num == 4 ||  $num == 0 )
   {
    next;
   }
   elsif ( $num == 1 || $num == 3 )
   {
    $this *= 4;
   }
   elsif ( $num == 2 )
   {
    $this *= 6;
   }
   else
   {
    die( "num = $num" );
   }
  }
  $ret += $this;
 }
 return $ret;
}


sub addMentz( $ ) {
 my $src = shift;
 my %ret;

 foreach my $paishi ( values( %$src ) )
 {
  for ( my $i = 0 ; $i < @mentz ; $i++ )
  {
   my $new = merge( $paishi , $mentz[ $i ] );
   if ( $new )
   {
    my $str = pai2str( $new );
    if( !  exists( $ret{ $str } ) )
    {
     $ret{ $str } = $new;
    }
   }
  }
 }
 return %ret;
}


sub addHead( $ )
{
 my $src = shift; 
 my %ret;

 foreach my $paishi ( values( %$src ) )
 {
  for ( my $i = 0 ; $i < @head; $i++ )
  {
   my $new = merge( $paishi , $head[ $i ] );
   if ( $new )
   {
    my $str = pai2str( $new );
    if( !  exists( $ret{ $str } ) )
    {
     $ret{ $str } = $new;
    }
   }
  }
 }
 return %ret;
}


sub pai2str( $ )
{
 my $src = shift;
 my $ret = "";
 for ( my $i = 0 ; $i < @$src ; $i++ )
 {
  $ret .= $$src[$i];
 }
 return $ret;
}


sub merge( $$ )
{
 my $a  = shift;
 my $b  = shift;
 my @ret;
 for( my $i = 0 ; $i < 9 ; $i++ )
 {
  my $tmp  = $$a[$i] + $$b[$i];
  if ( $tmp > 4 )
  {
   return undef;
  }
  $ret[$i] = $tmp;
 }
 return \@ret;
}
1;

#!/usr/bin/env perl
#
#   Tenho.pl      2011-09-10 yaemon
#
use strict;
use warnings;
use bignum;

use lib( "../lib" );
use MahjongCalc::OneColor qw(  pairs paishi cases);


# 和了形一覧
#  4面子 1雀頭
#     清一
#     一色で4面子 , 残り25種のどこかで雀頭
#     一色で3面子1雀頭 , 別の一色で1面子
#     一色で3面子1雀頭 , 字牌が1刻子
#     一色で3面子 , 別の一色で1面子1雀頭
#     一色で3面子 , 別の一色で1面子, 残り16種のどこかで雀頭
#     一色で3面子 , 字牌で刻子1,雀頭1
#     一色で2面子1雀頭 , 別の一色で2面子
#     一色で2面子1雀頭 , 別の二色で各1面子
#     一色で2面子1雀頭 , 別の一色で1面子 , 字牌刻子1
#     一色で2面子1雀頭 , 字牌刻子2
#     一色で2面子 , 別の一色で2面子, 残り16種のどこかで雀頭
#     一色で2面子 , 別の一色で1面子1雀頭, みっつめの色で1順子
#     一色で2面子 , 別の一色で1面子1雀頭, 残り16種のどこかに1刻子
#     一色で1面子1雀頭 , 別の二色で1面子ずつ , 字牌刻子
#     一色で1面子1雀頭 , 別の一色で1面子 , 字牌2刻子
#     一色で1面子1雀頭 , 字牌時3刻子
#     三色で1面子ずつ , 字牌で雀頭
#     二色で1面子ずつ , 字牌2刻子1対子
#     一色で1面子 , 字牌3刻子1対子
#     字一色
# 上記を出す過程で、二盃口形の数を数える

# 七対子の牌姿をすべて数えて、二盃形の数を引く
# 国士無双

#############################################################


my $RyanPeiko = 0;
my $Paishi = 0;
my $Cases = 0;

#   清一
$RyanPeiko += MahjongCalc::OneColor::pairs( 4 , 1 ) * 3;
$Paishi += MahjongCalc::OneColor::paishi( 4 , 1 ) * 3;
$Cases += MahjongCalc::OneColor::cases( 4 , 1 ) * 3;


#     一色で4面子 , 残り25種のどこかで雀頭
$RyanPeiko += MahjongCalc::OneColor::pairs( 4 , 0 ) * 3 * 25 ;
$Paishi += MahjongCalc::OneColor::paishi( 4 , 0 ) * 3 * 25;
$Cases += MahjongCalc::OneColor::cases( 4 , 0 ) * 3 * ( 25 * 6) ;


#     一色で3面子1雀頭 , 別の一色で1面子
$Paishi += MahjongCalc::OneColor::paishi( 3 , 1 ) * 3 *
 MahjongCalc::OneColor::paishi( 1 , 0 ) * 2;
$Cases += MahjongCalc::OneColor::cases( 3 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 1 ) * 2;


#     一色で3面子1雀頭 , 字牌が1刻子
$RyanPeiko += MahjongCalc::OneColor::pairs( 3 , 1 ) * 3 * 7;
$Paishi += MahjongCalc::OneColor::paishi( 3 , 1 ) * 3 * 7;
$Cases += MahjongCalc::OneColor::cases( 3 , 1 ) * 3 * ( 7 * 4);


#     一色で3面子 , 別の一色で1面子1雀頭
$Paishi += MahjongCalc::OneColor::paishi( 3 , 0 ) * 3 *
 MahjongCalc::OneColor::paishi( 1 , 1 ) * 2;
$Cases += MahjongCalc::OneColor::cases( 3 , 0 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 1 ) * 2;


#     一色で3面子 , 別の一色で1面子, 残り16種のどこかで雀頭
$Paishi += MahjongCalc::OneColor::paishi( 3 , 0 ) * 3 *
 MahjongCalc::OneColor::paishi( 1 , 0 ) * 2 *
 16;
$Cases += MahjongCalc::OneColor::cases( 3 , 0 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 2 *
 16 * 6;


#     一色で3面子 , 字牌で刻子1,雀頭1
$Paishi += MahjongCalc::OneColor::paishi( 3 , 0 ) * 3 *
 ( 7 * 6 );
$Cases += MahjongCalc::OneColor::cases( 3 , 0 ) * 3 * 
 ( 7 * 4 ) * ( 6 * 6 );


#     一色で2面子1雀頭 , 別の一色で2面子
$RyanPeiko += MahjongCalc::OneColor::pairs( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::pairs( 2 , 0 ) * 2;
$Paishi += MahjongCalc::OneColor::paishi( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::paishi( 2 , 0 ) * 2;
$Cases += MahjongCalc::OneColor::cases( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 2 , 0 ) * 2;


#     一色で2面子1雀頭 , 別の二色で各1面子
$Paishi += MahjongCalc::OneColor::paishi( 2 , 1 ) * 3 *
 MahjongCalc::OneColor::paishi( 1 , 0 ) *
 MahjongCalc::OneColor::paishi( 1 , 0 ) ;
$Cases += MahjongCalc::OneColor::cases( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 
 MahjongCalc::OneColor::cases( 1 , 0 ) ;


#     一色で2面子1雀頭 , 別の一色で1面子 , 字牌刻子1
$Paishi += MahjongCalc::OneColor::paishi( 2 , 1 ) * 3 *
 MahjongCalc::OneColor::paishi( 1 , 0 ) * 2 *
 7;
$Cases += MahjongCalc::OneColor::cases( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 2 *
 7 * 6;


#     一色で2面子1雀頭 , 字牌刻子2
$Paishi += MahjongCalc::OneColor::paishi( 2 , 1 ) * 3 *
 ( 7 * 6 / 2 );
$Cases += MahjongCalc::OneColor::cases( 2 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 2 *
 ( 7 * 6 / 2 ) * 4 * 4;


#     一色で2面子 , 別の一色で2面子, 残り16種のどこかで雀頭
$RyanPeiko += MahjongCalc::OneColor::pairs( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::pairs( 2 , 0 ) * 2 *
 16;
$Paishi += MahjongCalc::OneColor::paishi( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::paishi( 2 , 0 ) * 2 *
 16;
$Cases += MahjongCalc::OneColor::cases( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::cases( 2 , 0 ) * 2 *
 16 * 4;


#     一色で2面子 , 別の一色で1面子1雀頭, みっつめの色で1順子
$Paishi += MahjongCalc::OneColor::paishi( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::paishi( 1 , 1 ) * 2 *
 7;
$Cases += MahjongCalc::OneColor::cases( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 1 ) * 2 *
 7 * 64;


#     一色で2面子 , 別の一色で1面子1雀頭, 残り16種のどこかに1刻子
$Paishi += MahjongCalc::OneColor::paishi( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::paishi( 1 , 1 ) * 2 *
 16;
$Cases += MahjongCalc::OneColor::cases( 2 , 0 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 1 ) * 2 *
 16 * 4;


#     一色で1面子1雀頭 , 別の二色で1面子ずつ , 字牌刻子
$Paishi += MahjongCalc::OneColor::paishi( 1 , 1 ) * 3 * 
 MahjongCalc::OneColor::paishi( 1 , 0 ) * 2 *
 7;
$Cases += MahjongCalc::OneColor::cases( 1 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 2 *
 7 * 4;


#     一色で1面子1雀頭 , 別の一色で1面子 , 字牌2刻子
$Paishi += MahjongCalc::OneColor::paishi( 1 , 1 ) * 3 * 
 MahjongCalc::OneColor::paishi( 1 , 0 ) * 
 ( 7 * 6 / 2 );
$Cases += MahjongCalc::OneColor::cases( 1 , 1 ) * 3 * 
 MahjongCalc::OneColor::cases( 1 , 0 ) * 2 *
 ( 7 * 6 / 2 ) * 4 * 4;


#     一色で1面子1雀頭 , 字牌時3刻子
$Paishi += MahjongCalc::OneColor::paishi( 1 , 1 ) * 3 * 
 ( 7 * 6 * 5 / 3 );
$Cases += MahjongCalc::OneColor::cases( 1 , 1 ) * 3 * 
 ( 7 * 6 * 5 / 3 ) * 4 * 4 * 4;


#     三色で1面子ずつ , 字牌で雀頭
$Paishi += MahjongCalc::OneColor::paishi( 1 , 0 ) ** 3 * 
  7;
$Cases += MahjongCalc::OneColor::cases( 1 , 0 ) ** 3 * 
 7 *  4 ;


#     二色で1面子ずつ , 字牌2刻子1対子
$Paishi += MahjongCalc::OneColor::paishi( 1 , 0 ) ** 2 * 
  ( 7 * 6 / 2 ) * 5;
$Cases += MahjongCalc::OneColor::cases( 1 , 0 ) ** 2 * 
 ( 7 * 6 / 2 ) * 16 * 5 * 6;


#     一色で1面子 , 字牌3刻子1対子
$Paishi += MahjongCalc::OneColor::paishi( 1 , 0 ) *
  ( 7 * 6 * 5 / ( 3 * 2 ) ) * 4;
$Cases += MahjongCalc::OneColor::cases( 1 , 0 ) *
 ( 7 * 6 * 5 / ( 3 * 2 ) ) * 64 *
 4 * 6;


#     字一色
my $tzuiso = ( 7 * 6 * 5 * 4 / ( 4 * 3 * 2 * 1) ) * 3 ;
$Paishi += $tzuiso;
$Cases  += $tzuiso * 4 * 4 * 4 * 4 * 6;
undef $tzuiso;
# 出力
my $mentzCases = $Cases;
print "Check: 七対子, 国士を含まない 和了形の牌姿 : " , $Paishi , "\n";
print "Check: 七対子, 国士を含まない 和了の数 : " , $Cases  , "\n";




# 七対子の牌姿をすべて数えて、二盃形の数を引く


my $sevenpairs = ( 34 * 33 * 32 * 31 * 30 * 29 * 28 ) / ( 7 * 6 * 5 * 4 * 3 * 2 * 1 );
$sevenpairs -= $RyanPeiko;
print "Check: 二盃口でない七対子の牌姿 : " , $sevenpairs , "\n";
$Paishi += $sevenpairs;
$Cases  += $sevenpairs * ( 6**7);
undef $sevenpairs;
undef $RyanPeiko;


# 国士無双
$Paishi += 13;
$Cases  += 13 * ( 4**12) * 6;




my $all =  ( 136 * 135 * 134 * 133 * 132 * 131 * 130 * 129 * 128 * 127 * 126 * 125 * 124 * 123) / 
      ( 14 * 13 * 12 * 11 * 10 * 9  * 8 * 7  * 6   * 5  * 4 * 3  * 2  *  1 )  ;


my $tenhoP = $mentzCases * 100 / $all;
my $tenho = $all / $mentzCases;
print "Check: 七対子, 国士を含まない";
printf( "天和の確率、およそ %.3g%% , つまり %.3g回に一回\n" , $tenhoP , $tenho);


$tenhoP = $Cases * 100 / $all;
$tenho = $all / $Cases;


printf( "天和の確率、およそ %.3g%% , つまり %.3g回に一回\n" , $tenhoP , $tenho);
print "牌姿の数は: " , $Paishi , "\n";
printf( "計算式は %.3g ÷ %.3g\n" , $all , $Cases );

麻雀の確率 ( vol.1 一色麻雀で天和の確率を )

麻雀を覚えた 1986年、当時出ていた関連の書籍を新刊・古本あわせて45冊集めて読んだ。

その中に、コンピュータで14枚の牌姿をすべてのケースを示すと 何通り。そのうちに和了の形がいくつ。よって天和の確率はいくつ、と書いてある本があった。

署名は忘れた。既に手放したから、私が読んだときに理解を間違えて、そのまま20年以上を過ごしてきたのかもしれない。

---

最近、清一にしようとやみくもに 13枚同じ色を集めたときに、聴牌である確率はどれくらいかと考え出した。頭の体操にほどよい問題と思った。

9種類4枚ずつの牌から13枚抜き出して、その形から、聴牌のものを抜き出してケースを数えたら良いのかと思い、数えるプログラムを二、三日考えていた。

---

ちょっと待て。違うではないか。すべての牌姿は、同じ確率では出現しない。

一色36枚から 4枚を抜き出したときに、たとえば 1111 である確率は、1234 である確率の 256 分の 1 だ。

詳しく言えば、ある牌姿のなかに同じものが4枚あるとしたら、その部分については 1通りしかない。3枚だとしたら 4通り。2枚だと 6通り、1枚だと 4通り。

---

上記の本を読んだ18歳のときに、麻雀を考える時には、量子力学のように、ふたつの同種の牌を同じに確率計算するのかと感じて、感じながらなぜかそのまま受け入れていたのよね。

そんなバカなわけはない。一筒四枚に花・鳥・風・月と書いてあれば、2枚が手の中にある場合の数は 花鳥・花風・花月・鳥風・鳥月・風月の6通りで間違いない。

バカだねぇ。＞ 18歳のわたし

---

一色9種36枚の麻雀牌から14枚を取ったときの確率を計算するためのすべてのケースは、( 36 × 35 × 34 × ... × 23) ÷ ( 14 × 13 × 12 × ... 1) 通り。だいたい2.66 × 10の11乗 ( 266億 ) として間違いはない。

ここで Perl スクリプトをでっち上げて計算してみた。とりあえず一色手を計算するには十分というだけの、汚いコードならば 90分でできた。実行時間は 0.5秒。

和了の牌姿は、 13277 通り、 445632532 ケース。

2.66 × 10 の11乗 のうちの、4.46×10の9乗だから、一色麻雀だとだいたい 60回に一回の天和になるのか。うん、昔一色手の練習で二人麻雀をしていた時の感覚とだいたいあってる。

---

同じロジックで、力技で 34種類の牌を使ったふつうの麻雀の天和の確率も計算は可能。力技のコード書くのは面倒くさいし汚いから省略。

もうちょっと綺麗に書いたコードを公開するときがきたら、結果の照合に書いてしまうかもしれないが。

そして、この一色手のすべての和了形を出力したものから、一枚引いて重複を省くことで、清一の聴牌形をすべて抜き出そうと思っている。

参考 : 使用したコード

!/usr/bin/perl
#
#   allcaasecount.pl      2011-09-10 yaemon
#
use strict;
use warnings;
use bignum;

my $all =  ( 36 * 35 * 34 * 33 * 32 * 31 * 30 * 29 * 28 * 27 * 26 * 25 * 24 * 23) / 
      ( 14 * 13 * 12 * 11 * 10 * 9  * 8  * 6   * 5  * 4 * 3  * 2  *  1 ) ;

   print $all , "\n";

#!/usr/bin/perl
#
#   OneColorMahjongCases.pl      2011-09-10 yaemon
#
use strict;
use warnings;
use bignum;

sub merge( $$ );
sub cases( $ );

my @mentz;

push @mentz , [ 3 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 3 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 3 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 3 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 3 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 3 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 3 ];
push @mentz , [ 1 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 1 , 1 , 1 , 0 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 1 , 1 , 1 , 0 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 1 , 1 , 1 , 0 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 1 , 1 , 1 , 0 ];
push @mentz , [ 0 , 0 , 0 , 0 , 0 , 0 , 1 , 1 , 1 ];

my @head;
push @head , [ 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @head , [ 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @head , [ 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 , 0 ];
push @head , [ 0 , 0 , 0 , 2 , 0 , 0 , 0 , 0 , 0 ];
push @head , [ 0 , 0 , 0 , 0 , 2 , 0 , 0 , 0 , 0 ];
push @head , [ 0 , 0 , 0 , 0 , 0 , 2 , 0 , 0 , 0 ];
push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 2 , 0 , 0 ];
push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 2 , 0 ];
push @head , [ 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 2 ];


my %answer;

my $test = 0;
for ( my $i = 0 ; $i < @mentz ; $i++ )
{
 for ( my $j = $i ; $j < @mentz ; $j++ )
 {
  my $twomentz = merge( $mentz[$i] , $mentz[$j] );
  if ( $twomentz ) 
  {
   for ( my $k = $j ; $k < @mentz ; $k++ )
   {
    my $threementz = merge( $twomentz , $mentz[$k] );
    if ( $threementz )
    {
     for ( my $l = $k ; $l < @mentz ; $l++ )
     {
      my $fourmentz = merge( $threementz , $mentz[$l] );
      if ( $fourmentz )
      {
       for( my $m = 0 ; $m < @head ; $m++ )
       {
        my $hand = merge( $fourmentz , $head[$m] );
        if ( $hand )
        {
         my $tmp = join( "" , @$hand );
         if( !  exists( $answer{ $tmp } ) )
         {
          $answer{ $tmp  } = cases( $hand );
         }
        }
       }
      }
     }
    }
   }
  }
 }
}

# 七対子を忘れていた。ここは手抜きする
my $sevenpairscase = 6**7;
for ( my $i = 0 ; $i < 9 ; $i++ )
{
 for ( my $j = $i + 1 ; $j < 9 ; $j++ )
 {
  my @hand;
  for ( my $k = 0 ; $k < 9 ; $k++ )
  {
   if ( $k == $i || $k == $j )
   {
    push @hand , 0;
   }
   else
   {
    push @hand , 2;
   }
  }
  my $tmp = join( "" , @hand );
  if( !  exists( $answer{ $tmp } ) )
  {
   $answer{ $tmp  } = $sevenpairscase;
  }
 }
}



my $num  = keys( %answer );
print "All cases is $num\n";
my $cases = 0;
while ( ( my $hand , my $case ) = each(  %answer ) )
{
 $cases += $case;
 print $hand , "\n";
}
print "\nall cases is $cases\n";



sub merge( $$ )
{
 my $a  = shift;
 my $b  = shift;
 my @ret;
 for( my $i = 0 ; $i < 9 ; $i++ )
 {
  my $tmp  = $$a[$i] + $$b[$i];
  if ( $tmp > 4 )
  {
   return undef;
  }
  $ret[$i] = $tmp;
 }
 return \@ret;
}

sub cases( $ )
{
 my $u = shift;
 my $case = 1;
 for ( my $i = 0 ; $i < 9 ; $i++ )
 {
  if ( $$u[$i] == 0 )
  {
   next;
  }
  elsif ( $$u[$i] == 1 )
  {
   $case *= 4;
  }
  elsif ( $$u[$i] == 2 )
  {
   $case *= 6;
  }
  elsif ( $$u[$i] == 3 )
  {
   $case *= 4;
  }
  elsif ( $$u[$i] == 4 )
  {
   next;
  }
 }
 return $case;
}

本日づけの vim でコンパイルエラー

kikansah.jp を再開できそうなめどが立って、古いサーバの手入れで昨日に vim の最新版 (表示は 7.3.107 )を hg で取ってきてコンパイルした。ふつうに入った。

昨日はそのとき、自宅 PC の ruby も更新した。それゆえ、ruby と perl , python が vim のスクリプトから使えるほうの拡張版が動かなくなった。gvim に使っていて、ないと困るので今日再コンパイル。

再コンパイル時にまた最新ソース (これも表示は 7.3.107 )に更新したら、コンパイルエラー。Undefined routine ExtUtils::ParseXS::error だったかな。

perl の version は 5.14.1。cpanp コマンドを起動して ExtUtils::ParseXS モジュールを入れて、コンパイルは通った。

警告がいくつか流れていたし、perl が動くかテストするためだけの vim script が手許にないので、コンパイルできたってところまでしか確認していないが。とりあえず。

全力で

日常を進める気力が沸かずに眠ってばかりいたので、全力で現実逃避してみた。

mutt のソースの最新を取ってきて自力コンパイルしたり、MakeWorld してみたり、ふた月ほど離れていた mixi のコミュニティの話題に追いつくため、トピックの記事一括ダウンロードのスクリプト書いたり。

見るトピックがわかっていれば、スクリプト書かなくてもブラウザから全記事を見れば良い 、正しい。単に頭の体操としてスクリプト書いて遊んでいただけだ。

単に遊んでいるだけ。

mutt のコンパイル手順

1. もし hg コマンドが使えないならば mercurial をインストール
2. $ hg clone hg clone http://dev.mutt.org/hg/mutt workdir
3. $ cd workdir ; ./prepare configureOptions
4. $ make && sudo make install

私が configure オプションスを与えるのに使ったスクリプト

./prepare \
--prefix=/usr/develop \
--enable-pgp \
--disable-pop \
--enable-imap \
--enable-smtp \
--enable-debug \
--enable-inodesort \
--disable-nfs-fix \
--disable-mailtool \
--enable-locales-fix \
--enable-exact-address \
--enable-hcache --with-gdbm --without-bdb --with-tokyocabinet \
--enable-iconv \
--with-regex \
--with-ssl=/usr \
--with-gnutls=/usr/local \
--with-sasl=/usr/local \
--with-idn=/usr/local \

インストール先が /usr/develop てのは相当苦しいが、/usr/local に入れた ports からの 安定 version と別にしたかった

ports の版と違い、データベースファイルに tokyocabinet は使えないので、じつはこれを動かすと警告が出る。

GNU make でなく、BSD に元からある make が使えたのはうれしかった。気分の問題でしかないが。

いまはこんな設定を加えた。

yaemon@bouon-an$ alias muttd
alias muttd='/usr/develop/bin/mutt -F /home/yaemon/dotfiles/.muttrc-develop  -d 1'
yaemon@bouon-an$ diff ~/dotfiles/.muttrc{,-develop}
21,21
< set smtp_pass=Secret
---
> # 送信パスワードは、本家の版では保存されない。コメントアウトしておいて毎回入力
25a25,28
>
> set header_cache=/home/yaemon/var/mutt/CachesGDB/header
> set message_cachedir=/home/yaemon/var/mutt/CachesGDB/body
> set pager=

fetchMixiBBS

車輪の再発明 とかいわない。運動をしたら汗をかくようなもので、全力で現実逃避したら成果ができる。それだけ。

Objective でない考え方でスクリプトが設計できないってだけのバカです。

$ cat ~/bin/fetchMixiBBS
#!/usr/bin/env perl
#
#       $Id: fetchMixiBBS,v 1.1 2010/08/29 00:16:11 yaemon Exp $
#
use strict;
use warnings;
use FileHandle;
use WWW::Mixi::Scraper;

use lib( "/home/yaemon/lib/perl" );
use MixiToRFC2822::BBSWrapper qw( id subject pop );

sub checkMaildir($);
sub getMessage( $$ );

my $mixi = WWW::Mixi::Scraper->new(
    'email' => 'EmailAddressForLogin' ,
    'password' => 'PasswordForMixi' ,
);

my $storeDir = $ENV{ 'HOME' } . "/Maildir/mixi/";
checkMaildir( $storeDir );



my $list = new FileHandle( "< $ARGV[0]" );
if ( ! defined( $list ) )
{
    die "Can't open $ARGV[0]:$!";
}

while( my $line = $list->getline )
{
    chomp( $line);
    $line =~ s/#.*//;
    if ( $line !~ /^[0-9]+$/ )
    {
        next;
    }

    getMessage( $mixi , $line);
}

sub checkMaildir( $ )
{
    my $maildir = shift;
    if ( ! -d $maildir )
    {
        mkdir( $maildir ) or die "Can't mkdir $maildir:$!";
    }
    if ( ! -d "$maildir/new" )
    {
        mkdir( "$maildir/new" ) or die "Can't mkdir $maildir/new:$!";
        mkdir( "$maildir/cur" ) or die "Can't mkdir $maildir/cur:$!";
        mkdir( "$maildir/tmp" ) or die "Can't mkdir $maildir/tmp:$!";
    }
}

sub getMessage( $$ )
{
    my $account = shift;
    my $bbs     = shift;

    my $all = $account->parse( "/view_bbs.pl?id=$bbs&page=all" );
    if ( defined ( $all ) )
    {
        printf STDERR "%s: %s fetch success\n" , my $datestr = localtime() , $bbs ;
    }
    else
    {
        die( "Can't get $bbs. retry not implimented" );
    }
    my $board = MixiToRFC2822::BBSWrapper->new( $all );
    my $dir = $storeDir . "/" . 
        $board ->community->id() . '-' . $board->community()->name();

    checkMaildir( $dir );

    while( my $comment = $board->pop() )
    {
        if ( -f $dir . "/new/" . $comment->uniqueName() || 
             glob( $dir . "/cur/" . $comment->uniqueName() . '*' ) )
        {
            return;
        }

        my $out = new FileHandle( "> $dir/new/" . $comment->uniqueName() );
        if ( ! defined( $out ))
        {
            die "Can't open messagefile:$!";
        }
        $out->print(  $comment->message() );
    }
}

$ ls ~/lib/perl/MixiToRFC2822
BBSWrapper.pm
CVS/
Community.pm
Message.pm

$ cat ~/lib/perl/BBSWrapper.pm
#!/usr/bin/env perl
#
#   $Id: BBSWrapper.pm,v 1.1 2010/08/29 00:17:16 yaemon Exp $
#
package MixiToRFC2822::BBSWrapper;
use strict;
use warnings;

use Carp;
use Exporter;
use lib( "/home/yaemon/lib/perl");
use MixiToRFC2822::Community;
use MixiToRFC2822::Message;

use vars qw( $VERSION @ISA @EXPORT_OK );
sub id($);
sub subject($);
sub child($);
sub root($);



our $VERSION = "0.01";
@ISA = qw( Exporter);
@EXPORT_OK = qw( id subject commuity pop);



sub new($$)
{
    my $self = bless {} , shift;
    $self->{ '_data' } = shift;
    return $self;
}

sub id($)
{
    my $self = shift;
    return $self->{ '_id' } if exists $self->{ '_id' } ;
    my @tmp = grep( /^id=/ ,  split( /[\&\?]/ , $self->{'_data'}->{'link'}->opaque ));
    if ( @tmp != 1 ) { die "Can't parse " . $self->{'_data'}->{ '_link' } }
    $self->{'_id'} = $tmp[0];
    $self->{'_id'} =~ s/^id=//;
    return $self->{'_id'};
}

sub community($)
{
    my $self = shift;
    return $self->{'_community'} if exists $self->{ '_community'};

    $self->{'_community'} = MixiToRFC2822::Community->new( $self->{'_data'}->{'community'} );
}

sub subject($)
{
    my $self = shift;
    return $self->{'_data'}->{'subject'};
}

sub root($)
{
    my $self = shift;
    return $self->{ '_root' } if exists $self->{ '_root' } ;
    my $message;
    $message->{'subject'} = $self->subject();
    $message->{'name_link'} = $self->{'_data'}->{'name_link'};
    $message->{'name'} = $self->{'_data'}->{'name'};
    $message->{'time'} = $self->{'_data'}->{'time'};
    $message->{'description'} = $self->{'_data'}->{'description'};
    $message->{'to'} =  $self->community();
    $self->{'_root'} = MixiToRFC2822::Message->new( $message , 'bbs' );
}



sub pop($)
{
    my $self = shift;
    return undef if  exists $self->{'_end'} ;
    my $message = pop( @{ $self->{_data}->{comments}} );
    if ( ! defined( $message ) )
    {
        $self->{'_end'} = 1;
        return $self->root();
    }
    $message->{'reply_to'} = "<" . $self->root()->uniqueName() . ">";
    $message->{'subject'} = "Re: " . $self->subject();
    $message->{'to'} =  $self->community();

    return MixiToRFC2822::Message->new( $message , 'bbs' );
}
1;

$ cat ~/lib/perl/Community.pm

#!/usr/bin/env perl
#
#   $Id: Community.pm,v 1.1 2010/08/29 00:17:16 yaemon Exp $
#
package MixiToRFC2822::Community;
use strict;
use warnings;

use Carp;
use Exporter;
use vars qw( $VERSION @ISA @EXPORT_OK );

sub id($);
sub name($);

our $VERSION = "0.01";
@ISA = qw( Exporter);
@EXPORT_OK = qw( id name );


sub new($$)
{
    my $name = shift;
    my $data = shift;
    return bless $data , $name;

}

sub id($)
{
    my $self = shift;
    return $self->{ '_id' } if exists $self->{ '_id' } ;

    $self->{'_id'} = $self->{'link'}->opaque();
    $self->{'_id'} =~ s/.*id=//;

    return $self->{'_id'};
}


sub name($)
{
    return shift->{'name'};
}

1; 

$ cat ~/lib/perl/Message.pm
#!/usr/bin/env perl
#
#   MixiToRFC2822.pm      2010-07-07 yaemon
#   $Id: Message.pm,v 1.1 2010/08/29 00:17:16 yaemon Exp $
#
package MixiToRFC2822::Message;
use strict;
use warnings;
use Carp;
use Exporter;
use Mail::Internet;
use Mail::Header;
use Encode qw/encode/;
use DateTime;
use vars qw( $VERSION @ISA @EXPORT_OK );

sub message($);
sub date( $ );
sub uniqueName($);
sub messageFrom($);

our $VERSION = "0.01";
@ISA = qw( Exporter);
@EXPORT_OK = qw( uniqueName message );


sub new($$$)
{
    my $self = bless {} , shift;
    $self->{ '_message' } = shift;
    $self->{ '_kind' } = shift;

    return $self;
}

sub message($)
{
    my $self = shift;
    return $self->{ '_mailFormat' }->as_string() if exists $self->{ '_mailFormat' };
    my $myAddr = "( T.Nakagawa )  <23211\@mixi.jp>";
    my $otherAddr = sprintf( "( %s )<%d\@mixi.jp> " , 
            encode( 'MIME-Header' , $self->{ '_message'}->{ 'name' } ) ,
        $self->messageFrom() );
    my $header = Mail::Header->new();
    $header->header_hashref(
        { 
        'Subject' => encode( 'MIME_Header' , $self->{ '_message'}->{'subject'} ),
        'MIME-version' => "1.0" ,
        "Message-Id" => sprintf( "<%s\@mixi.jp>" , $self->uniqueName() ),
        'Content-Type' => 'text/plain; charset=utf-8' ,
        'Date' =>  $self->date->strftime( "%a, %d %b %Y %H:%M:%S %z") ,
    } );

    if ( $self->{ '_kind'} eq "inbox" )
    {
        $header->add( 'From' , $otherAddr );
        $header->add( 'To' , $myAddr );
    }
    elsif ( $self->{ '_kind'} eq "outbox" )
    {
        $header->add( 'To' , $otherAddr );
        $header->add( 'From' , $myAddr );
    }
    elsif ( $self->{ '_kind' } eq "bbs" )
    {
        $header->add( 'From' , $otherAddr );
        $header->add( 'To' , sprintf( "( %s )<%s%%community\@mixi.jp>" ,
                encode( 'MIME-Header' , 
                    $self->{'_message'}->{'to'}->name() ) ,
                    $self->{'_message'}->{'to'}->id() ) );
        if ( exists( $self->{'_message'}->{'reply_to'} ) )
        {
            $header->add( 'In-Reply-To' , $self->{'_message'}->{'reply_to'} );
        }
    }
    else
    {
        die "Not implementd messagebox:$self->{'_kind'}";
    }


    my $body = encode( 'utf-8' , $self->{ '_message' }->{ 'description'} );
    $body =~ s/&#(\d+);/pack("W" , $1)/meg;

    $self->{ '_mailFormat' } = Mail::Internet->new(
        'Body' => [ map { "$_\r\n"; } split( "<br />" , $body ) ],
        'Header' => $header,
    );

    return $self->{ '_mailFormat' }->as_string();
}


sub uniqueName($)
{
    my $self = shift;
    return $self->{ '_uniqueName' } if exists $self->{ '_uniqueName' } ;
    $self->{ '_uniqueName' } = sprintf( "%d.%s.%s" ,
        $self->date()->epoch() ,
        $self->messageFrom() ,
        "mixi.MixiToRFC2822"
    );

    return $self->{ '_uniqueName' };
}


sub messageFrom($)
{
    my $self = shift;
    return $self->{ '_from' } if exists $self->{ '_from' };
    my $tmp;
    if ( $self->{'_kind'} =~ /box$/ )
    {
        $tmp = $self->{ '_message' }->{ 'link' }->opaque(),
    }
    else
    {
        $tmp = $self->{ '_message' }->{ 'name_link'}->opaque();
    }
    $tmp =~ /id=([0-9]+)/;
    $self->{ '_from' } = $1;
    return $self->{ '_from' };
}
sub date( $ )
{
    my $self = shift;

    return $self->{ '_date'} if exists $self->{ '_date' };


    my @date = split( /[\- :]/ , $self->{ '_message' }->{ 'time' } );

    $self->{ '_date' }  = DateTime->new( 
        "year"  => $date[0] ,
        "month" => $date[1] ,
        "day"   => $date[2] ,
        "hour"  => $date[3] ,
        "minute"    => $date[4] ,
        "second"    => 1 ,
        time_zone   => 'Asia/Tokyo' ,
    );


    $self->{ '_date' };
}


1;

yaemon@bouon-an$  /usr/local/lib/perl5/site_perl/5.12.1/WWW/Mixi/Scraper/Plugin/ViewBBS.pm{.orig,} 
*** /usr/local/lib/perl5/site_perl/5.12.1/WWW/Mixi/Scraper/Plugin/ViewBBS.pm.orig        Sun Aug 29 13:45:12 2010
--- /usr/local/lib/perl5/site_perl/5.12.1/WWW/Mixi/Scraper/Plugin/ViewBBS.pm    Sun Aug 29 06:22:10 2010
***************
*** 36,42 ****
        description => $self->html_or_text;
      process 'dd.bbsContent>dl>dd>div.communityPhoto>table>tr>td',
        'images[]' => $scraper{images};
!     result qw( time subject description name name_link images link );
 };

    # bbs topic is not an array
--- 36,46 ----
        description => $self->html_or_text;
      process 'dd.bbsContent>dl>dd>div.communityPhoto>table>tr>td',
        'images[]' => $scraper{images};
! 
!       process 'p.utilityLinks03>a',
!         _community_name => 'TEXT',
!         _community_link => '@href';
!         result qw( time subject description name name_link images link _community_name _community_link);
 };

    # bbs topic is not an array
***************
*** 84,89 ****
--- 88,103 ----
    }
 $stash->{comments} = \@comments;

+ 
+   $stash->{_community_name} =~ s/.*\[//;
+   $stash->{_community_name} =~ s/\].*//;
+ 
+   $stash->{community}->{name} = $stash->{_community_name};
+   $stash->{community}->{link} = $stash->{_community_link};
+ 
+   undef $stash->{_community_name};
+   undef $stash->{_community_link};
+
 return $stash;
  }

fetchMixi (Message)

リハビリをかねて、mixi で送受信したメール (メッセージ) をローカルのMaildir に保存するスクリプトを書いてみました。

Web::Scraper おもしろい。私が Perl から離れ始めたころにできたモジュールなので知りませんでした。

一年近く前、同様のことをより低レベルのライブラリ HTML::TreeBuilder からスクラッチで書き起こしたら、オブジェクトがスコープを離れて解放されているのに、循環構造ゆえにメモリが開放されずに (いわゆる メモリリーク ) 難儀してほうったらかしなのできわめて興味深いです。解析する時間、取れるかな。

1. ページ取得エラー時のリトライ
2. ライブラリの名前と置くパスがええ加減
3. メールアドレス・パスワードを設定ファイルから読み込む

#!/usr/bin/env perl
#
#        $Id: fetchMixi,v 1.3 2010/07/07 10:08:11 yaemon Exp $
#
use strict;
use warnings;
use FileHandle;
use WWW::Mixi::Scraper;

use lib( "/home/yaemon/lib/perl" );
use MixiToRFC2822 qw(message uniqueName);

sub checkMaildir();
sub getMessage( $$ );

my $mixi = WWW::Mixi::Scraper->new(
    'email' => 'MyAddress' ,
    'password' => 'MyPassword' ,
);

my $maildir = $ENV{ 'HOME' } . "/Maildir/mixi/";
checkMaildir();
getMessage( $mixi , "inbox");
getMessage( $mixi , "outbox" );




sub checkMaildir()
{
    if ( ! -d $maildir )
    {
        mkdir( $maildir ) or die "Can't mkdir $maildir:$!";
    }
    if ( ! -d "$maildir/new" )
    {
        mkdir( "$maildir/new" ) or die "Can't mkdir $maildir/new:$!";
        mkdir( "$maildir/cur" ) or die "Can't mkdir $maildir/cur:$!";
        mkdir( "$maildir/tmp" ) or die "Can't mkdir $maildir/tmp:$!";
    }
}

sub getMessage( $$ )
{
    my $account = shift;
    my $box = shift;

    my $page = 1;

    while ( 1 )
    {
        my @mailInPage = $account->parse( "/list_message.pl?page=$page&box=$box" );
        if ( @mailInPage < 1 )
        {
            return;
        }
        printf STDERR "%s : $box: Page:%03d fetch\n" , my $datestr = localtime() , $page ;
        $page++;
        foreach my $mbox ( @mailInPage )
        {
            foreach my $message ( $account->parse( $mbox->{ 'link' } ) )
            {
                my $rfc2822 = MixiToRFC2822->new( $message , $box );

                if ( -f "$maildir/new/" . $rfc2822->uniqueName() || 
                    glob( "$maildir/cur/" . $rfc2822->uniqueName() . ":*" ) )
                {
                    return;
                }
                my $out = new FileHandle( "> $maildir/new/" . $rfc2822->uniqueName() );
                if ( ! defined( $out ))
                {
                    die "Can't open messagefile:$!";
                }
                $out->print(  $rfc2822->message() );
            }
        }
    }
}
 

#!/usr/bin/env perl
#
#    $Id: MixiToRFC2822.pm,v 1.3 2010/07/07 10:08:29 yaemon Exp $
#
package MixiToRFC2822;
use strict;
use warnings;
use Carp;
use Exporter;
use Mail::Internet;
use Mail::Header;
use Encode qw/encode/;
use DateTime;
use vars qw( $VERSION @ISA @EXPORT_OK );

sub message($);
sub date( $ );
sub uniqueName($);
sub messageFrom($);

our $VERSION = "0.01";
@ISA = qw( Exporter);
@EXPORT_OK = qw( uniqueName message );


sub new($$$)
{
    my $self = bless {} , shift;
    $self->{ '_message' } = shift;
    $self->{ '_kind' } = shift;

    return $self;
}

sub message($)
{
    my $self = shift;
    return $self->{ '_mailFormat' }->as_string() if exists $self->{ '_mailFormat' };
    my $myAddr = "( MyName )  <MyIDNo.\@mixi.jp>";
    my $otherAddr = sprintf( "( %s )<%d\@mixi.jp> " , 
            encode( 'MIME-Header' , $self->{ '_message'}->{ 'name' } ) ,
        $self->messageFrom() );
     my $header = Mail::Header->new();
    $header->header_hashref(
        { 
        'Subject' => encode( 'MIME_Header' , $self->{ '_message'}->{'subject'} ),
        'Subject' => encode( 'MIME_Header' , $self->{ '_message'}->{'subject'} ),
        'MIME-version' => "1.0" ,
        "Message-Id" => sprintf( "<%s\@mixi.jp>" , $self->uniqueName() ),
        'Content-Type' => 'text/plain; charset=utf-8' ,
        'Date' =>  $self->date->strftime( "%a, %d %b %Y %H:%M:%S %z") ,
    } );

    if ( $self->{ '_kind'} eq "inbox" )
    {
        $header->add( 'From' , $otherAddr );
        $header->add( 'To' , $myAddr );
    }
    elsif ( $self->{ '_kind'} eq "outbox" )
    {
        $header->add( 'To' , $otherAddr );
        $header->add( 'From' , $myAddr );
    }
    else
    {
        die "Not implementd messagebox:$self->{'_kind'}";
    }


    my $body = encode( 'utf-8' , $self->{ '_message' }->{ 'description'} );
    $body =~ s/&#(\d+);/pack("W" , $1)/meg;

    $self->{ '_mailFormat' } = Mail::Internet->new(
        'Body' => [ map { "$_\r\n"; } split( "<br />" , $body ) ],
        'Header' => $header,
    );

    return $self->{ '_mailFormat' }->as_string();
}




sub uniqueName($)
{
    my $self = shift;
    return $self->{ '_uniqueName' } if exists $self->{ '_uniqueName' } ;
    $self->{ '_uniqueName' } = sprintf( "%d.%s.%s" ,
        $self->date()->epoch() ,
        $self->messageFrom() ,
        "mixi.MixiToRFC822"
    );

    return $self->{ '_uniqueName' };
}

sub messageFrom($)
{
    my $self = shift;
    return $self->{ '_from' } if exists $self->{ '_from' };
    my $tmp = $self->{ '_message' }->{ 'link' }->as_string();
    $tmp =~ /id=([0-9]+)/;
    $self->{ '_from' } = $1;
    return $self->{ '_from' };
}

sub date( $ )
{
    my $self = shift;

    return $self->{ '_date'} if exists $self->{ '_date' };


    my @date = split( /[\- :]/ , $self->{ '_message' }->{ 'time' } ); # 厳密ではないが充分

    $self->{ '_date' }  = DateTime->new( 
        "year"    => $date[0] ,
        "month"    => $date[1] ,
        "day"    => $date[2] ,
        "hour"    => $date[3] ,
        "minute"    => $date[4] ,
        "second"    => 1 ,
        time_zone    => 'Asia/Tokyo' ,
    );


    $self->{ '_date' };
}




1;

テクニカルな覚え書き -1-

読み返すと、年が明けてから、ひとつとてテクニカルな話題を書いていない。

わっさー 用のボットを作るかもしれない、途中で投げ出すかもしれない。ちょこちょことアイデアだけはある。

昨九月に、ワッサー・ゲイザー という開発コードで、MH 風のメッセージで各記事をまとめて、メーラとして読んだり、高評価をつけるという話をしていた。

そのプロトタイプで、Perl でダウンロードツールを作って自分の記事をローカルに保存してみたりしたが、メモリリークを解消することができずに、これでは公開もできないと放ってある。

その時には、API を使うことにこだわり、さらに API で不足な部分を ユーザ用の Web から取ってくることに頭が凝り固まっていて、先に進まなかった。

2週間ほど前に、Gtalk からメッセージを送受信したら一番楽であることに気づく。気づいたきっかけは、ボット好きのユーザと知り合ったこと。

ならば、私もボット作ってみようじゃないか。もう、自分が読める記事を全部読もうと思わなくなったし、メーラ風のインタフェイスを作る興味も失せたが。リハビリには良いだろう。

というわけで、最初に入れた Perl のモジュールは、Net::XMPP3 。jabber で使われる XMPP プロトコルで、メッセージを送受信するためだ。

Net::XMPP がバグを抱えたまま長くメンテされていないので XMPP3 という名前で bug fix した、のだそうだ。ただし、インストール時のテストプログラムの名前が Net::XMPP のままになっている。

アカウント設定などの周辺作業を了えて、さて、ちょっとテストしようかというところで、PC が壊れて中断していた。

今日、Ports の更新をしていて、p5-Astro というジャンルがあるのに気づいた。

おりしも昨日、発言として 日出・月出・月齢告知 機能をつけると宣言したばかり。ここから使えるものがあるかな ?

Astro::MoonPhase , Astro::SunTime , Astro::Sunrise というのがある。

Astro::SunTime よりも、Astro::Sunrise のほうが、きめ細かな指定ができそうだとインストール開始。タイムゾーンを取得できないと、インストーラがテストで停まる。

PERL_DL_NONLAZY=1 /usr/local/bin/perl "-MExtUtils::Command::MM" "-e" "test_harness(0, 'blib/lib', 'blib/arch')" t/*.t
t/00load.t ....... ok
Subroutine main::ok redefined at t/01basic.t line 9
Cannot determine local time zone
# Looks like you planned 237 tests but ran 232.
# Looks like your test exited with 2 just after 232.
t/01basic.t ...... 
Dubious, test returned 2 (wstat 512, 0x200)
Failed 5/237 subtests 

ports 更新作業をしながらのかたわら、あまり重い処理をさせるのは鬱陶しいので、軽く流す程度に調べていると、CPAN の中には DateTime::Event::Lunar というのもあるのを発見。こちらをまずインストール。

依存で入った、DateTime::Util::Astro が、太陽と月の出入り、月相くらいならば計算できるようだ。私は DateTime 型を他でも使っているので、こちらでテストして、うまくいけば常時稼働環境に仕込むことに決めた。