#!/usr/bin/perl
# -*- CPerl -*-
use strict;
use warnings;
# sparse range structure:
# array of arrayref/number
# single integers represented as number
# contigous ranges as arrayref [LOW,HIGH] inclusive
# given: string "A,B,C,X-Y,Z"
# return: sorted array [A, B, C, [X, Y], Z]
sub parse ($) {
my @elements = split /,/, shift;
foreach (@elements) {
s/\s+//g; # prune whitespace
next unless m/\d+-\d+/; # skip conversion if single integer
$_ = [split /-/, $_]; # convert ranges to arrayrefs
}
# sort range set
@elements = sort {(ref($a)?$a->[0]:$a) <=> (ref($b)?$b->[0]:$b)} @el
+ements;
# merge overlapping loose elements into preceding ranges
for (my $i = 0; $i < $#elements; $i++) {
next unless ref $elements[$i]; # skip single integers
while ($i+1 <= $#elements and $elements[$i+1] <= $elements[$i][1])
{ splice @elements, $i+1, 1 } # remove elements included in r
+ange
}
# coalesce contiguous integers into ranges
for (my $i = 0; $i < $#elements; $i++) {
next if ref $elements[$i]; # skip ranges
if ($elements[$i]+1 == $elements[$i+1]) {
my $j = 1+$i;
$j++ while !ref($elements[$j]) && $elements[$j]+1 == $elements[$
+j+1];
splice @elements, $i, 1+$j-$i, [$elements[$i], $elements[$j]];
}
}
# merge adjacent loose elements into succeeding ranges
for (my $i = 0; $i < $#elements; $i++) {
next if ref $elements[$i]; # skip ranges
next unless ref $elements[$i+1]; # but next element is a range
# There can be at most one such element, since contiguous integers
+ were
# coalesced into ranges above.
if ($elements[$i]+1 == $elements[$i+1][0])
{ splice @elements, $i, 2, [$elements[$i], $elements[$i+1][1]] }
}
# merge adjacent loose elements into preceding ranges
for (my $i = 0; $i < $#elements; $i++) {
next unless ref $elements[$i]; # skip single integers
next if ref $elements[$i+1]; # but next element is a single int
+eger
# There can be at most one such element, since contiguous integers
+ were
# coalesced into ranges above.
if ($elements[$i][1]+1 == $elements[$i+1])
{ splice @elements, $i, 2, [$elements[$i][0], $elements[$i+1]] }
}
# merge overlapping ranges
for (my $i = 0; $i < $#elements; $i++) {
next unless ref $elements[$i] and ref $elements[$i+1];
splice @elements, $i, 2, [$elements[$i][0], $elements[$i+1][1]]
if $elements[$i][1] >= $elements[$i+1][0];
}
# merge adjacent ranges
for (my $i = 0; $i < $#elements; $i++) {
next unless ref $elements[$i] and ref $elements[$i+1];
splice @elements, $i, 2, [$elements[$i][0], $elements[$i+1][1]]
if $elements[$i][1]+1 == $elements[$i+1][0];
}
return \@elements;
}
# given: sorted array from sub parse and integer
# return true if the integer is in the sorted array
sub search ($$) {
my $set = shift;
my $num = shift;
my $left = 0; my $right = $#$set;
my $i = $#$set >> 1; # bitshift for integer /2
while ($left < $right) {
if (ref($set->[$i])) { # evaluate a range
return 1 # number within this range
if $num >= $set->[$i][0] && $num <= $set->[$i][1];
if ($num > $set->[$i][0]) { $left = $i+1 }
else { $right = $i-1 }
} else { # evaluate a single integer
return 1 # number matched
if $num == $set->[$i];
if ($num > $set->[$i]) { $left = $i+1 }
else { $right = $i-1 }
}
$i = ($left + $right) >> 1; # bitshift for integer /2
}
# last check
if (ref($set->[$i])) {
return $num >= $set->[$i][0] && $num <= $set->[$i][1]
} else {
return $num == $set->[$i]
}
}
# given: sorted array from sub parse
# return: closure accepting an integer and returning true iff it is in
+ the set
sub wrap ($) {
my $set = shift;
return sub { return search $set, shift };
}
# given: sorted array from sub parse
# return: closure same as from wrap but using unrolled binary search
sub compile ($) {
my $set = shift;
my $expand; $expand = sub {
my $mid = $#_ >> 1;
my $branchcond; my $matchcond;
if (ref $_[$mid]) { # pivot on range
$branchcond = "\$X > $_[$mid][0]";
$matchcond = "\$X >= $_[$mid][0] && \$X <= $_[$mid][1]";
} else { # pivot on single integer
$branchcond = "\$X > $_[$mid]";
$matchcond = "\$X == $_[$mid]";
}
my $fragment = " return $matchcond;\n";
if ($mid+1 <= $#_) {
$fragment =
(" return 1 if $matchcond;\n".
" if ($branchcond) {\n".
$expand->(@_[$mid+1 .. $#_]).
" }");
if ($mid-1 >= 0) {
$fragment .=
(" else {\n".
$expand->(@_[0 .. $mid-1]).
" }\n");
} else {
$fragment .= "\n";
}
}
return $fragment
};
my $tree = $expand->(@$set);
return eval <<CODE
sub {
my \$X = shift;
$tree
return !1; # false value for no match if end reached
}
CODE
}
my $Set = parse shift;
my $Test = wrap $Set;
my $Clos = compile $Set;
use Data::Dumper;
print Data::Dumper->new([$Set],[qw(Set)])->Indent(0)->Dump,"\n";
print Data::Dumper->new([$Clos], [qw(Closure)])->Deparse(1)->Dump;
sub sym ($) { $_[0] ? 'X' : ' ' }
printf "%4s | basic | wrapped | compile\n", '';
foreach (@ARGV) {
printf "%4d | %1s | %1s | %1s\n",
$_, sym(search $Set, $_), sym($Test->($_)), sym($Clos->($_));
}
Edit 2021-02-02 by jcb: Use B::Deparse with Data::Dumper to also output the compiled closure. (line 169 inserted) | 