日向夏特殊応援部隊

俺様向けメモ

Moose::Cookbook::Recipe3 - predicate, weak_ref, lazy -

Perl Moose

さらに Recipe3 です。

ソース

package BinaryTree;

use Moose;

has 'node' => (is => 'rw', isa => 'Any');

has 'parent' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_parent',
    weak_ref => 1,
);

has 'left' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_left',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

has 'right' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_right',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

before 'right', 'left' => sub {
    my ($self, $tree) = @_;
    $tree->parent($self) if defined $tree;
};

package main;

use Data::Dump qw(dump);
use Perl6::Say;

sub tree {
    my ($node) = @_;
    BinaryTree->new(node => $node);
}

sub slot {
    my ($tree, $node) = @_;

    unless (defined $tree->node) {
        $tree->node($node);
        return 1;
    }

    if ($tree->node > $node) {
        unless ($tree->has_right) {
            $tree->right(tree($node));
            return 1;
        }
        else {
            return slot($tree->right, $node);
        }
    }
    else {
        unless ($tree->has_left) {
            $tree->left(tree($node));
            return 1;
        }
        else {
            return slot($tree->left, $node);
        }
    }
}

my @nodes = 
    map { $_->[0] }
    sort { $a->[1] <=> $b->[1] }
    map { [ $_, rand ] }
    (1 .. 10);

say dump \@nodes;

my $tree = BinaryTree->new;
slot($tree, $_) for (@nodes);

sub bsort {
    my ($tree, $order, $result) = @_;

    if ($order) {
        bsort($tree->right, $order, $result) if ($tree->has_right);
        push(@$result, $tree->node);
        bsort($tree->left, $order, $result) if ($tree->has_left);
    }
    else {
        bsort($tree->left, $order, $result) if ($tree->has_left);
        push(@$result, $tree->node);
        bsort($tree->right, $order, $result) if ($tree->has_right);
    }
}

my $result = [];
bsort($tree, 1, $result);

say dump $result;

解説

二分探索木と二分木ソート

これは 2分木ソート でいいのかな、多分。二分木 - Wikipedia # 二分探索木 を詳しくは参照して下さい。

特定のノードから見て、親と二つの部分木を持つ構造をクラス表現した物。

ノード毎に値が割り振られているとする。あるノードの左の子およびその全ての子孫ノードの持つ値はそのノードの値より小さく、右の子及びその全ての子孫ノードの持つ値はそのノードの値より大きくなるように構成した二分木を二分探索木 (binary search tree) という。

とあるので、slot 関数ではそのように二分探索木を再帰的に作るような関数になってます。
このようにして出来た二分探索木を、

二分探索木を通りがけ順に探索すると、各ノードの値を大きさ順（あるいは逆順）に得ることができる。

との事なので bsort 関数では昇順、降順を選んでソート出来るようになってます。
まぁアルゴリズムの解説がメインじゃないのでこんな感じで。

predicate 属性オプション、weak_ref 属性オプション

これはいわゆる初期化済みか否かを指定したメソッド名で取れるようになるってオプションです。

has 'parent' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_parent',
    weak_ref => 1,
);

has_parent メソッドが生えるって事ですね。weak_ref 属性オプションは名前のまま、weak reference を使うって事です。循環参照オブジェクトを作る際は必須ですね。

default 属性オプション、lazy 属性オプション

default 属性オプションは d:id:ZIGOROu:20080606:1212753180 でも出てきましたが、今回は CODEREF になってます。

has 'left' => (
    is => 'rw',
    isa => 'BinaryTree',
    predicate => 'has_left',
    lazy => 1,
    default => sub { BinaryTree->new(parent => $_[0]) },
);

これは逆に言えばそのように書かないと、リファレンスやオブジェクトの場合は同じ値が default 値として参照されてしまうので問題になっちゃうので、毎回新たに生成する事を保障する為にそうしているみたいです。

さらに lazy オプションは、

you cannot use the lazy option unless you have set the default option.

との事なので、default 属性オプションが無い場合には lazy 属性オプションは使えません。lazy って言うとタイムキーパーが出来ない id:tomyhero さんを思い出しますね＞＜

で lazy って何かって言えば、実際に値が突っ込まれるまでは初期化を遅らせるって事です。なので再帰的に呼び出す際にも省エネなんだぜって事ですな。

その他

before 'left', 'right' の使い方が素敵ですね。left, right を初期化する際に、さらりと parent を設定してくれる所が小憎らしいですｗ

SEE ALSO