File Coverage

blib/lib/Set/IntSpan.pm

Criterion	Covered	Total	%
statement	760	771	98.5
branch	347	364	95.3
condition	169	179	94.4
subroutine	86	88	97.7
pod	51	61	83.6
total	1413	1463	96.5

package Set::IntSpan;

use 5;
use if $Set::IntSpan::integer, qw(integer);
use strict;
use base qw(Exporter);
use Carp;

our $VERSION   = '1.19';
our @EXPORT_OK = qw(grep_set map_set grep_spans map_spans);

use overload
    '+'    => 'union'     ,
    '-'    => 'diff'      ,
    '*'    => 'intersect' ,
    '^'    => 'xor'       ,
    '~'    => 'complement',

    '+='   => 'U'	  ,
    '-='   => 'D'	  ,
    '*='   => 'I'	  ,
    '^='   => 'X'	  ,

    'eq'   => 'set_eq' 	  ,
    'ne'   => 'set_ne' 	  ,
    'lt'   => 'set_lt' 	  ,
    'le'   => 'set_le' 	  ,
    'gt'   => 'set_gt' 	  ,
    'ge'   => 'set_ge' 	  ,

    '<=>'  => 'spaceship' ,
    'cmp'  => 'spaceship' ,

    '""'   => 'run_list'  ,
    'bool' => sub { not shift->empty };

sub _reorder # restore the order of args that are reversed by operator overloads
{
    if ($_[2])
    {
	my $temp = $_[0];
	$_[0] = $_[1];
	$_[1] = $temp;
    }
}

sub set_eq
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);
    $a->equal($b)
}

sub set_le
{
    my($a, $set_spec, $reverse) = @_;
    my $b = $a->_real_set($set_spec);
    _reorder($a, $b, $reverse);
    $a->subset($b)
}

sub set_ge
{
    my($a, $set_spec, $reverse) = @_;
    my $b = $a->_real_set($set_spec);
    _reorder($a, $b, $reverse);
    $a->superset($b)
}

sub set_ne {             not &set_eq }
sub set_lt { &set_le and not &set_eq }
sub set_gt { &set_ge and not &set_eq }


sub set_cmp
{
    my($a, $b, $reverse) = @_;
    $b = $a->_real_set($b);

    _reorder($a, $b, $reverse);

    $a->equal($b) ? 0 : 1;
}


sub spaceship
{
    my($a, $b, $reverse) = @_;
    ref $a and $a = $a->size;
    ref $b and $b = $b->size;

    _reorder($a, $b, $reverse);

    $a ==  $b and return  0;
    $a <   0  and return  1;
    $b <   0  and return -1;
    $a <=> $b
}


$Set::IntSpan::Empty_String = '-';


sub new
{
    my($this, $set_spec, @set_specs) = @_;

    my $class = ref($this) || $this;
    my $set   = bless { }, $class;
    $set->{empty_string} = \$Set::IntSpan::Empty_String;
    $set->copy($set_spec);

    while (@set_specs)
    {
	$set = $set->union(shift @set_specs);
    }

    $set
}


sub valid
{
    my($this, $run_list) = @_;
    my $class = ref($this) || $this;
    my $set   = new $class;

    eval { $set->_copy_run_list($run_list) };
    $@ ? 0 : 1
}


sub copy
{
    my($set, $set_spec) = @_;

  SWITCH:
    {
	defined $set_spec            or  $set->_copy_empty   (         ), last;
	ref     $set_spec            or  $set->_copy_run_list($set_spec), last;
	ref     $set_spec eq 'ARRAY' and $set->_copy_array   ($set_spec), last;
				         $set->_copy_set     ($set_spec)      ;
    }

    $set
}


sub _copy_empty			# makes $set the empty set
{
    my $set = shift;

    $set->{negInf} = 0;
    $set->{posInf} = 0;
    $set->{edges } = [];
}


sub _copy_array			# copies an array into a set
{
    my($set, $array) = @_;

    my @spans    = 		      grep { ref     } @$array;
    my @elements = sort { $a <=> $b } grep { not ref } @$array;

    my @span;
    for my $e (@elements)
    {
	if (@span==0)
	{
	    push @span, $e;
	}
	elsif (@span==1 and $e==$span[0]+1)
	{
	    push @span, $e;
	}
	elsif (@span==1 and $e >$span[0]+1)
	{
	    push @spans, [ $span[0], $span[0] ];
	    @span = ($e);
	}
	elsif (@span==2 and $e==$span[1]+1)
	{
	    $span[1] = $e;
	}
	elsif (@span==2 and $e >$span[1]+1)
	{
	    push @spans, [ @span ];
	    @span = ($e);
	}
    }

    @span==1 and push @spans, [ $span[0], $span[0] ];
    @span==2 and push @spans, [ @span ];

    $set->_insert_spans(\@spans)
}

sub bySpan
{
    my($al, $au) = @$a;
    my($bl, $bu) = @$b;

       if (defined $al && defined $bl) { return $al <=> $bl; }
    elsif (defined $al               ) { return  1;          }
    elsif (               defined $bl) { return -1;          }
    elsif (defined $au               ) { return -1;          }
    elsif (               defined $bu) { return  1;          }
    else                               { return  0;          }
}

sub _insert_spans
{
    my($set, $spans) = @_;

    my @edges;
    $set->{negInf} = 0;
    $set->{posInf} = 0;
    $set->{edges } = \@edges;

    my @spans = sort bySpan @$spans;

    if (@spans and not defined $spans[0][0])
    {
	$set->{negInf} = 1;
	my $span = shift @spans;

	if (not defined $span->[1])
	{
	    $set->{posInf} = 1;
	    return $set;
	}

	push @edges, $span->[1];

	while (@spans and not defined $spans[0][0])
	{
	    my $span = shift @spans;
	    $edges[0] = $span->[1] if $edges[0] < $span->[1];
	}
    }

    for (@spans) { $_->[0]--; }

    if (@spans and not @edges)
    {
	my $span = shift @spans;

	if (defined $span->[1])
	{
	    push @edges, @$span;
	}
	else
	{
	    push @edges, $span->[0];
	    $set->{posInf} = 1;
	    return $set;
	}
    }

    while (@spans and defined $spans[0][1])
    {
	my $span = shift @spans;
	if ($edges[-1] < $span->[0])
	{
	    push @edges, @$span;
	}
	else
	{
	    $edges[-1] = $span->[1] if $edges[-1] < $span->[1];
	}
    }

    if (@spans)
    {
	$set->{posInf} = 1;
	my $span = shift @spans;

	if ($edges[-1] < $span->[0])
	{
	    push @edges, $span->[0];
	}
	else
	{
	    pop @edges;
	}
    }

    return $set
}


sub _copy_set			# copies one set to another
{
    my($dest, $src) = @_;

    $dest->{negInf} =     $src->{negInf};
    $dest->{posInf} =     $src->{posInf};
    $dest->{edges } = [ @{$src->{edges }} ];
}


sub _copy_run_list		# parses a run list
{
    my($set, $runList) = @_;

    $set->_copy_empty;

    $runList =~ s/\s|_//g;
    return if $runList eq '-';	# empty set

    my($first, $last) = (1, 0);	# verifies order of infinite runs

    my @edges;
    for my $run (split(/,/ , $runList))
    {
    	croak "Set::IntSpan::_copy_run_list: Bad order 1: $runList\n" if $last;

      RUN:
    	{
	    $run =~ /^ (-?\d+) $/x and do
	    {
		push(@edges, $1-1, $1);
		last RUN;
	    };

	    $run =~ /^ (-?\d+) - (-?\d+) $/x and do
	    {
		croak "Set::IntSpan::_copy_run_list: Bad order 2: $runList\n"
		    if $1 > $2;
		push(@edges, $1-1, $2);
		last RUN;
	    };

	    $run =~ /^ \( - (-?\d+) $/x and do
	    {
		croak "Set::IntSpan::_copy_run_list: Bad order 3: $runList\n"
		    unless $first;
		$set->{negInf} = 1;
		push @edges, $1;
		last RUN;
	    };

	    $run =~ /^ (-?\d+) - \) $/x and do
	    {
		push @edges, $1-1;
		$set->{posInf} = 1;
		$last = 1;
		last RUN;
	    };

	    $run =~ /^ \( - \) $/x and do
	    {
		croak "Set::IntSpan::_copy_run_list: Bad order 4: $runList\n"
		    unless $first;
		$last = 1;
		$set->{negInf} = 1;
		$set->{posInf} = 1;
		last RUN;
	    };

	    croak "Set::IntSpan::_copy_run_list: Bad syntax: $runList\n";
	}

	$first = 0;
    }

    $set->{edges} = [ @edges ];

    $set->_cleanup or
	croak "Set::IntSpan::_copy_run_list: Bad order 5: $runList\n";
}


# check for overlapping runs
# delete duplicate edges
sub _cleanup
{
    my $set = shift;
    my $edges = $set->{edges};

    my $i=0;
    while ($i < $#$edges)
    {
	my $cmp = $$edges[$i] <=> $$edges[$i+1];
	{
	    $cmp == -1 and $i++                  , last;
	    $cmp ==  0 and splice(@$edges, $i, 2), last;
	    $cmp ==  1 and return 0;
	}
    }

    1
}


sub run_list
{
    my $set = shift;

    $set->empty and return ${$set->{empty_string}};

    my @edges = @{$set->{edges}};
    my @runs;

    $set->{negInf} and unshift @edges, '(';
    $set->{posInf} and push    @edges, ')';

    while(@edges)
    {
	my($lower, $upper) = splice @edges, 0, 2;

	if ($lower ne '(' and $upper ne ')' and $lower+1==$upper)
	{
	    push @runs, $upper;
	}
	else
	{
	    $lower ne '(' and $lower++;
	    push @runs, "$lower-$upper";
	}
    }

    join(',', @runs)
}

sub dump
{
    my $set = shift;
    ($set->{negInf} ? '(' : '') . join ',', @{$set->{edges}} . ($set->{posInf} ? ')' : '')
}

sub elements
{
    my $set = shift;

    ($set->{negInf} or $set->{posInf}) and
	croak "Set::IntSpan::elements: infinite set\n";

    my @elements;
    my @edges = @{$set->{edges}};
    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);
	push @elements, $lower+1 .. $upper;
    }

    wantarray ? @elements : \@elements
}

sub sets
{
    my $set   = shift;
    my @edges = @{$set->{edges}};

    unshift @edges, undef if $set->{negInf};
    push    @edges, undef if $set->{posInf};

    my @sets;
    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);

	$lower = defined $lower ? $lower+1 : '(';
	$upper = defined $upper ? $upper   : ')';

	push @sets, Set::IntSpan->new("$lower-$upper");
    }

    @sets
}


sub spans
{
    my $set   = shift;
    my @edges = @{$set->{edges}};

    unshift @edges, undef if $set->{negInf};
    push    @edges, undef if $set->{posInf};

    my @spans;
    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);
	$lower++
	    if defined $lower;
	push @spans, [$lower, $upper];
    }

    @spans
}


sub _real_set		# converts a set specification into a set
{
    my($set, $set_spec) = @_;

    (defined $set_spec and ref $set_spec and ref $set_spec ne 'ARRAY') ?
	$set_spec :
	$set->new($set_spec)
}

sub U
{
    my($a, $set_spec) = @_;
    my $s = $a->union($set_spec);
    $a->{negInf} = $s->{negInf};
    $a->{posInf} = $s->{posInf};
    $a->{edges } = $s->{edges };
    $a
}

sub union
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);
    my $s = $a->new;

    $s->{negInf} = $a->{negInf} || $b->{negInf};

    my $eA = $a->{edges};
    my $eB = $b->{edges};
    my $eS = $s->{edges};

    my $inA = $a->{negInf};
    my $inB = $b->{negInf};

    my $iA = 0;
    my $iB = 0;

    while ($iA<@$eA and $iB<@$eB)
    {
	my $xA = $$eA[$iA];
	my $xB = $$eB[$iB];

	if ($xA < $xB)
	{
	    $iA++;
	    $inA = ! $inA;
	    not $inB and push(@$eS, $xA);
	}
	elsif ($xB < $xA)
	{
	    $iB++;
	    $inB = ! $inB;
	    not $inA and push(@$eS, $xB);
	}
	else
	{
	    $iA++;
	    $iB++;
	    $inA = ! $inA;
	    $inB = ! $inB;
	    $inA == $inB and push(@$eS, $xA);
	}
    }

    $iA < @$eA and ! $inB and push(@$eS, @$eA[$iA..$#$eA]);
    $iB < @$eB and ! $inA and push(@$eS, @$eB[$iB..$#$eB]);

    $s->{posInf} = $a->{posInf} || $b->{posInf};
    $s
}


sub I
{
    my($a, $set_spec) = @_;
    my $s = $a->intersect($set_spec);
    $a->{negInf} = $s->{negInf};
    $a->{posInf} = $s->{posInf};
    $a->{edges } = $s->{edges };
    $a
}

sub intersect
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);
    my $s = $a->new;

    $s->{negInf} = $a->{negInf} && $b->{negInf};

    my $eA = $a->{edges};
    my $eB = $b->{edges};
    my $eS = $s->{edges};

    my $inA = $a->{negInf};
    my $inB = $b->{negInf};

    my $iA = 0;
    my $iB = 0;

    while ($iA<@$eA and $iB<@$eB)
    {
	my $xA = $$eA[$iA];
	my $xB = $$eB[$iB];

	if ($xA < $xB)
	{
	    $iA++;
	    $inA = ! $inA;
	    $inB and push(@$eS, $xA);
	}
	elsif ($xB < $xA)
	{
	    $iB++;
	    $inB = ! $inB;
	    $inA and push(@$eS, $xB);
	}
	else
	{
	    $iA++;
	    $iB++;
	    $inA = ! $inA;
	    $inB = ! $inB;
	    $inA == $inB and push(@$eS, $xA);
	}
    }

    $iA < @$eA and $inB and push(@$eS, @$eA[$iA..$#$eA]);
    $iB < @$eB and $inA and push(@$eS, @$eB[$iB..$#$eB]);

    $s->{posInf} = $a->{posInf} && $b->{posInf};
    $s
}


sub D
{
    my($a, $set_spec) = @_;
    my $s = $a->diff($set_spec);
    $a->{negInf} = $s->{negInf};
    $a->{posInf} = $s->{posInf};
    $a->{edges } = $s->{edges };
    $a
}

sub diff
{
    my($a, $set_spec, $reverse) = @_;
    my $b = $a->_real_set($set_spec);

    _reorder($a, $b, $reverse);

    my $s = $a->new;

    $s->{negInf} = $a->{negInf} && ! $b->{negInf};

    my $eA = $a->{edges};
    my $eB = $b->{edges};
    my $eS = $s->{edges};

    my $inA = $a->{negInf};
    my $inB = $b->{negInf};

    my $iA = 0;
    my $iB = 0;

    while ($iA<@$eA and $iB<@$eB)
    {
	my $xA = $$eA[$iA];
	my $xB = $$eB[$iB];

	if ($xA < $xB)
	{
	    $iA++;
	    $inA = ! $inA;
	    not $inB and push(@$eS, $xA);
	}
	elsif ($xB < $xA)
	{
	    $iB++;
	    $inB = ! $inB;
	    $inA and push(@$eS, $xB);
	}
	else
	{
	    $iA++;
	    $iB++;
	    $inA = ! $inA;
	    $inB = ! $inB;
	    $inA != $inB and push(@$eS, $xA);
	}
    }

    $iA < @$eA and not $inB and push(@$eS, @$eA[$iA..$#$eA]);
    $iB < @$eB and     $inA and push(@$eS, @$eB[$iB..$#$eB]);

    $s->{posInf} = $a->{posInf} && ! $b->{posInf};
    $s
}


sub X
{
    my($a, $set_spec) = @_;
    my $s = $a->xor($set_spec);
    $a->{negInf} = $s->{negInf};
    $a->{posInf} = $s->{posInf};
    $a->{edges } = $s->{edges };
    $a
}

sub xor
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);
    my $s = $a->new;

    $s->{negInf} = $a->{negInf} ^ $b->{negInf};

    my $eA = $a->{edges};
    my $eB = $b->{edges};
    my $eS = $s->{edges};

    my $iA = 0;
    my $iB = 0;

    while ($iA<@$eA and $iB<@$eB)
    {
	my $xA = $$eA[$iA];
	my $xB = $$eB[$iB];

	if ($xA < $xB)
	{
	    $iA++;
	    push(@$eS, $xA);
	}
	elsif ($xB < $xA)
	{
	    $iB++;
	    push(@$eS, $xB);
	}
	else
	{
	    $iA++;
	    $iB++;
	}
    }

    $iA < @$eA and push(@$eS, @$eA[$iA..$#$eA]);
    $iB < @$eB and push(@$eS, @$eB[$iB..$#$eB]);

    $s->{posInf} = $a->{posInf} ^ $b->{posInf};
    $s
}


sub complement
{
    my $set = shift;
    $set->new($set)->C
}

sub C
{
    my $set = shift;
    $set->{negInf} = ! $set->{negInf};
    $set->{posInf} = ! $set->{posInf};
    $set
}


sub superset
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);

    $b->diff($a)->empty
}


sub subset
{
    my($a, $b) = @_;

    $a->diff($b)->empty
}


sub equal
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);

    $a->{negInf} == $b->{negInf} or return 0;
    $a->{posInf} == $b->{posInf} or return 0;

    my $aEdge = $a->{edges};
    my $bEdge = $b->{edges};
    @$aEdge == @$bEdge or return 0;

    for (my $i=0; $i<@$aEdge; $i++)
    {
	$$aEdge[$i] == $$bEdge[$i] or return 0;
    }

    1
}


sub equivalent
{
    my($a, $set_spec) = @_;
    my $b = $a->_real_set($set_spec);

    $a->cardinality == $b->cardinality
}


sub cardinality
{
    my $set = shift;

    ($set->{negInf} or $set->{posInf}) and return -1;

    my $cardinality = 0;
    my @edges = @{$set->{edges}};
    while (@edges)
    {
	my $lower = shift @edges;
	my $upper = shift @edges;
	$cardinality += $upper - $lower;
    }

    $cardinality
}

*size = \&cardinality;


sub empty
{
    my $set = shift;

    not $set->{negInf} and not @{$set->{edges}} and not $set->{posInf}
}


sub finite
{
    my $set = shift;

    not $set->{negInf} and not $set->{posInf}
}


sub neg_inf { shift->{negInf} }
sub pos_inf { shift->{posInf} }


sub infinite
{
    my $set = shift;

    $set->{negInf} or $set->{posInf}
}


sub universal
{
    my $set = shift;

    $set->{negInf} and not @{$set->{edges}} and $set->{posInf}
}


sub member
{
    my($set, $n) = @_;

    my $i = _bsearch($set->{edges}, $n);

    $set->{negInf} xor $i & 1
}

use constant INSERT => 0;
use constant REMOVE => 1;

sub insert { _indel(@_, INSERT); }
sub remove { _indel(@_, REMOVE); }

sub _indel # INsertion/DELetion
{
    my($set, $n, $indel) = @_;
    defined $n or return;

    my $edge = $set->{edges};
    my $i    = _bsearch($edge, $n);

    return if $set->{negInf} xor $i & 1 xor $indel;

    my $lGap = $i==0      || $edge->[$i-1] < $n-1;
    my $rGap = $i==@$edge || $n            < $edge->[$i];

    if    (    $lGap and     $rGap) { splice @$edge, $i, 0, $n-1, $n }
    elsif (not $lGap and     $rGap) { $edge->[$i-1]++                }
    elsif (    $lGap and not $rGap) { $edge->[$i  ]--                }
    else                            { splice @$edge, $i-1, 2         }
}

# Returns the index of the first edge that satisifies target <= edge.
# Returns $#$edges+1 if target > the last edge.
# Returns 0 if edges is empty.
sub _bsearch
{
    my($edges, $target) = @_;

    @$edges or return 0;

    my $lower = 0;
    my $upper = $#$edges;

    while ($lower+1 < $upper)
    {
	my $mid = int(($lower + $upper) / 2);

	if ($target <= $edges->[$mid])
	{
	    $upper = $mid;
	}
	else
	{
	    $lower = $mid+1;
	}
    }

    $target <= $edges->[$lower] and return $lower;
    $target <= $edges->[$upper] and return $upper;
    $upper + 1
}

sub span_ord
{
    my($set, $n) = @_;

    my $i = _bsearch($set->{edges}, $n);
    ($set->{negInf} xor $i & 1) ? $i >> 1 : undef
}

sub min
{
    my $set = shift;

    $set->empty   and return undef;
    $set->neg_inf and return undef;
    $set->{edges}->[0]+1
}


sub max
{
    my $set = shift;

    $set->empty   and return undef;
    $set->pos_inf and return undef;
    $set->{edges}->[-1]
}

sub cover
{
    my $set    = shift;
    my $cover  = $set->new();
    my $edges  = $set->{edges};
    my $negInf = $set->{negInf};
    my $posInf = $set->{posInf};

    if ($negInf and $posInf)
    {
	$cover->{negInf}   = 1;
	$cover->{posInf}   = 1;
    }
    elsif ($negInf and not $posInf)
    {
	$cover->{negInf}   = 1;
	$cover->{edges}[0] = $set->{edges}[-1];
    }
    elsif (not $negInf and $posInf)
    {
	$cover->{edges}[0] = $set->{edges}[0];
	$cover->{posInf}   = 1;
    }
    elsif (@$edges)
    {
	$cover->{edges}[0] = $set->{edges}[ 0];
	$cover->{edges}[1] = $set->{edges}[-1];
    }

    $cover
}

*extent = \&cover;


sub holes
{
    my $set    = shift;
    my $holes  = $set->new($set);
    my $edges  = $holes->{edges};
    my $negInf = $holes->{negInf};
    my $posInf = $holes->{posInf};

    if ($negInf and $posInf)
    {
	$holes->{negInf}   = 0;
	$holes->{posInf}   = 0;
    }
    elsif ($negInf and not $posInf)
    {
	$holes->{negInf}   = 0;
	pop   @$edges;
    }
    elsif (not $negInf and $posInf)
    {
	shift @$edges;
	$holes->{posInf}   = 0;
    }
    elsif (@$edges)
    {
	shift @$edges;
	pop   @$edges;
    }

    $holes
}

sub inset
{
    my($set, $n) = @_;
    my $edges = $set->{edges};
    my @edges = @$edges;

    my $inset = $set->new();
    $inset->{negInf} = $set->{negInf};
    $inset->{posInf} = $set->{posInf};

    my @inset;
    my $nAbs = abs $n;

    if (@edges and ($inset->{negInf} xor $n < 0))
    {
	my $edge = shift @edges;
	push @inset, $edge - $nAbs;
    }

    while (@edges > 1)
    {
	my($lower, $upper) = splice(@edges, 0, 2);
	$lower += $nAbs;
	$upper -= $nAbs;

	push @inset, $lower, $upper
	    if $lower < $upper;
    }

    if (@edges)
    {
	my $edge = shift @edges;
	push @inset, $edge + $nAbs;
    }


    $inset->{edges} = \@inset;
    $inset
}

*trim = \&inset;

sub pad
{
    my($set, $n) = @_;
    $set->inset(-$n)
}


sub grep_set(&$)
{
    my($block, $set) = @_;

    return undef if $set->{negInf} or $set->{posInf};

    my @edges     = @{$set->{edges}};
    my @sub_edges = ();

    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);

	for (my $i=$lower+1; $i<=$upper; $i++)
	{
	    local $_ = $i;
	    &$block() or next;

	    if (@sub_edges and $sub_edges[-1] == $i-1)
	    {
		$sub_edges[-1] = $i;
	    }
	    else
	    {
		push @sub_edges, $i-1, $i;
	    }
	}
    }

    my $sub_set = $set->new;
    $sub_set->{edges} = \@sub_edges;
    $sub_set
}


sub map_set(&$)
{
    my($block, $set) = @_;

    return undef if $set->{negInf} or $set->{posInf};

    my $map_set = $set->new;

    my @edges = @{$set->{edges}};
    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);

	my $domain;
	for ($domain=$lower+1; $domain<=$upper; $domain++)
	{
	    local $_ = $domain;

	    my $range;
	    for $range (&$block())
	    {
		$map_set->insert($range);
	    }
	}
    }

    $map_set
}


sub grep_spans(&$)
{
    my($block, $set) = @_;

    my @edges     = @{$set->{edges}};
    my $sub_set   = $set->new;
    my @sub_edges = ();

    if ($set->{negInf} and $set->{posInf})
    {
	local $_ = [ undef, undef ];
	if (&$block())
	{
	    $sub_set->{negInf} = 1;
	    $sub_set->{posInf} = 1;
	}
    }
    elsif ($set->{negInf})
    {
	my $upper = shift @edges;
	local $_ = [ undef, $upper ];
	if (&$block())
	{
	    $sub_set->{negInf} = 1;
	    push @sub_edges, $upper;
	}
    }

    while (@edges > 1)
    {
	my($lower, $upper) = splice(@edges, 0, 2);
	local $_ = [ $lower+1, $upper ];
	&$block() and push @sub_edges, $lower, $upper;
    }

    if (@edges)
    {
	my $lower = shift @edges;
	local $_ = [ $lower+1, undef ];
	if (&$block())
	{
	    $sub_set->{posInf} = 1;
	    push @sub_edges, $lower;
	}
    }

    $sub_set->{edges} = \@sub_edges;
    $sub_set
}

sub map_spans(&$)
{
    my($block, $set) = @_;

    my @edges = @{$set->{edges}};
    my @spans;

    if ($set->{negInf} and $set->{posInf})
    {
	local $_ = [ undef, undef ];
	push @spans, &$block();
    }
    elsif ($set->{negInf})
    {
	my $upper = shift @edges;
	local $_ = [ undef, $upper ];
	push @spans, &$block();
    }

    while (@edges > 1)
    {
	my($lower, $upper) = splice(@edges, 0, 2);
	local $_ = [ $lower+1, $upper ];
	push @spans, &$block();
    }

    if (@edges)
    {
	my $lower = shift @edges;
	local $_ = [ $lower+1, undef ];
	push @spans, &$block();
    }

    $set->new->_insert_spans(\@spans)
}


sub first($)
{
    my $set   = shift;

    $set->{iterator} = $set->min;
    $set->{run}[0]   = 0;
    $set->{run}[1]   = $#{$set->{edges}} ? 1 : undef;

    $set->{iterator}
}


sub last($)
{
    my $set = shift;

    my $lastEdge     = $#{$set->{edges}};
    $set->{iterator} = $set->max;
    $set->{run}[0]   = $lastEdge ? $lastEdge-1 : undef;
    $set->{run}[1]   = $lastEdge;

    $set->{iterator}
}


sub start($$)
{
    my($set, $start) = @_;

    $set->{iterator} = undef;
    defined $start or return undef;

    my $inSet = $set->{negInf};
    my $edges = $set->{edges};

    for (my $i=0; $i<@$edges; $i++)
    {
	if ($inSet)
	{
	    if ($start <= $$edges[$i])
	    {
		$set->{iterator} = $start;
		$set->{run}[0] = $i ? $i-1 : undef;
		$set->{run}[1] = $i;
		return $start;
	    }
	    $inSet = 0;
	}
	else
	{
	    if ($start <= $$edges[$i])
	    {
		return undef;
	    }
	    $inSet = 1;
	}
    }

    if ($inSet)
    {
	$set->{iterator} = $start;
	$set->{run}[0]   = @$edges? $#$edges: undef;
	$set->{run}[1]   = undef;
    }

    $set->{iterator}
}


sub current($) { shift->{iterator} }


sub next($)
{
    my $set = shift;

    defined $set->{iterator} or return $set->first;

    my $run1 = $set->{run}[1];
    defined $run1 or return ++$set->{iterator};

    my $edges = $set->{edges};
    $set->{iterator} < $edges->[$run1] and return ++$set->{iterator};

    if    ($run1 < $#$edges-1)
    {
	my $run0         = $run1 + 1;
	$set->{run}      = [$run0, $run0+1];
	$set->{iterator} = $edges->[$run0]+1;
    }
    elsif ($run1 < $#$edges)
    {
	my $run0         = $run1 + 1;
	$set->{run}      = [$run0, undef];
	$set->{iterator} = $edges->[$run0]+1;
    }
    else
    {
	$set->{iterator} = undef;
    }

    $set->{iterator}
}


sub prev($)
{
    my $set = shift;

    defined $set->{iterator} or return $set->last;

    my $run0 = $set->{run}[0];
    defined $run0 or return --$set->{iterator};

    my $edges = $set->{edges};
    $set->{iterator} > $edges->[$run0]+1 and return --$set->{iterator};

    if    ($run0 > 1)
    {
	my $run1         = $run0 - 1;
	$set->{run}      = [$run1-1, $run1];
	$set->{iterator} = $edges->[$run1];
    }
    elsif ($run0 > 0)
    {
	my $run1         = $run0 - 1;
	$set->{run}      = [undef, $run1];
	$set->{iterator} = $edges->[$run1];
    }
    else
    {
	$set->{iterator} = undef;
    }

    $set->{iterator}
}

sub at
{
    my($set, $i) = @_;

    $i < 0 ? $set->_at_neg($i) : $set->_at_pos($i)
}

sub _at_pos
{
    my($set, $i) = @_;

    $set->neg_inf and
	croak "Set::IntSpan::at: negative infinite set\n";

    my @edges = @{$set->{edges}};

    while (@edges > 1)
    {
	my($lower, $upper) = splice(@edges, 0, 2);

	my $size = $upper - $lower;

	$i < $size and return $lower + 1 + $i;

	$i -= $size;
    }

    @edges ? $edges[0] + 1 + $i : undef
}

sub _at_neg
{
    my($set, $i) = @_;

    $set->pos_inf and
	croak "Set::IntSpan::at: positive infinite set\n";

    my @edges = @{$set->{edges}};
    $i++;

    while (@edges > 1)
    {
	my($lower, $upper) = splice(@edges, -2, 2);

	my $size = $upper - $lower;

	-$i < $size and return $upper + $i;

	$i += $size;
    }

    @edges ? $edges[0] + $i : undef
}

sub ord
{
    my($set, $n) = @_;

    $set->{negInf} and
	croak "Set::IntSpan::ord: negative infinite set\n";

    defined $n or return undef;

    my $i = 0;
    my @edges = @{$set->{edges}};

    while (@edges)
    {
	my($lower, $upper) = splice(@edges, 0, 2);

	$n <= $lower and return undef;

	if (defined $upper and $upper < $n)
	{
	    $i += $upper - $lower;
	    next;
	}

	return $i + $n - $lower - 1;
    }

    undef
}

sub slice
{
    my($set, $from, $to) = @_;

    $set->{slicing} = 1;
    my $slice = $set->_splice($from, $to - $from + 1);
    $set->{slicing} = 0;

    $slice
}

sub _splice
{
    my($set, $offset, $length) = @_;

    $offset < 0
	? $set->_splice_neg($offset, $length)
	: $set->_splice_pos($offset, $length)
}

sub _splice_pos
{
    my($set, $offset, $length) = @_;

    $set->neg_inf and
	croak "Set::IntSpan::slice: negative infinite set\n";

    my @edges = @{$set->{edges}};
    my $slice = new Set::IntSpan;

    while (@edges > 1)
    {
	my ($lower, $upper) = @edges[0,1];
	my $size = $upper - $lower;

	$offset < $size and last;

	splice(@edges, 0, 2);
	$offset -= $size;
    }

    @edges or
	return $slice;  # empty set

    $edges[0] += $offset;

    $slice->{edges} = $set->_splice_length(\@edges, $length);
    $slice
}

sub _splice_neg
{
    my($set, $offset, $length) = @_;

    $set->pos_inf and
	croak "Set::IntSpan::slice: positive infinite set\n";

    my @edges = @{$set->{edges}};
    my $slice = new Set::IntSpan;

    my @slice;
    $offset++;

    while (@edges > 1)
    {
	my ($lower, $upper) = @edges[-2,-1];
	my $size = $upper - $lower;

	-$offset < $size and last;

	unshift @slice, splice(@edges, -2, 2);
	$offset += $size;
    }

    if (@edges)
    {
	my $upper = pop @edges;
	unshift @slice, $upper+$offset-1, $upper;
    }
    elsif ($set->{slicing})
    {
	$length += $offset-1;
    }

    $slice->{edges} = $set->_splice_length(\@slice, $length);
    $slice
}

sub _splice_length
{
    my($set, $edges, $length) = @_;

    not defined $length   and return $edges;  # everything
    		$length<0 and return $set->_splice_length_neg($edges, -$length);
                $length>0 and return $set->_splice_length_pos($edges,  $length);

    []  # $length==0
}

sub _splice_length_pos
{
    my($set, $edges, $length) = @_;

    my @slice;

    while (@$edges > 1)
    {
	my ($lower, $upper) = @$edges[0,1];
	my $size = $upper - $lower;

	$length <= $size and last;

	push @slice, splice(@$edges, 0, 2);
	$length -= $size;
    }

    if (@$edges)
    {
	my $lower = shift @$edges;
	push @slice, $lower, $lower+$length;
    }

    \@slice
}

sub _splice_length_neg
{
    my($set, $edges, $length) = @_;

    $set->pos_inf and
	croak "Set::IntSpan::slice: positive infinite set\n";

    while (@$edges > 1)
    {
	my($lower, $upper) = @$edges[-2,-1];
	my $size = $upper - $lower;

	$length < $size and last;

	splice(@$edges, -2, 2);
	$length -= $size;
    }

    if (@$edges)
    {
	$edges->[-1] -= $length;
    }

    $edges
}

1

__END__