File Coverage

blib/lib/Set/IntSpan/Partition.pm

Criterion	Covered	Total	%
statement	92	92	100.0
branch	7	8	87.5
condition			n/a
subroutine	15	15	100.0
pod	2	2	100.0
total	116	117	99.1

package Set::IntSpan::Partition;
use 5.008000;
use strict;
use warnings;
use base qw(Exporter);
use List::Util qw/min max/;
use List::MoreUtils qw/uniq/;
use List::UtilsBy qw/partition_by nsort_by/;
use List::StackBy;
use Set::IntSpan;

our $VERSION = '0.06';

our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
  intspan_partition
  intspan_partition_map
);

sub _uniq (@) {
  my %h;
  return map { $h{$_}++ == 0 ? $_ : () } @_;
}

sub _add {
  my $rest = shift;

  my @parts = map {
    my $old = $_;

    my $right = $rest->diff($old);
    my $left = $old->diff($rest);
    my $both = $old->intersect($rest);

    $rest = $right;

    grep { !$_->empty } $left, $both

  } @_;

  push @parts, $rest unless $rest->empty;
  return @parts;
}

sub intspan_partition {
  my @parts = ();

  @parts = _add($_, @parts) for @_;

  # TODO: It's not really possible to get non-unique
  # items into the list? But play it safe for now.
  return _uniq @parts;
}

sub intspan_partition_map {

  my @intspans = @_;

  my @stacks =
    stack_by { $_->[0] }
    sort { $a->[0] <=> $b->[0] }
    map {
      my $ix = $_;
      map { [ @$_, $ix ] } $intspans[$_]->spans
    } 0 .. $#intspans;

  return unless @stacks;

  my $min_overall = min(map { $_->[0] } map { @$_ } @stacks);
  my $max_overall = max(map { $_->[1] } map { @$_ } @stacks);

  push @{ $stacks[0] },
    [ $min_overall,
      $max_overall + 1, '' ];

  push @stacks,[
    [ $max_overall + 1,
      $max_overall + 1, '' ] ];

  for (my $ix = 0; $ix < @stacks - 1; ++$ix) {

    my $max = min(
      $stacks[$ix+1][0][0] - 1,
      map { $_->[1] } @{ $stacks[$ix] },
    );

    my @current_stack =
      map { [ $_->[0], min($_->[1], $max), $_->[2] ] }
      @{ $stacks[$ix] };

    my @new_stack =
      grep { $_->[0] <= $_->[1] }
      map { [ $max + 1, $_->[1], $_->[2] ] }
      @{ $stacks[$ix] };

    $stacks[$ix] = \@current_stack;

    if ($max + 1 == $stacks[$ix+1][0][0]) {
      push @{ $stacks[$ix+1] }, @new_stack;
    } else {
      splice @stacks, $ix+1, 0, \@new_stack;
    }

  }

  my %h = partition_by {
    join ',', sort { $a cmp $b } uniq map { $_->[2] } @$_
  } grep {
    scalar @$_
  } @stacks;

  # TODO(bh): this could be nicer:

  my %map;
  while (my ($k, $v) = each %h) {
    for my $in (split/,/, $k) {
      my $class = Set::IntSpan->new([map {
        [ $_->[0], $_->[1] ]
      } grep { $_->[2] eq $in } map { @$_ } @$v]);
      push @{ $map{$in} }, $class;
    }
  }

  delete $map{''};

  return %map;
}

1;

__END__