diff options
| -rw-r--r-- | challenge-114/james-smith/README.md | 374 | ||||
| -rw-r--r-- | challenge-114/james-smith/blog.txt | 1 | ||||
| -rw-r--r-- | challenge-114/james-smith/perl/ch-1.pl | 69 | ||||
| -rw-r--r-- | challenge-114/james-smith/perl/ch-2.pl | 70 |
4 files changed, 261 insertions, 253 deletions
diff --git a/challenge-114/james-smith/README.md b/challenge-114/james-smith/README.md index 3d284e315c..9bf832ce51 100644 --- a/challenge-114/james-smith/README.md +++ b/challenge-114/james-smith/README.md @@ -1,4 +1,6 @@ -# Perl Weekly Challenge #113 +# Perl Weekly Challenge #114 + +# What no regexs or loops.... You can find more information about this weeks, and previous weeks challenges at: @@ -10,311 +12,177 @@ submit solutions in whichever language you feel comfortable with. You can find the solutions here on github at: -https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-113/james-smith/perl - -# Challenge 1 - Represent Integer - -**You are given a positive integer `$N` and a digit `$D`. Write a script to -check if $N can be represented as a sum of positive integers having `$D` at -least once. If check passes print `1` otherwise `0`.** - -**Assumption** although not clear in the question, we make the -assumption that the numbers in the sum are all unique. +https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-114/james-smith/perl -## Solution... +# Challenge 1 - Next highest palindrome -There are two classes of solution to this problem: +***You are given a positive integer `$N`. Write a script to find out +the next Palindrome Number higher than the given integer `$N`.*** - 1. Solutions where `$D` only appears in the right hand column. - 1. Solutions where `$D` appears in more than one column. +## The solution - naive -### Type 2 solutions... -If `$D` is 0. Then we can find solutions for all numbers `>=100`. For -the numbers `100` -> `109` the number itself surfices. For numbers -`>=110` we can always find a solution of the form (or similar): +We will see this again for the next challenge we just increment `$N` +until we find another palindrome. -``` - x x x x 0 x -+ x 0 +```perl +sub next_palindrome_naive { + my ($n) = @_; + 1 until ++$n eq reverse $n; + return $n +} ``` -If `$D` in not 0. Then we can find similar solutions for all numbers -`>= 10*$D`. Again for `10*$D` -> `10*$D + 9` the number itself surfices. -For numbers `>=11*$D` we have similar solutions to above where we can -write the nubmer as: +## The solution - optimized -``` - x x x x D x -+ x D -``` - -So we check for that first, then we can look at the type (1) solutions +First we note that it is easier to compute the palindrome greater than +equal to itself {so we just incremement the passed parameter}. -### Type 1 solutions... +We should then be able to do away with the loop entirely as the +palindromic number will either have the same first half as itself OR +will have this value incrememented by 1 as the first half.... No loop +requried.. -We need a sequence of numbers `$D`, `10+$D`, `20+$D`, `30+$D` *etc* -that is less than or equal to `$N` and has the same last digit as `$N`. -Now we note `$D + 10+$D + 20+$D + 30+$D + 40+$D` is `100 + 5$D` and so -we know this is possible to represent for all values of `$D` so we -can ignore this case. +### The cases.. -## Perl code +There are two cases we need to consider: -The first pass at this uses a for loop to generate the values of the -numbers in the sum. After first checking the criteria for type 2 -solutions... + * There are an even number of digits + * There are an odd number of digits.. -```perl -sub represent { - my( $t, $n, $d ) = ( 0, @_ ); - ## Type 2 solutions... - return 1 if $n >= 10 *A ( $d || 10 ); - ## Type 1 solutions... - $n >= ( $t += $_ * 10 + $d ) && - ( $n % 10 == $t % 10 ) && return 1 for 0..3; - 0; -} -``` +The first case is slightly easiers as we just check to see if the +palindrome created by reversing the first digits and putting them +at the end is greater than or equal to the number, and if not +increment and try again. -We can further improve performance by removing the need for the `$t` -variable and the `for` loop by "unrolling" the loop as below... +The second case is slightly more interesting as we have the middle +digit to consider. In the 2nd half above we can increment the middle +digit if (less than 9) OR incremennt the first digits.. ```perl -sub represent_unrolled { - my( $n, $d ) = @_; - ## Type 2 solutions... - $n >= 10 * ( $d || 10 ) || - ## Type 1 solutions... - $n >= $d && $n%10 == $d || - $n >= 2*$d+10 && !( ($n-2*$d)%10 ) || - $n >= 3*$d+30 && !( ($n-3*$d)%10 ) || - $n >= 4*$d+60 && !( ($n-4*$d)%10 ) ? 1 : 0; +sub next_palindrome { + my $p = 1 + shift; + my $x = substr $p, 0, (length $p)>>1; + if( 1 & length $p ) { + my $y = substr $p, (length$p)>>1, 1; + return $x.$y.reverse $x if $p <= $x.$y.reverse $x; + return $x.($y+1).reverse $x if $y<9; + $x++; + return $x.'0'.reverse $x; + } else { + $x++ if $p > $x.reverse $x; + return $x.reverse $x; + } } ``` -This appears to be 50% faster than the loop solution... +## Notes and Summary -# Challenge 2 - Recreate Binary Tree +You will note I've used the "Yoda" form of some of the expressions +inequalities. It is much easier for instance to realise that: +`1 & length $p` is "and"ing `1` with the length of `$p` rather than +"and"ing `1` with `$p` and then taking the length (which will be 1) if +you were to write `length $p & 1`... -**You are given a Binary Tree. Write a script to replace each -node of the tree with the sum of all the remaining nodes.** +There were some cases where I thought assigning the result of +`reverse$x` and `length$p` would speed things up - but it seemed to +slow things down by 10% or so - So I'm assuming there is some neat +code in the interpreter/compiler does this cacheing for you. -We already have an embryonic `Tree` object from the Linked list/tree -challenge in week 94. +For small numbers of `$N` there is little difference in the performance +15% - but as soon as numbers are up to 3/4 digits then the optimised +version is 6 times faster, for 5/6 digits 80 times faster, for 7/8 +approximately 1000 times faster... -So we will extend this (and to write a true `BinaryTree`) representation. +# Challenge 2 - Higher Integer Set Bits -## Walk the tree +***You are given a positive integer `$N`. Write a script to find +the next higher integer having the same number of 1 bits in binary +representation as `$N`.*** -For each of the problems cloning, summing, updating a tree we need to -walk the tree. The solution I propose here will define a "walking" -function on the tree, which has it's parameters: - * a function to handle each node - * a "global" storage object - * a "local" storage object - * whether the node is a left child / right child. +## The solution - naive -## Perl `BinaryTree` object. - -Our binary tree is represented by an array of length 3. The value of -the node {which can be any object} and the left and right children. - -We then have two methods - `add_left_child` and `add_right_child` to -add them to the tree. - -We also have accessors: - - * `left` - left child - * `right` - right child - * `value` - value of node - -We have to functions to check for existance of a child: - - * `has_left` - left child - * `has_right` - right child - -and finally a method to update a node `update` +There is a simple solution we can try - and that is to take the number, +count the number of 1-bits, and then just increment repeatedly until we +get a number with the same amount of 1-bits. ```perl -package BinaryTree; - -sub new { - my $class = shift; - my $value = shift; - my $self = [ $value, undef, undef ]; - bless $self, $class; -} - -sub update { - my( $self, $val ) = @_; - $self->[0] = $val; - return $self; -} - -sub value { - my $self = shift; - return $self->[0]; +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/ ); + } } +``` -sub add_child_left { - my( $self,$child ) = @_; - $self->[1] = $child; - return $self; -} + * We convert the number to binary using sprintf with the format `'%b'`; + * We count the number of "1"s in the string using `tr`. `tr/1/1/` leaves the string unchanged but returns the number of "1"s that were replaced. -sub add_child_right { - my( $self,$child ) = @_; - $self->[2] = $child; - return $self; -} +## The solution - optimized -sub left { - my $self = shift; - return $self->[1]; -} +We can easily find a solution to this problem. -sub right { - my $self = shift; - return $self->[2]; -} +If the number contains a pair of digits "01" then we can find a number +that is larger but has the same number of digits by swapping the "01" to "10". +(Note we can force the binary representation to always have a "01" by prefixing +the binary representation with "0") -sub has_left { - my $self = shift; - return defined $self->[1]; -} +So e.g. `174 = 1010 1110` - you can replace either of the `01`s to give either: -sub has_right { - my $self = shift; - return defined $self->[2]; -} + * `1100 1110 = 206` + * `1011 0110 = 182` -``` - -## Walking the tree... +We note that to minimize the number we start by replacing the last `01` by `10` -Our tree walking function takes up to 4 parameters: +So we have: `182 = 1011 0110 > 174 = 1010 1100` - 1. `$fn` a callback function which does whatever is needed, - e.g. collect summary statistics, update the node etc; - 1. `$global` a reference to a variable which is used as - "global" storage for the walk - 1. `$local` a variable which is used as "local" storage for the walk, - it is updated as the value from `$fn` before being passed to the - children, - 1. `$dir` the direction of the walk whether it be "left" or "right" +The digits after the last `01` will be of the form `1...10..0`, so we can again +reduce the value by flipping this string around to be `0...01...1`; -`$self`, `$global`, `$local` and `$dir` are all passed to the callback -function.... +So now we have: `179 = 1011 0011 > 174 = 1010 110` -The code itself is quite simple to look at... +The code then becomes either: ```perl -sub walk { - my( $self, $fn, $global, $local, $dir ) = @_; - $local = $fn->( $self, $global, $local, $dir||'' ); - $self->left->walk( $fn, $global, $local, 'left' ) if $self->has_left; - $self->right->walk( $fn, $global, $local, 'right' ) if $self->has_right; - return; +sub next_bin_rex { + return oct '0b'.sprintf('0%b',shift) =~ s{01(1*)(0*)$}{10$2$1}r; } ``` - -## Cloning - with walk +or ```perl -sub clone { - my( $self, $clone_fn ) = @_; - $clone_fn ||= sub { $_[0] }; - my $clone = {}; - $self->walk( sub { my( $node, $global, $local, $dir ) = @_; - if(exists $global->{'tree'} ) { - my $child = BinaryTree->new( $clone_fn->( $node->value ) ); - $dir eq 'left' ? $local->add_child_left( $child ) : $local->add_child_right( $child ); - return $child; - } - $global->{'tree'} = BinaryTree->new( $clone_fn->( $node->value ) ); - return $global->{'tree'}; - }, $clone ); - return $clone->{'tree'}; +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 use this `walk` method to clone our tree. -Global is a hashref with one entry - 'tree' which will contain our -cloned tree. -The first time through the loop it initialises the tree and adds the -root node to the tree and returns itself. `$local` is then this node. +depending on whether or not you use a regular expression to find +the last "`01`" in the binary representaiton. -For subsequent calls the tree exists and so a new BinaryTree objects is -produced and attached to it's parent (which is held in `$local`) either -as a left or right child. +## Summary -`clone` can take an additional `callback` which is applied to each -node when being copied - which defaults to just a straight copy. +Both the performance of `next_bin_regex` and `next_bin_rrev` appear +to slow down only slightly as `$N` increases - comparabale with +"linear" scans for the last "`01`". Whereas the `next_bin` naive +method has no such property. -There are two more "walk methods" in the object, which dump the data: -either as a single line of values (flatten) or as "ASCII-art" to show -the nodes and their relationships. +Running this a large number of times - we have the following +approximate rates for the calculations.... -```perl -sub flatten { - my( $self,$dump_fn ) = @_; - $dump_fn ||= sub { $_[0] }; - my $arrayref = []; - $self->walk( sub { - my($node,$global) = @_; - push @{$global}, $dump_fn->( $node->value ); - }, $arrayref ); - return @{$arrayref}; -} +| Size of number | Rate rrev | Rate regex | Rate naive | +| -------------- | ---------: | ---------: | ---------: | +| 1-500 | 1,600,000 | 500,000 | 600,000 | +| Approx 1000 | 1,550,000 | 440,000 | 400,000 | +| Approx 1x10^6 | 1,500,000 | 390,000 | 4,000 | +| Approx 1x10^9 | 1,450,000 | 330,000 | 1 | -sub dump { - my( $self, $dump_fn ) = @_; - $dump_fn ||= sub { $_[0] }; - $self->walk( sub { - my( $node, $global, $local, $dir ) = @_; - say join '', - $local||'', - $dir eq 'left' ? '<' : $dir eq 'right' ? '>' : ' ', - ' ', $dump_fn->($node->value); - return $local .= ' '; - }, {}, '', '' ); - return; -} -``` - -Like clone they take a simple call back if you want to include a -function of the object's values rather than the value itself.... -*a callback* within *a callback*.... You could even say its -***Turtles all the way down***... - -## The solution - -### Walking the tree to get the sum - -We create a "*global*` variable which contains the total, walk through -all nodes and add the node value to this total.... We can then -retrieve the value by inspecting `$glob`.. - -```perl -my $glob = { 'total' => 0 }; -$y->walk( sub { - my( $node, $global ) = @_; - $global->{'total'} += $node->value; -}, $glob ); -``` - -### Walking the tree to update the nodes... +The calls do include the hardest example `2^n-1` for which the next +number is `2^(n-1)` more - so much of the time in the naive loop is +taken up by that example - in the 1x10^9 example this would require +500_000_000 iterations of the increment/check loop. -We pass the variable $glob back in, and use the total there -to update the value. For the value to be the sum of all the -other nodes, we can get this by adding all the nodes together -than subtracting away the node value.... - -So the 2nd half becomes. -```perl -$y->walk( sub { - my( $node, $global ) = @_; - $node->update( $global->{'total'} - $node->value ); -}, $glob ); -``` +We see as we did a few weeks ago that if you don't actually need to +use regexs then you can get an appreciable speed boost. Obviously +remembering there is trade off between coding and running time. diff --git a/challenge-114/james-smith/blog.txt b/challenge-114/james-smith/blog.txt new file mode 100644 index 0000000000..83cc017bd8 --- /dev/null +++ b/challenge-114/james-smith/blog.txt @@ -0,0 +1 @@ +https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-114/james-smith diff --git a/challenge-114/james-smith/perl/ch-1.pl b/challenge-114/james-smith/perl/ch-1.pl new file mode 100644 index 0000000000..8303864dbd --- /dev/null +++ b/challenge-114/james-smith/perl/ch-1.pl @@ -0,0 +1,69 @@ +#!/usr/local/bin/perl + +use strict; + +use warnings; +use feature qw(say); +use Test::More; + +my @tests = ([1,2],[9,11],[99,101],[989,999],[999,1001],[10,11],[11,22],[12,22], + [1990,1991],[1992,2002],[99011,99099],[97979,98089],[99099,99199],[99999,100001], + [111222,112211]); +#@tests = map { chomp; [split] } <>; + +is( next_palindrome( $_->[0] ), $_->[1] ) foreach @tests; +is( next_palindrome_naive( $_->[0] ), $_->[1] ) foreach @tests; + +done_testing(); + +use Benchmark qw{ cmpthese }; +my @ranges = ( + [ 100_000, 1, 101 ], + [ 50_000, 950, 1050 ], + [ 20_000, 9950, 10050 ], + [ 10_000, 99950, 100050 ], + [ 5_000, 999950, 1000050 ], + [ 1_000, 9999950, 10000050 ], + [ 1_000, 99999950, 100000050 ], +); + +foreach my $r (@ranges) { + cmpthese($r->[0], { + slow => sub { next_palindrome_naive($_) for $r->[1] .. $r->[2] }, + fast => sub { next_palindrome($_) for $r->[1] .. $r->[2] }, + }); +} + +sub next_palindrome_naive { + my ($n) = @_; + 1 until ++$n eq reverse $n; + return $n +} + +sub next_palindrome { + my $p = 1 + shift; + my $x = substr $p, 0, (length $p)>>1; + if( 1 & length $p ) { + ## Odd length so we have three options... + ## new number by reversing the first half of the number > $n so OK! + ## middle digit is < 9 so just increment that + ## o/w we will need to increment the first half and reverse it... + ## if $x is 999 then the only time we could do the ++ to get + ## a longer string is when $p is of the form 999.9.999, but + ## then 999.9.999 > 999.9.998 and so we don't get this... so we + ## are safe with this approach... + my $y = substr $p, (length$p)>>1, 1; + return $x.$y.reverse $x if $p <= $x.$y.reverse $x; + return $x.($y+1).reverse $x if $y<9; + return ++$x.'0'.reverse $x; + } + ## Even no of digits.. + ## If $n >= $x.reverse $x we incrememnt $x; + ## The only time that this could lead to a longer number is when + ## $x is 999 and is OK as $x.reverse $x will always be larger than + ## $n.... + return $x.reverse $x if $p <= $x.reverse $x; + return ++$x.reverse $x; +} + + diff --git a/challenge-114/james-smith/perl/ch-2.pl b/challenge-114/james-smith/perl/ch-2.pl new file mode 100644 index 0000000000..773f79b0cb --- /dev/null +++ b/challenge-114/james-smith/perl/ch-2.pl @@ -0,0 +1,70 @@ +#!/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_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 = ( + [ 1000, 1, 500 ], + [ 500, 500, 2500 ], + [ 100, 1_047_576, 1_049_576 ], + [ 50, 1_073_740_824, 1_073_742_824 ], +); + +foreach my $r (@ranges) { + cmpthese( 10*$r->[0], { + 'rind' => sub { next_bin_rrev( $_ ) foreach $r->[1] .. $r->[2] }, + 'rex' => sub { next_bin_rex( $_ ) foreach $r->[1] .. $r->[2] }, +# 'simp' => sub { next_bin( $_ ) foreach $r->[1] .. $r->[2] }, + }); +} +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; +} + |