Hatena::ブログ(Diary)

ヤルキデナイズドだった

Yarukidenized

2011-12-14

[]Perl 6でもっとダイスを振る 16:50 Perl 6でもっとダイスを振る - ヤルキデナイズドだった を含むブックマーク

この記事はPerl 6 Advent Calendar 2011の14日目の記事であるとともに13日目の記事(no title)へのレスポンスでもあります。

さて、僕は TRPG をやったことはありませんが、サイコロを振るのは好きです。いわゆるサイコロバカです。 Larry Wall もきっとサイコロバカなのだと思います。なぜなら Perl 6 には .roll() メソッドがあり、これを使うとサイコロが振れるようになっているからです。どうかしてますね。

say [+] (1..6).roll(10);

これで6面体サイコロを10個振った出目の総和が求められます。

さらに中置演算子を定義すれば TRPG でお馴染みの nDm 記法も使えます。

multi sub infix:<D>(Int:D $n, Int:D $m) {
    (1..$m).roll($n);
}

say [+] 10 D 6;

クリスマスパーティーゲームでうっかりサイコロを用意し忘れたときなどに、インタプリタを起動して上記のコードを華麗に打ち込んでみましょう。賞賛を浴びるかサイコロバカだと思われますよ。

2011-12-12

[]Perl 6でモックテスト 23:53 Perl 6でモックテスト - ヤルキデナイズドだった を含むブックマーク

Perl Advent Calendar 2011の12日目の記事です。

Test::Mock を使うとモックテストが書けます。

use v6;
use Test;
use Test::Mock;

plan 2;

class Dog {
    method bark() {
        say 'bowwow';
    }

    method eat($food) {
    }
}

my $dog = mocked(Dog);

$dog.bark;
$dog.bark;
$dog.eat('fish');

check-mock($dog,
    *.called('bark', times => 2),
    *.called('eat', times => 1, with => \('fish')),
);

だいたい見たまんまですね。*.called('eat', times => 1, with => \('fish')) これは解説が必要かもしれません。 \('fish')Capture オブジェクトを返します。キャプチャとは、ざっくりいうと関数呼び出しのカッコの中身をそのまま保持するオブジェクトです。実際に $dog.eat() に渡された引数のキャプチャと、 with オプションで指定したキャプチャをスマートマッチで比較し、一致すればテスト成功ということになります。

with オプションには *.called('eat', times => 1, with => :(Str)) このように Signature オブジェクトを渡すこともできます。シグネチャは関数定義のカッコの中身(仮引数の並び)を保持するオブジェクトです。シグネチャを渡すと、$dog.eat() に渡された引数がシグネチャにマッチするか(つまり、そのようなシグネチャを持つ関数が仮に存在するとして、その引数で呼び出すことができるか)をチェックします。

2011-12-04

[]Perl6で自動国際化クラス 23:35 Perl6で自動国際化クラス - ヤルキデナイズドだった を含むブックマーク

Perl Advent Calendar 2011の4日目の記事です。

メソッド名を英語で考えるの面倒ですよね。適当に日本語でメソッド名をつけたら勝手に翻訳されて英語のメソッド名に変換されたら便利だと思いませんか。 Perl 6ではアレをアレすると日本語のメソッドを英語で呼ぶこともできます。便利ですね。

use v6;
use Trans;

class C {
    method こんにちは() {
        say 'こんにちは、世界';
    }
}

C.hello; # => こんにちは、世界

ヒミツは Perl 6のメタオブジェクトプロトコルにあります。クラスの振る舞いは Metamodel::ClassHOW というメタクラスによって既定されています。 Perl 6のクラス定義文は、実際には Metamodel::ClassHOW の各メソッドの呼び出しに変換されます。あるクラスオブジェクトメソッドを追加する Metamodel::ClassHOW#add_method を上書きすることによって、追加されるメソッド名に手を加えたりもできるのです。

# Trans.pm6
my class TransClassHOW is Metamodel::ClassHOW is Mu {
    # いろいろ追加しましょう
    my %dict = <
        こんにちは hello
    >;

    my sub translate($name) {
        %dict.exists($name) ?? %dict{$name} !! $name;
    }

    method add_method(Mu $obj, $name, $meth) {
        Mu.HOW.add_method($obj, translate($name), $meth);
    }
}

my module EXPORTHOW {}
EXPORTHOW.WHO.<class> = TransClassHOW;

2010-12-13

[]Perl 6 Coding Contest 始まった! 01:12 Perl 6 Coding Contest 始まった! - ヤルキデナイズドだった を含むブックマーク

もう一度言う!Perl 6 Coding Contest 始まった!

5つの課題に解答すると100ユーロ相当のお好きな本が送られてくる!かも!

というわけで Carl Mäsak さん主催のコーディングコンテストが始まりました。課題は次の5つ:

  • 2つ以上の行列を掛ける際にスカラ演算が最も少なくなる順番を探せ
  • ある点が多角形の内側に含まれるかどうか判定せよ
  • ある値が与えられた複数の範囲に含まれるかどうか判定せよ
  • 石取りゲームに勝利するコンピュータプレイヤーを作れ
  • 2つの文字列に共通する最長の部分文字列を探せ

詳細はコンテストのページにある各課題の zip ファイルを参照してください。

12月23日までに cmasak [at] gmail.com に参加の意思を伝え、来年1月14日までに課題を送信しましょう。運が良ければ Amazon wishlist 経由で本が送られてきます。

2010-11-27

[]Perl 6 で Brainfuck interpreter 書いた 13:28 Perl 6 で Brainfuck interpreter 書いた - ヤルキデナイズドだった を含むブックマーク

とくにヒネリはありません。

https://gist.github.com/717036

use v6;

class Brainfuck {
    has $!buf;
    has $!ptr;

    submethod BUILD(:$buf-size = 1024) {
        $!buf = Buf.new(0 xx $buf-size);
        $!ptr = 0;
    }

    multi method unfuck($self where :!defined: $code) {
        self.new.unfuck($code);
    }

    multi method unfuck($code) {
        my @chars = $code.comb(/ <[ + . , < >  ]> | '-' | '[' | ']' /);
        my $at = 0;
        while @chars[$at] -> $char {
            given $char {
                when '>' { $!ptr++ }
                when '<' { $!ptr-- }
                when '+' { self!incl($!buf[$!ptr]) }
                when '-' { self!decl($!buf[$!ptr]) }
                when '.' { print $!buf[$!ptr].chr }
                when ',' { $!buf[$!ptr] = $*STDIN.getc }
                when '[' { $at = self!find-closing-bracket(@chars, $at) - 1 if $!buf[$!ptr] == 0 }
                when ']' { $at = self!find-opening-bracket(@chars, $at) - 1 if $!buf[$!ptr] != 0 }
                default  { die "Unknown instruction '$_'" }
            }
            $at++;
        }
    }

    method !incr($byte is rw) {
        $byte = $byte < 255 ?? $byte + 1 !! 0;
    }

    method !decr($byte is rw) {
        $byte = $byte > 0 ?? $byte - 1 !! 255;
    }

    method !find-closing-bracket(@chars, $pos is copy) {
        my $unmatch = 1;
        while $unmatch {
            my $char = @chars[++$pos];
            given $char {
                when '[' { $unmatch++ }
                when ']' { $unmatch-- }
                when :!defined { die 'Matching closing bracket not found' }
            }
        }
        $pos;
    }

    method !find-opening-bracket(@chars, $pos is copy) {
        my $unmatch = 1;
        while $unmatch {
            my $char = @chars[--$pos];
            given $char {
                when '[' { $unmatch-- }
                when ']' { $unmatch++ }
                when :!defined { die 'Matching opening bracket not found' }
            }
        }
        $pos;
    }
}