/
ch-2.pl
128 lines (113 loc) · 8.13 KB
/
ch-2.pl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
#!/usr/local/bin/perl
use strict;
use warnings;
use feature qw(say);
use Test::More;
use Benchmark qw(cmpthese);
my @sols = (
[7,11],[11,13],[13,14],[14,19],[19,21],[21,22],[22,25],[25,26],[26,28],[28,35],[35,37],[37,38],[38,41],[41,42],[42,44],[44,49],[49,50],[50,52],[52,56],[56,67],[67,69],[69,70],[70,73],[73,74],[74,76],[76,81],[81,82],[82,84],[84,88],[88,97],[97,98],[98,100],[100,104],[104,112],[112,131],[131,133],[133,134],[134,137],[137,138],[138,140],[140,145],[145,146],[146,148],[148,152],[152,161],[161,162],[162,164],[164,168],[168,176],[176,193],[193,194],[194,196],[196,200],[200,208],[208,224],[224,259],[259,261],[261,262],[262,265],[265,266],[266,268],[268,273],[273,274],[274,276],[276,280],[280,289],[289,290],[290,292],[292,296],[296,304],[304,321],[321,322],[322,324],[324,328],[328,336],[336,352],[352,385],[385,386],[386,388],[388,392],[392,400],[400,416],[416,448],[255,383],[383,447],[447,479],[479,495],[495,503],[503,507],[507,509],[509,510],[3,5],[5,6],[6,9],[9,10],[10,12],[12,17],[17,18],[18,20],[20,24],[24,33],[33,34],[34,36],[36,40],[40,48],[48,65],[65,66],[66,68],[68,72],[72,80],[80,96],[96,129],[129,130],[130,132],[132,136],[136,144],[144,160],[160,192],[192,257],[257,258],[258,260],[260,264],[264,272],[272,288],[288,320],[320,384],[15,23],[23,27],[27,29],[29,30],[30,39],[39,43],[43,45],[45,46],[46,51],[51,53],[53,54],[54,57],[57,58],[58,60],[60,71],[71,75],[75,77],[77,78],[78,83],[83,85],[85,86],[86,89],[89,90],[90,92],[92,99],[99,101],[101,102],[102,105],[105,106],[106,108],[108,113],[113,114],[114,116],[116,120],[120,135],[135,139],[139,141],[141,142],[142,147],[147,149],[149,150],[150,153],[153,154],[154,156],[156,163],[163,165],[165,166],[166,169],[169,170],[170,172],[172,177],[177,178],[178,180],[180,184],[184,195],[195,197],[197,198],[198,201],[201,202],[202,204],[204,209],[209,210],[210,212],[212,216],[216,225],[225,226],[226,228],[228,232],[232,240],[240,263],[263,267],[267,269],[269,270],[270,275],[275,277],[277,278],[278,281],[281,282],[282,284],[284,291],[291,293],[293,294],[294,297],[297,298],[298,300],[300,305],[305,306],[306,308],[308,312],[312,323],[323,325],[325,326],[326,329],[329,330],[330,332],[332,337],[337,338],[338,340],[340,344],[344,353],[353,354],[354,356],[356,360],[360,368],[368,387],[387,389],[389,390],[390,393],[393,394],[394,396],[396,401],[401,402],[402,404],[404,408],[408,417],[417,418],[418,420],[420,424],[424,432],[432,449],[449,450],[450,452],[452,456],[456,464],[464,480],[127,191],[191,223],[223,239],[239,247],[247,251],[251,253],[253,254],[254,319],[319,351],[351,367],[367,375],[375,379],[379,381],[381,382],[382,415],[415,431],[431,439],[439,443],[443,445],[445,446],[446,463],[463,471],[471,475],[475,477],[477,478],[478,487],[487,491],[491,493],[493,494],[494,499],[499,501],[501,502],[502,505],[505,506],[506,508],[31,47],[47,55],[55,59],[59,61],[61,62],[62,79],[79,87],[87,91],[91,93],[93,94],[94,103],[103,107],[107,109],[109,110],[110,115],[115,117],[117,118],[118,121],[121,122],[122,124],[124,143],[143,151],[151,155],[155,157],[157,158],[158,167],[167,171],[171,173],[173,174],[174,179],[179,181],[181,182],[182,185],[185,186],[186,188],[188,199],[199,203],[203,205],[205,206],[206,211],[211,213],[213,214],[214,217],[217,218],[218,220],[220,227],[227,229],[229,230],[230,233],[233,234],[234,236],[236,241],[241,242],[242,244],[244,248],[248,271],[271,279],[279,283],[283,285],[285,286],[286,295],[295,299],[299,301],[301,302],[302,307],[307,309],[309,310],[310,313],[313,314],[314,316],[316,327],[327,331],[331,333],[333,334],[334,339],[339,341],[341,342],[342,345],[345,346],[346,348],[348,355],[355,357],[357,358],[358,361],[361,362],[362,364],[364,369],[369,370],[370,372],[372,376],[376,391],[391,395],[395,397],[397,398],[398,403],[403,405],[405,406],[406,409],[409,410],[410,412],[412,419],[419,421],[421,422],[422,425],[425,426],[426,428],[428,433],[433,434],[434,436],[436,440],[440,451],[451,453],[453,454],[454,457],[457,458],[458,460],[460,465],[465,466],[466,468],[468,472],[472,481],[481,482],[482,484],[484,488],[488,496],[1,2],[2,4],[4,8],[8,16],[16,32],[32,64],[64,128],[128,256],[63,95],[95,111],[111,119],[119,123],[123,125],[125,126],[126,159],[159,175],[175,183],[183,187],[187,189],[189,190],[190,207],[207,215],[215,219],[219,221],[221,222],[222,231],[231,235],[235,237],[237,238],[238,243],[243,245],[245,246],[246,249],[249,250],[250,252],[252,287],[287,303],[303,311],[311,315],[315,317],[317,318],[318,335],[335,343],[343,347],[347,349],[349,350],[350,359],[359,363],[363,365],[365,366],[366,371],[371,373],[373,374],[374,377],[377,378],[378,380],[380,399],[399,407],[407,411],[411,413],[413,414],[414,423],[423,427],[427,429],[429,430],[430,435],[435,437],[437,438],[438,441],[441,442],[442,444],[444,455],[455,459],[459,461],[461,462],[462,467],[467,469],[469,470],[470,473],[473,474],[474,476],[476,483],[483,485],[485,486],[486,489],[489,490],[490,492],[492,497],[497,498],[498,500],[500,504]);
#is( next_bin_rindex2ns( $_->[0]), $_->[1] ) foreach @sols;exit;
#is( next_bin_rindex2( $_->[0]), $_->[1] ) foreach @sols;exit;
#is( next_bin_rex( $_->[0]), $_->[1] ) foreach @sols;exit;
#is( next_bin_rrev($_->[0]), $_->[1] ) foreach @sols;exit;
#is( next_bin( $_->[0]), $_->[1] ) foreach @sols;exit;
#done_testing();
my @ranges = (
[ 20000, 1..500,1..500,1..500,1..500 ],
[ 20000, 500..2499 ],
[ 20000, 1_047_576..1_049_575 ],
[ 20000, 1_073_740_824..1_073_742_823 ],
);
foreach my $r (@ranges) {
my($c,@n) = @{$r};
cmpthese( $c, {
'rind2x'=> sub { next_bin_rindex2ns($_) foreach @n },
'rind2' => sub { next_bin_rindex2( $_ ) foreach @n },
'rind' => sub { next_bin_rrev( $_ ) foreach @n },
# 'rex' => sub { next_bin_rex( $_ ) foreach @n },
# 'simp' => sub { next_bin($_ ) foreach @n },
});
}
sub next_bin {
my $n = shift;
my $c = (sprintf '%b', $n) =~ tr/1/1/;
while(++$n) {
return $n if $c == ( (sprintf '%b', $n) =~ tr/1/1/ );
}
}
## All numbers can be written in the binary form as
## ^[01]*(01)1*0*$
## This we can match with the regexp..
## /01(1*)(0*)$/
## The next highest number with the same number of bits
## flips the 01 to 10 and switches the 1s with the 0s
## The regex replace is then:
## /01(1*)(0*)$/10$2$1/
sub next_bin_rex {
return oct '0b'.sprintf('0%b',shift) =~ s{01(1*)(0*)$}{10$2$1}r;
}
## We further note we can find the "01" with rindex
## rather than having to use a regex {regex's are expensive}
##
## We also note that to flip 1111000 to 0001111 we don't need to
## know how many 1s there are or 0s we just reverse the string.
##
## This gives us the following similar function which DOES NOT
## use regexs
##
## Usually avoiding regexs leads to more performant code (unless the
## replacement for the regex is particularly complex - which in this
## case it isn't!)
sub next_bin_rrev {
my $t = rindex my $s = sprintf('0%b',shift),'01';
return oct '0b'.substr($s,0,$t).'10'.reverse substr $s,$t+2;
}
## We can get further optimization by avoiding the call to "oct" by
## converting the above to simple arithmetic...
## To move all the 1s to the end and flip the '01' to '10'
## We note that if the number is of the form..
##
## 0 1111 00000000
##
## The next highest number (with the same number of bits is:
##
## 1 000000000 111
##
## To get this we first do:
##
## 0 1111 00000000
## + 0 0001 00000000
## ---------------
## 1 0000 00000000
##
## and then:
##
## 1 0000 00000000
## + 0 0000 00000111
## ---------------
## 1 0000 00000111
##
## which is the answer we are looking for....
##
## This is basically:
##
## $N + 2^(#0s) +2^(#1s-1) - 1;
##
## We can get these with rindex
##
## #0s = length of the binary string - (last index of 1 + 1)
## #1s = last index of 1 - last index of 0 (before this 1)
##
## This all leads into the following fn.
##
## Note we don't use 2**$N but 1<<$N which is much more efficient
## Investigated unpack vs sprintf to do the dec->binary conversion
## the latter is faster by about 20%...
sub next_bin_rindex2ns {
my $t = rindex my $s = sprintf('%b',$_[0]),'1';
return $_[0] - 1 + (1<<(-1-$t+length$s)) + (1<<(-1+$t-rindex $s,'0',$t));
}
sub next_bin_rindex2 {
my $t = rindex my $s = sprintf('%b',$_[0]), '1';
return $_[0] + (1<<(-$t-1+length$s)) - 1 + (1<<($t-1-rindex$s,'0',$t));
}