File Coverage

blib/lib/Set/SegmentTree/Builder.pm

Criterion	Covered	Total	%
statement	106	113	93.8
branch	17	26	65.3
condition			n/a
subroutine	22	22	100.0
pod	4	12	33.3
total	149	173	86.1

package Set::SegmentTree::Builder;

use strict;
use warnings;

our $VERSION = '0.06';

use Carp qw/croak confess carp/;
use IO::File;
use Time::HiRes qw/gettimeofday/;
use File::Map qw/map_file/;
use List::Util qw/reduce/;
use Set::SegmentTree::ValueLookup;
use Readonly;

Readonly our $INTERVAL_ID        => 0;
Readonly our $INTERVAL_MIN       => 1;
Readonly our $INTERVAL_MAX       => 2;
Readonly our $ELEMENTARY_MIN     => 0;
Readonly our $ELEMENTARY_MAX     => 1;
Readonly our $TRUE               => 1;
Readonly our $MS_IN_NS           => 1000;
Readonly our $INTERVALS_PER_NODE => 2;

#########################
my $cc  = 0;
my $icc = 0;
#########################

sub new_instance {
    my ( $class, $options ) = @_;
    return bless { locked => 0, segment_list => [], %{ $options || {} } },
        $class;
}

sub build {
    my ($self) = @_;
    $self->build_tree( @{ $self->{segment_list} } );
    return Set::SegmentTree->deserialize( $self->serialize );
}

sub new {
    my ( $class, @list ) = @_;
    my $options = {};
    if ( 'HASH' eq ref @list ) { $options = pop @list; }
    return $class->new_instance($options)->insert(@list);
}

sub insert {
    my ( $self, @list ) = @_;
    confess 'This tree already built. Make a new one' if $self->{locked};
    push @{ $self->{segment_list} }, @list;
    return $self;
}

sub serialize {
    my ($self) = @_;
    confess 'Cannot serialized unlocked tree' if !$self->{locked};

    my $t = Set::SegmentTree::ValueLookup->new(
        root    => $self->{tree},
        nodes   => $self->{nodelist},
        created => time
    );
    return $t->serialize;
}

sub to_file {
    my ( $self, $outfile ) = @_;
    if ( !$self->{locked} ) {
        carp 'you asked for to_file without building first. '
            . 'Building now. This is expensive.'
            . $self->build;
    }
    my $out = IO::File->new( $outfile, '>:raw' );
    $out->print( $self->serialize );
    undef $out;
    return -s $outfile;
}

sub endpoint {
    my ( $self, $offset, $which ) = @_;
    return $self->{elist}->[$offset]->[$which];
}

sub endpoints {
    my ( $self, @endpoints ) = @_;
    my @list = sort { $a <=> $b }
        map { ( $_->[$INTERVAL_MIN], $_->[$INTERVAL_MAX] ) } @endpoints;
    return @list;
}

sub place_intervals {
    my ( $self, @intervals ) = @_;
    foreach my $node ( @{ $self->{nodelist} } ) {
        next if exists $node->{low};
        $node->{segments} = [
            map { $_->[$INTERVAL_ID] } grep {
                       $node->{min} >= $_->[$INTERVAL_MIN]
                    && $node->{max} <= $_->[$INTERVAL_MAX];
            } @intervals
        ];
    }
    return;
}

sub build_elementary_list {
    my ( $self, @segment_list ) = @_;
    my ($elementary) = reduce {
        my ( $d, $c ) = ( $a, $a );
        if ( 'ARRAY' ne ref $a ) {
            $d = [ [ $c, $c ], $c ];
        }
        $c = pop @{$d};
        [ @{$d}, [ $c, $b ], [ $b, $b ], $b ];
    }
    $self->endpoints(@segment_list);
    pop @{$elementary};    # extra bit
    $self->{elist} = $elementary;
    return $elementary;
}

sub build_tree {
    my ( $self, @segment_list ) = @_;
    if ( $self->{locked} ) {
        croak 'This tree is immutable. Build a new one.';
    }
    $self->{locked} = 1;
    my $elementary = $self->build_elementary_list(@segment_list);

    if ( $self->{verbose} ) {
        warn "Building binary tree\n";
    }
    my $st = gettimeofday;
    $self->{tree} = $self->build_binary( 0, $#{$elementary} );
    if ( $self->{verbose} ) {
        my $et = gettimeofday;
        warn "took $cc calls "
            . sprintf( '%0.3f', ( ( $et - $st ) * $MS_IN_NS ) / $cc )
            . ' ms per ('
            . ( $et - $st )
            . " elap)\n";
        warn "placing intervals...\n";
    }
    my $ist = gettimeofday;
    $self->place_intervals(@segment_list);
    my $iet = gettimeofday;
    warn "took $icc segment placements "
        . sprintf( '%0.3f', ( ( $iet - $ist ) * $MS_IN_NS ) / $icc )
        . ' ms per ('
        . ( $iet - $ist )
        . " elapsed)\n"
        if $self->{verbose};
    return $self;
}

# from being offset into elementary list
# to being offset into elementary list
sub build_binary {
    my ( $self, $from, $to ) = @_;
    $cc++;
    my $mid = int( ( $to - $from ) / $INTERVALS_PER_NODE ) + $from;
    my $node = {
        min => $self->endpoint( $from, $ELEMENTARY_MIN ),
        max => $self->endpoint( $to,   $ELEMENTARY_MAX ),
    };

    if ( $from != $to ) {
        $node->{low}  = $self->build_binary( $from,    $mid );
        $node->{high} = $self->build_binary( $mid + 1, $to );
    }
    push @{ $self->{nodelist} }, $node;
    return $#{ $self->{nodelist} };
}

1;
__END__