view release on metacpan or  search on metacpan

lib/DBIx/Class/Tree/Mobius.pm  view on Meta::CPAN

package DBIx::Class::Tree::Mobius;
# ABSTRACT: Manage trees of data using the Möbius encoding (nested intervals with continued fraction)

use strict;
use warnings;

use bigint;

use Math::BigFloat;

use base qw/DBIx::Class/;

__PACKAGE__->mk_classdata( 'strict_mode' => 1 );

__PACKAGE__->mk_classdata( 'parent_virtual_column' => 'parent' );

__PACKAGE__->mk_classdata( '_mobius_a_column' => 'mobius_a' );
__PACKAGE__->mk_classdata( '_mobius_b_column' => 'mobius_b' );
__PACKAGE__->mk_classdata( '_mobius_c_column' => 'mobius_c' );
__PACKAGE__->mk_classdata( '_mobius_d_column' => 'mobius_d' );
__PACKAGE__->mk_classdata( '_lft_column' => 'lft' );
__PACKAGE__->mk_classdata( '_rgt_column' => 'rgt' );
__PACKAGE__->mk_classdata( '_is_inner_column' => 'is_inner' );

sub add_mobius_tree_columns {
    my $class = shift;
    my %column_names = @_;

    #workaround SQL::Translator::Producer::MySQL bug
    no bigint;

    foreach my $name (qw/ mobius_a mobius_b mobius_c mobius_d lft rgt is_inner /) {
        next unless exists $column_names{$name};
        my $accessor = "_${name}_column";
        $class->$accessor( $column_names{$name} );
    }

    $class->add_columns(
        $class->_mobius_a_column => { data_type => 'BIGINT', is_nullable => 1, extra => { unsigned => 1} },
        $class->_mobius_b_column => { data_type => 'BIGINT', is_nullable => 1, extra => { unsigned => 1} },
        $class->_mobius_c_column => { data_type => 'BIGINT', is_nullable => 1, extra => { unsigned => 1} },
        $class->_mobius_d_column => { data_type => 'BIGINT', is_nullable => 1, extra => { unsigned => 1} },
        $class->_lft_column => { data_type => 'DOUBLE', is_nullable => 0, default_value => 1, extra => { unsigned => 1} },
        $class->_rgt_column => { data_type => 'DOUBLE', is_nullable => 1, default_value => undef, extra => { unsigned => 1} },
        $class->_is_inner_column => { data_type => "BOOLEAN", default_value => 0, is_nullable => 0 },
        );

    $class->add_unique_constraint( $class->_mobius_a_column . $class->_mobius_c_column, [ $class->_mobius_a_column, $class->_mobius_c_column ] );

    if ($class =~ /::([^:]+)$/) {

        $class->belongs_to( 'parent' => $1 => {
            "foreign.".$class->_mobius_a_column => "self.".$class->_mobius_b_column,
            "foreign.".$class->_mobius_c_column => "self.".$class->_mobius_d_column,
        });

        $class->has_many( '_children' => $1 => {
            "foreign.".$class->_mobius_b_column => "self.".$class->_mobius_a_column,
            "foreign.".$class->_mobius_d_column => "self.".$class->_mobius_c_column,
        }, { cascade_delete => 0 });
      
    }

    Math::BigFloat->accuracy(53); 

}

sub children {
    my $self = shift;
    return $self->is_leaf ? ( wantarray ? () : $self->result_source->resultset->search({ 0 => 1 }) ) : $self->_children(@_);
}

sub root_cond {
    my $self = shift;
        return ( $self->_mobius_b_column => 1, $self->_mobius_d_column => undef );
}

sub inner_cond {
    my $self = shift;
    return $self->_is_inner_column => 1 ;
}

sub leaf_cond {
    my $self = shift;
    return $self->_is_inner_column => 0 ;
}

sub _rational {
    my $i = shift;

    return unless ($i);
    return ($i, 1) unless (scalar @_ > 0);

    my ($num, $den) = _rational(@_);
    return ($num * $i + $den, $num);
}

sub _euclidean {
    my ($a, $c) = (Math::BigInt->new(shift), Math::BigInt->new(shift));
    return unless ($c);
    my ($quo, $rem) = $a->bdiv($c);
    return $rem == 0 ? $quo : ($quo, _euclidean($c, $rem));
}

sub _mobius {
    my $i = shift;

    return (1, 0, 0, 1) unless ($i);
    my ($a, $b, $c, $d) = _mobius(@_);
    return ($i * $a + $c, $i * $b + $d, $a, $b);
}

sub _mobius_encoding {
    my ($a, $b, $c, $d) = _mobius(@_);
    return wantarray ? ($a, $b, $c, $d) : sprintf("(${a}x + $b) / (${c}x + $d)");
}

sub _mobius_path {
    my ($a, $b, $c, $d) = @_;
    my @path = _euclidean($a, $c);