in reply to Modified Binary Search
For starters,
use strict; use warnings; sub _unsigned_to_signed { return unpack('i', pack('I', $_[0])); } sub binsearch(&$\@) { my ($compare, $value, $array) = @_; # # If the $value is not found in @array, # the 1s complement of where the $value # should be inserted is returned. So, # $value is found if the return value >= 0. # # When compare is called, $a is an alias for $value, # and $b is an alias for the element of the array # against which $a which be compared. # # Example: # # Add $value to sorted @array, if it's not already there. # $idx = binsearch { $a <=> $b } $value, @array; # splice(@array, ~$idx, 0, $value) if $idx < 0; # my $i = 0; my $j = $#$array; return $j if $j == -1; my $ap = do { no strict 'refs'; \*{caller().'::a'} }; my $bp = do { no strict 'refs'; \*{caller().'::b'} }; my $kp = do { no strict 'refs'; \*{caller().'::k'} }; local *$ap; local *$bp; local *$kp; *$ap = \$value; for (;;) { my $k = int(($j-$i)/2) + $i; *$kp = \$k; *$bp = \($array->[$k]); my $cmp = &$compare(); return $k if $cmp == 0; if ($cmp < 0) { $j = $k-1; return _unsigned_to_signed(~$k) if $i > $j; } else { $i = $k+1; return _unsigned_to_signed(~$i) if $i > $j; } } } our $k; for ( # 0 1 2 3 4 5 6 7 8 [ [qw( a b c p q r x w z )], 'p', 'r', 3, 5, 3 ], [ [qw( a b c p q r x w z )], 'd', 'w', 3, 5, 3 ], [ [qw( q q q q q q q q q )], 'p', 'z', 0, 8, 9 ], [ [qw( q q q q q q q q q )], 'q', 'z', 0, 8, 9 ], [ [qw( q q q q q q q q q )], 'r', 'z', 9, 8, 0 ], [ [qw( q q q q q q q q q )], 'a', 'p', 0, -1, 0 ], [ [qw( q q q q q q q q q )], 'a', 'q', 0, 8, 9 ], [ [qw( q q q q q q q q q )], 'a', 'r', 0, 8, 9 ], ) { my ( $array, $beg, $end, $expect_beg_idx, $expect_end_idx, $expect_count ) = @$_; my $beg_idx = binsearch { $a cmp $b || ( $k > 0 && $a eq $array->[$k-1] ? -1 : 0 ) } $beg, @$array; $beg_idx = ~$beg_idx if $beg_idx < 0; my $end_idx = binsearch { $a cmp $b || ( $k < $#$array && $a eq $array->[$k+1] ? +1 : 0 ) } $end, @$array; $end_idx = ~$end_idx - 1 if $end_idx < 0; my $count = $end_idx - $beg_idx + 1; printf("%2d %-5s %2d %-5s %2d %-5s\n", $beg_idx, $beg_idx == $expect_beg_idx ? "(ok)" : "(bad)", $end_idx, $end_idx == $expect_end_idx ? "(ok)" : "(bad)", $count, $count == $expect_count ? "(ok)" : "(bad)", ); }
3 (ok) 5 (ok) 3 (ok) 3 (ok) 5 (ok) 3 (ok) 0 (ok) 8 (ok) 9 (ok) 0 (ok) 8 (ok) 9 (ok) 9 (ok) 8 (ok) 0 (ok) 0 (ok) -1 (ok) 0 (ok) 0 (ok) 8 (ok) 9 (ok) 0 (ok) 8 (ok) 9 (ok)
It can be optimised, of course. In particular, the negating can be removed, the callback can be inlined, and the initial cuts can be used for both searches.
In Section
Seekers of Perl Wisdom