From b7ee3deaa2a05acca98eba97c01a762c58b82eae Mon Sep 17 00:00:00 2001 From: drbaggy Date: Sun, 6 Jun 2021 10:19:09 +0100 Subject: added non-recursive solution --- challenge-115/james-smith/perl/ch-2.pl | 75 +++++++++++++++++++++++++++++++--- 1 file changed, 70 insertions(+), 5 deletions(-) diff --git a/challenge-115/james-smith/perl/ch-2.pl b/challenge-115/james-smith/perl/ch-2.pl index 696a5f6501..b7ea0e4418 100644 --- a/challenge-115/james-smith/perl/ch-2.pl +++ b/challenge-115/james-smith/perl/ch-2.pl @@ -5,6 +5,7 @@ use strict; use warnings; use feature qw(say); use Test::More; +use Benchmark qw(cmpthese); my @examples = ( [ [qw(abc dea cd)], 1, 1 ], @@ -13,15 +14,74 @@ my @examples = ( [ [qw(ab bc ca ae)], 0, 1 ], [ [qw(bad bed bid bod bud dub dob dib deb dab)], 1, 1 ], [ [qw(abc def fed)], 0, 1 ], + [ [qw(ana)], 1, 1 ], + [ [qw(ana bob)], 0, 1 ], + [ [qw(ana one ant glo ten era nag )], 1, 1 ], + [ [qw(ana bad bed dab deb)], 0, 1 ], + [ [qw(bad bed ana dab deb)], 0, 1 ], + [ [qw(abc cde efg ghi ijk kla cpq qpc eft the ilm mli)], 1, 1 ], + [ [qw(pk fz iy oz cf xm gm uy ur te ct zz rw jm aq oq xy mi me rv jc iv sx pq lz nd cm vj uf rq ij zk ef wm bb cj vv oo og ft fq mj os uh gn ml mz fm az yr zh wa bm gj xn df yf er xc xb bl uw ri nq nn oi pc ym jr da rz bq vm sr ni jz po oj wf iu ja tu lk yt nc sl wi zb hm uv th kn hk pv yq ez we im gt za sj nh qr bt rr ok ai xx qs lg ue fc ws vc vy ki xi wy fv lt rl xw nj gu dz ip zl je pf hn uk di mv ug vf uz wt yn qx rh sz fh pm sa qz gp gw jp ve le fe ia nw pu km uo gy li pe hj mn ew hg qg se mq by vh ca hd bn nl xu dd ji bd ol vp wp yo st ac bh bx fa md zx mm ox qi mc lc jx wz jd xt vr yj pn uj zy ih ul pb id xh wb qq xg ou sp bo yz bu ec vz fy io hl jo cl zs ge tz qp mf zf kq sk qw as vs rm jw yk tr cw tk xz kt ra qo tj fu dy hx ic ej nt jt gf ko rd od ep qn sg ek ui bg iw zm at dv fx kb xr nu xl xs lr xk na ne xe rt jf ga hv kf xq sq pt cp rj fr fp qf gg ii ey tn ce ya kl wc ks qh em gc ts dn wk is fo pa sd ly uc zn dk wq bw tq kg xf vn ea hh ik lm nr wd kc mu ru co kx nb gl fs bi hu fk ld qa qy qm wl cn cr zd ke jl gz wr xp tm tl kj no ex wj su dc sh ee hf dw ax ms hq jj sb ed qj vw ha ju wx yi sf ln jy rx ei sy ar dm hr al ah mb on ob uq ps lv ad jk rb fb gk cc rp jq ka my ix nv re vk tp zw rg tb up pp uu ds ho zv nf ty cu kp eg in lu hy mk um zt hc qt yp tv rk hb pj ph bk af to lq qe ib gi bz jh iz lo yv ci jg gh yx bj il cz gx ro ff kk vd ub et bs tw si qd ql au ti xj yh yl kr om nx lw wo gs gq ku mw py tx ll fl xd ch rc go dt lx zu ry hz bc lj la lh ux sc fn it ir tt mo pr gd sm mx jn cd vl vb mt pz vt he eh ss dh dj yw xv be ov wh ww pg ao es ye xa vq hs yc yd vu ns zr lf rs pl cs eo zi qb qk so oc wn el zc yb de mg fw cx cv wv ot cb qu wu nm ow zp rn hw lp ma en vg cy rf tc am ut cq sv kv oh jb np us ck mh ny gr gb op an kw aa vo zq iq ba px dr un or ze bp zg eb ud if dl dq zj ky bf vi cg ua br yu mp bv sn pi db ae of kh pd hp qc jv xo du fg ta do kd dx av ys tg ls fi kz tf eu aj sw vx oa pw fd ab hi va lb dg ig dp nz js qv ag aw eq mr zo yy ie nk yg ap oe gv oy ht ev ak td ay fj ng wg)], 1, 1 ], ); -foreach (@examples) { - is(circ_single(@{$_->[0]}),$_->[1]); - is(circ_any( @{$_->[0]}),$_->[2]); -} +warn "SNR"; +is(circ_single_non_recursive(@{$_->[0]}),$_->[1]) foreach @examples; +warn "S"; +is(circ_single(@{$_->[0]}),$_->[1]) foreach @examples; +warn "A"; +is(circ_any( @{$_->[0]}),$_->[2]) foreach @examples; + done_testing(); +cmpthese( 400, { + 1 => sub { circ_single(@{$_->[0]}) foreach @examples; }, + 2 => sub { circ_single_non_recursive(@{$_->[0]}) foreach @examples; }, + 0 => sub { circ_any(@{$_->[0]}) foreach @examples; }, +} ); + +sub circ_single_non_recursive { + my @words = @_; + my %F; + ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; + return 0 if grep {$_} values %F; ## This quickly filters out those cases in which we + ## can't join end on end... now there is a harder + ## problem coming up which is to work out if there + ## is a multi-loop option + ## Now we start at any point and get the first circle.... + my %seen; + while(@words) { + my $init = shift @words; + $seen{ord $init}=1; + my $ptr = 0; + ## Skip this bit if the word is "self-closing" ie starts/ends + ## with same letter... + if( substr($init,0,1) ne substr $init, -1 ) { + while($ptr++ < @words) { + if( (substr $init,-1) eq substr $words[0],0,1 ) { + $seen{ ord $words[0] } = 1; + $init =shift @words; + $ptr = 0; + return 1 unless @words; + } + push @words, shift @words; + } + } + return 1 unless @words; ## We have no words left - success... + $ptr=0; + $init=undef; + while( $ptr++ < @words) { + if($seen{ord $words[0]}) { + $init=1; + last; + } + push @words,shift@words; + } + return 0 unless $init; + } + return 1; +} + sub circ_single { +no warnings 'recursion'; ## Disable deep recursion warning - this gets messy... my @words = @_; my %F; ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; @@ -31,8 +91,11 @@ sub circ_single { ## is a multi-loop option ## e.g. "ab","bc","ca","de","ef","fd" - which ## can't make a single loop... + ## Special case where we have 1 word and it starts/ends with the same letter! + return 1 if @words ==1; + ## nested sub-function which does the exhaustive/recurisve search for a single - ## "circle"... + ## "circle"... look through all routes.... sub exhaust { my ($init,@words) = @_; my $n = @words; @@ -55,6 +118,7 @@ sub circ_single { } return exhaust( @words ); + use warnings 'recursion'; } sub circ_any { @@ -67,6 +131,7 @@ sub circ_any { ## returning 1 if we eventually reach the criteria above... foreach(1..$n) { my $init = shift @words; + return 1 if (substr $init,-1) eq substr $init,0,1; foreach(2..$n) { push @words,shift@words; next unless (substr $init,-1) eq substr $words[0],0,1; -- cgit From 224c27877bbd99f1fba6fb38d6a4317f669ce106 Mon Sep 17 00:00:00 2001 From: drbaggy Date: Sun, 6 Jun 2021 10:19:37 +0100 Subject: tidied up code and pass by ref --- challenge-115/james-smith/perl/ch-1.pl | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/challenge-115/james-smith/perl/ch-1.pl b/challenge-115/james-smith/perl/ch-1.pl index 94269e06c7..ba5bed2831 100644 --- a/challenge-115/james-smith/perl/ch-1.pl +++ b/challenge-115/james-smith/perl/ch-1.pl @@ -6,21 +6,31 @@ use warnings; use feature qw(say); use Test::More; -is( biggest_even(4,1,7,6), 7614 ); -is( biggest_even(1,4,2,8), 8412 ); -is( biggest_even(1,0,2,6), 6210 ); -is( biggest_even(1,7,9,6), 9716 ); -is( biggest_even(1,7,3,5), '' ); +my @TESTS = ( + [[qw(4 1 7 6)], 7614], + [[qw(1 4 2 8)], 8412], + [[qw(1 0 2 6)], 6210], + [[qw(1 7 9 6)], 9716], + [[qw(1 7 3 5)], ''], + [[qw(1 7 3 8)], 7318], + [[qw(2 4 6 8)], 8642], +); -done_testing(); +is( biggest_even( $_->[0] ), $_->[1] ) foreach @TESTS; sub biggest_even { - my $ptr = my @digits = reverse sort @_; + my $ptr = my @digits = reverse sort @{$_[0]}; + ## Firstly grab the digits in reverse numerical order ## Keep looping backwards through the array until we ## find a digit which is even - if this is the case ## we move it to the back and return the list. - $digits[$ptr]&1 || return join'',@digits[0..$ptr-1,$ptr+1..$#digits,$ptr] while $ptr--; + + while( $ptr-- ) { + next if $digits[$ptr] & 1; ## Skip if odd... + return join '', + @digits[ 0..$ptr-1, $ptr+1..$#digits, $ptr ]; + } ## If we get to the start return 0 as there are no even digits! return ''; -- cgit From 4e92833d1ffb4970bd4d62e134d7b3877177ce4b Mon Sep 17 00:00:00 2001 From: drbaggy Date: Sun, 6 Jun 2021 10:22:58 +0100 Subject: fix order --- challenge-115/james-smith/perl/ch-1.pl | 149 ++++++++++++++++++++++++++++----- challenge-115/james-smith/perl/ch-2.pl | 149 +++++---------------------------- 2 files changed, 149 insertions(+), 149 deletions(-) diff --git a/challenge-115/james-smith/perl/ch-1.pl b/challenge-115/james-smith/perl/ch-1.pl index ba5bed2831..b7ea0e4418 100644 --- a/challenge-115/james-smith/perl/ch-1.pl +++ b/challenge-115/james-smith/perl/ch-1.pl @@ -5,34 +5,141 @@ use strict; use warnings; use feature qw(say); use Test::More; +use Benchmark qw(cmpthese); -my @TESTS = ( - [[qw(4 1 7 6)], 7614], - [[qw(1 4 2 8)], 8412], - [[qw(1 0 2 6)], 6210], - [[qw(1 7 9 6)], 9716], - [[qw(1 7 3 5)], ''], - [[qw(1 7 3 8)], 7318], - [[qw(2 4 6 8)], 8642], +my @examples = ( + [ [qw(abc dea cd)], 1, 1 ], + [ [qw(ade cbd fgh)], 0, 0 ], + [ [qw(ab bc ca de ef fd)], 0, 1 ], + [ [qw(ab bc ca ae)], 0, 1 ], + [ [qw(bad bed bid bod bud dub dob dib deb dab)], 1, 1 ], + [ [qw(abc def fed)], 0, 1 ], + [ [qw(ana)], 1, 1 ], + [ [qw(ana bob)], 0, 1 ], + [ [qw(ana one ant glo ten era nag )], 1, 1 ], + [ [qw(ana bad bed dab deb)], 0, 1 ], + [ [qw(bad bed ana dab deb)], 0, 1 ], + [ [qw(abc cde efg ghi ijk kla cpq qpc eft the ilm mli)], 1, 1 ], + [ [qw(pk fz iy oz cf xm gm uy ur te ct zz rw jm aq oq xy mi me rv jc iv sx pq lz nd cm vj uf rq ij zk ef wm bb cj vv oo og ft fq mj os uh gn ml mz fm az yr zh wa bm gj xn df yf er xc xb bl uw ri nq nn oi pc ym jr da rz bq vm sr ni jz po oj wf iu ja tu lk yt nc sl wi zb hm uv th kn hk pv yq ez we im gt za sj nh qr bt rr ok ai xx qs lg ue fc ws vc vy ki xi wy fv lt rl xw nj gu dz ip zl je pf hn uk di mv ug vf uz wt yn qx rh sz fh pm sa qz gp gw jp ve le fe ia nw pu km uo gy li pe hj mn ew hg qg se mq by vh ca hd bn nl xu dd ji bd ol vp wp yo st ac bh bx fa md zx mm ox qi mc lc jx wz jd xt vr yj pn uj zy ih ul pb id xh wb qq xg ou sp bo yz bu ec vz fy io hl jo cl zs ge tz qp mf zf kq sk qw as vs rm jw yk tr cw tk xz kt ra qo tj fu dy hx ic ej nt jt gf ko rd od ep qn sg ek ui bg iw zm at dv fx kb xr nu xl xs lr xk na ne xe rt jf ga hv kf xq sq pt cp rj fr fp qf gg ii ey tn ce ya kl wc ks qh em gc ts dn wk is fo pa sd ly uc zn dk wq bw tq kg xf vn ea hh ik lm nr wd kc mu ru co kx nb gl fs bi hu fk ld qa qy qm wl cn cr zd ke jl gz wr xp tm tl kj no ex wj su dc sh ee hf dw ax ms hq jj sb ed qj vw ha ju wx yi sf ln jy rx ei sy ar dm hr al ah mb on ob uq ps lv ad jk rb fb gk cc rp jq ka my ix nv re vk tp zw rg tb up pp uu ds ho zv nf ty cu kp eg in lu hy mk um zt hc qt yp tv rk hb pj ph bk af to lq qe ib gi bz jh iz lo yv ci jg gh yx bj il cz gx ro ff kk vd ub et bs tw si qd ql au ti xj yh yl kr om nx lw wo gs gq ku mw py tx ll fl xd ch rc go dt lx zu ry hz bc lj la lh ux sc fn it ir tt mo pr gd sm mx jn cd vl vb mt pz vt he eh ss dh dj yw xv be ov wh ww pg ao es ye xa vq hs yc yd vu ns zr lf rs pl cs eo zi qb qk so oc wn el zc yb de mg fw cx cv wv ot cb qu wu nm ow zp rn hw lp ma en vg cy rf tc am ut cq sv kv oh jb np us ck mh ny gr gb op an kw aa vo zq iq ba px dr un or ze bp zg eb ud if dl dq zj ky bf vi cg ua br yu mp bv sn pi db ae of kh pd hp qc jv xo du fg ta do kd dx av ys tg ls fi kz tf eu aj sw vx oa pw fd ab hi va lb dg ig dp nz js qv ag aw eq mr zo yy ie nk yg ap oe gv oy ht ev ak td ay fj ng wg)], 1, 1 ], ); -is( biggest_even( $_->[0] ), $_->[1] ) foreach @TESTS; +warn "SNR"; +is(circ_single_non_recursive(@{$_->[0]}),$_->[1]) foreach @examples; +warn "S"; +is(circ_single(@{$_->[0]}),$_->[1]) foreach @examples; +warn "A"; +is(circ_any( @{$_->[0]}),$_->[2]) foreach @examples; -sub biggest_even { - my $ptr = my @digits = reverse sort @{$_[0]}; +done_testing(); - ## Firstly grab the digits in reverse numerical order - ## Keep looping backwards through the array until we - ## find a digit which is even - if this is the case - ## we move it to the back and return the list. +cmpthese( 400, { + 1 => sub { circ_single(@{$_->[0]}) foreach @examples; }, + 2 => sub { circ_single_non_recursive(@{$_->[0]}) foreach @examples; }, + 0 => sub { circ_any(@{$_->[0]}) foreach @examples; }, +} ); - while( $ptr-- ) { - next if $digits[$ptr] & 1; ## Skip if odd... - return join '', - @digits[ 0..$ptr-1, $ptr+1..$#digits, $ptr ]; +sub circ_single_non_recursive { + my @words = @_; + my %F; + ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; + return 0 if grep {$_} values %F; ## This quickly filters out those cases in which we + ## can't join end on end... now there is a harder + ## problem coming up which is to work out if there + ## is a multi-loop option + ## Now we start at any point and get the first circle.... + my %seen; + while(@words) { + my $init = shift @words; + $seen{ord $init}=1; + my $ptr = 0; + ## Skip this bit if the word is "self-closing" ie starts/ends + ## with same letter... + if( substr($init,0,1) ne substr $init, -1 ) { + while($ptr++ < @words) { + if( (substr $init,-1) eq substr $words[0],0,1 ) { + $seen{ ord $words[0] } = 1; + $init =shift @words; + $ptr = 0; + return 1 unless @words; + } + push @words, shift @words; + } + } + return 1 unless @words; ## We have no words left - success... + $ptr=0; + $init=undef; + while( $ptr++ < @words) { + if($seen{ord $words[0]}) { + $init=1; + last; + } + push @words,shift@words; + } + return 0 unless $init; + } + return 1; +} + +sub circ_single { +no warnings 'recursion'; ## Disable deep recursion warning - this gets messy... + my @words = @_; + my %F; + ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; + return 0 if grep {$_} values %F; ## This quickly filters out those cases in which we + ## can't join end on end... now there is a harder + ## problem coming up which is to work out if there + ## is a multi-loop option + ## e.g. "ab","bc","ca","de","ef","fd" - which + ## can't make a single loop... + ## Special case where we have 1 word and it starts/ends with the same letter! + return 1 if @words ==1; + + ## nested sub-function which does the exhaustive/recurisve search for a single + ## "circle"... look through all routes.... + sub exhaust { + my ($init,@words) = @_; + my $n = @words; + ## If we have just two "words" then check that they form a loop. + if( $n==1) { + return substr($init,-1) eq substr($words[0],0,1) + && substr($init,0,1) eq substr($words[0],-1) ? 1 : 0; + } + ## o/w we loop through the list of words... + ## if the start of one word matches the end of the "first word" + ## then we "extend" the first word, and repeat recursively, + ## returning 1 if we eventually reach the criteria above... + foreach(1..$n) { + push @words,shift @words; + next unless (substr $init,-1) eq substr $words[0],0,1; + return 1 if exhaust( $init.$words[0], @words[1..($n-1)] ); + } + ## In none match criteria we return 0... + return 0; } - ## If we get to the start return 0 as there are no even digits! - return ''; + return exhaust( @words ); + use warnings 'recursion'; } +sub circ_any { + my (@words) = @_; + my $n = @words; + ## If we have just two "words" then check that they form a loop. + ## o/w we loop through the list of words... + ## if the start of one word matches the end of the "first word" + ## then we "extend" the first word, and repeat recursively, + ## returning 1 if we eventually reach the criteria above... + foreach(1..$n) { + my $init = shift @words; + return 1 if (substr $init,-1) eq substr $init,0,1; + foreach(2..$n) { + push @words,shift@words; + next unless (substr $init,-1) eq substr $words[0],0,1; + return 1 if substr($init,0,1) eq substr($words[0],-1); + return 1 if circ_any( $init.$words[0], @words[1..($n-2)] ); + } + push @words,$init; + } + ## In none match criteria we return 0... + return 0; +} diff --git a/challenge-115/james-smith/perl/ch-2.pl b/challenge-115/james-smith/perl/ch-2.pl index b7ea0e4418..ba5bed2831 100644 --- a/challenge-115/james-smith/perl/ch-2.pl +++ b/challenge-115/james-smith/perl/ch-2.pl @@ -5,141 +5,34 @@ use strict; use warnings; use feature qw(say); use Test::More; -use Benchmark qw(cmpthese); -my @examples = ( - [ [qw(abc dea cd)], 1, 1 ], - [ [qw(ade cbd fgh)], 0, 0 ], - [ [qw(ab bc ca de ef fd)], 0, 1 ], - [ [qw(ab bc ca ae)], 0, 1 ], - [ [qw(bad bed bid bod bud dub dob dib deb dab)], 1, 1 ], - [ [qw(abc def fed)], 0, 1 ], - [ [qw(ana)], 1, 1 ], - [ [qw(ana bob)], 0, 1 ], - [ [qw(ana one ant glo ten era nag )], 1, 1 ], - [ [qw(ana bad bed dab deb)], 0, 1 ], - [ [qw(bad bed ana dab deb)], 0, 1 ], - [ [qw(abc cde efg ghi ijk kla cpq qpc eft the ilm mli)], 1, 1 ], - [ [qw(pk fz iy oz cf xm gm uy ur te ct zz rw jm aq oq xy mi me rv jc iv sx pq lz nd cm vj uf rq ij zk ef wm bb cj vv oo og ft fq mj os uh gn ml mz fm az yr zh wa bm gj xn df yf er xc xb bl uw ri nq nn oi pc ym jr da rz bq vm sr ni jz po oj wf iu ja tu lk yt nc sl wi zb hm uv th kn hk pv yq ez we im gt za sj nh qr bt rr ok ai xx qs lg ue fc ws vc vy ki xi wy fv lt rl xw nj gu dz ip zl je pf hn uk di mv ug vf uz wt yn qx rh sz fh pm sa qz gp gw jp ve le fe ia nw pu km uo gy li pe hj mn ew hg qg se mq by vh ca hd bn nl xu dd ji bd ol vp wp yo st ac bh bx fa md zx mm ox qi mc lc jx wz jd xt vr yj pn uj zy ih ul pb id xh wb qq xg ou sp bo yz bu ec vz fy io hl jo cl zs ge tz qp mf zf kq sk qw as vs rm jw yk tr cw tk xz kt ra qo tj fu dy hx ic ej nt jt gf ko rd od ep qn sg ek ui bg iw zm at dv fx kb xr nu xl xs lr xk na ne xe rt jf ga hv kf xq sq pt cp rj fr fp qf gg ii ey tn ce ya kl wc ks qh em gc ts dn wk is fo pa sd ly uc zn dk wq bw tq kg xf vn ea hh ik lm nr wd kc mu ru co kx nb gl fs bi hu fk ld qa qy qm wl cn cr zd ke jl gz wr xp tm tl kj no ex wj su dc sh ee hf dw ax ms hq jj sb ed qj vw ha ju wx yi sf ln jy rx ei sy ar dm hr al ah mb on ob uq ps lv ad jk rb fb gk cc rp jq ka my ix nv re vk tp zw rg tb up pp uu ds ho zv nf ty cu kp eg in lu hy mk um zt hc qt yp tv rk hb pj ph bk af to lq qe ib gi bz jh iz lo yv ci jg gh yx bj il cz gx ro ff kk vd ub et bs tw si qd ql au ti xj yh yl kr om nx lw wo gs gq ku mw py tx ll fl xd ch rc go dt lx zu ry hz bc lj la lh ux sc fn it ir tt mo pr gd sm mx jn cd vl vb mt pz vt he eh ss dh dj yw xv be ov wh ww pg ao es ye xa vq hs yc yd vu ns zr lf rs pl cs eo zi qb qk so oc wn el zc yb de mg fw cx cv wv ot cb qu wu nm ow zp rn hw lp ma en vg cy rf tc am ut cq sv kv oh jb np us ck mh ny gr gb op an kw aa vo zq iq ba px dr un or ze bp zg eb ud if dl dq zj ky bf vi cg ua br yu mp bv sn pi db ae of kh pd hp qc jv xo du fg ta do kd dx av ys tg ls fi kz tf eu aj sw vx oa pw fd ab hi va lb dg ig dp nz js qv ag aw eq mr zo yy ie nk yg ap oe gv oy ht ev ak td ay fj ng wg)], 1, 1 ], +my @TESTS = ( + [[qw(4 1 7 6)], 7614], + [[qw(1 4 2 8)], 8412], + [[qw(1 0 2 6)], 6210], + [[qw(1 7 9 6)], 9716], + [[qw(1 7 3 5)], ''], + [[qw(1 7 3 8)], 7318], + [[qw(2 4 6 8)], 8642], ); -warn "SNR"; -is(circ_single_non_recursive(@{$_->[0]}),$_->[1]) foreach @examples; -warn "S"; -is(circ_single(@{$_->[0]}),$_->[1]) foreach @examples; -warn "A"; -is(circ_any( @{$_->[0]}),$_->[2]) foreach @examples; +is( biggest_even( $_->[0] ), $_->[1] ) foreach @TESTS; -done_testing(); +sub biggest_even { + my $ptr = my @digits = reverse sort @{$_[0]}; -cmpthese( 400, { - 1 => sub { circ_single(@{$_->[0]}) foreach @examples; }, - 2 => sub { circ_single_non_recursive(@{$_->[0]}) foreach @examples; }, - 0 => sub { circ_any(@{$_->[0]}) foreach @examples; }, -} ); + ## Firstly grab the digits in reverse numerical order + ## Keep looping backwards through the array until we + ## find a digit which is even - if this is the case + ## we move it to the back and return the list. -sub circ_single_non_recursive { - my @words = @_; - my %F; - ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; - return 0 if grep {$_} values %F; ## This quickly filters out those cases in which we - ## can't join end on end... now there is a harder - ## problem coming up which is to work out if there - ## is a multi-loop option - ## Now we start at any point and get the first circle.... - my %seen; - while(@words) { - my $init = shift @words; - $seen{ord $init}=1; - my $ptr = 0; - ## Skip this bit if the word is "self-closing" ie starts/ends - ## with same letter... - if( substr($init,0,1) ne substr $init, -1 ) { - while($ptr++ < @words) { - if( (substr $init,-1) eq substr $words[0],0,1 ) { - $seen{ ord $words[0] } = 1; - $init =shift @words; - $ptr = 0; - return 1 unless @words; - } - push @words, shift @words; - } - } - return 1 unless @words; ## We have no words left - success... - $ptr=0; - $init=undef; - while( $ptr++ < @words) { - if($seen{ord $words[0]}) { - $init=1; - last; - } - push @words,shift@words; - } - return 0 unless $init; - } - return 1; -} - -sub circ_single { -no warnings 'recursion'; ## Disable deep recursion warning - this gets messy... - my @words = @_; - my %F; - ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; - return 0 if grep {$_} values %F; ## This quickly filters out those cases in which we - ## can't join end on end... now there is a harder - ## problem coming up which is to work out if there - ## is a multi-loop option - ## e.g. "ab","bc","ca","de","ef","fd" - which - ## can't make a single loop... - ## Special case where we have 1 word and it starts/ends with the same letter! - return 1 if @words ==1; - - ## nested sub-function which does the exhaustive/recurisve search for a single - ## "circle"... look through all routes.... - sub exhaust { - my ($init,@words) = @_; - my $n = @words; - ## If we have just two "words" then check that they form a loop. - if( $n==1) { - return substr($init,-1) eq substr($words[0],0,1) - && substr($init,0,1) eq substr($words[0],-1) ? 1 : 0; - } - ## o/w we loop through the list of words... - ## if the start of one word matches the end of the "first word" - ## then we "extend" the first word, and repeat recursively, - ## returning 1 if we eventually reach the criteria above... - foreach(1..$n) { - push @words,shift @words; - next unless (substr $init,-1) eq substr $words[0],0,1; - return 1 if exhaust( $init.$words[0], @words[1..($n-1)] ); - } - ## In none match criteria we return 0... - return 0; + while( $ptr-- ) { + next if $digits[$ptr] & 1; ## Skip if odd... + return join '', + @digits[ 0..$ptr-1, $ptr+1..$#digits, $ptr ]; } - return exhaust( @words ); - use warnings 'recursion'; + ## If we get to the start return 0 as there are no even digits! + return ''; } -sub circ_any { - my (@words) = @_; - my $n = @words; - ## If we have just two "words" then check that they form a loop. - ## o/w we loop through the list of words... - ## if the start of one word matches the end of the "first word" - ## then we "extend" the first word, and repeat recursively, - ## returning 1 if we eventually reach the criteria above... - foreach(1..$n) { - my $init = shift @words; - return 1 if (substr $init,-1) eq substr $init,0,1; - foreach(2..$n) { - push @words,shift@words; - next unless (substr $init,-1) eq substr $words[0],0,1; - return 1 if substr($init,0,1) eq substr($words[0],-1); - return 1 if circ_any( $init.$words[0], @words[1..($n-2)] ); - } - push @words,$init; - } - ## In none match criteria we return 0... - return 0; -} -- cgit From aaf08e7d52840d43a649b2bd65babfb8d211b156 Mon Sep 17 00:00:00 2001 From: drbaggy Date: Sun, 6 Jun 2021 11:07:18 +0100 Subject: Update README.md --- challenge-115/james-smith/README.md | 327 ++++++++++++++++-------------------- 1 file changed, 142 insertions(+), 185 deletions(-) diff --git a/challenge-115/james-smith/README.md b/challenge-115/james-smith/README.md index 95ca983fee..4f9b1b131c 100644 --- a/challenge-115/james-smith/README.md +++ b/challenge-115/james-smith/README.md @@ -1,6 +1,6 @@ -# Perl Weekly Challenge #114 +# Perl Weekly Challenge #115 -# What no regexs or loops.... +# Cursing at recursion You can find more information about this weeks, and previous weeks challenges at: @@ -12,228 +12,185 @@ 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-114/james-smith/perl +https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-115/james-smith/perl -# Challenge 1 - Next highest palindrome +# Challenge 1 - String Chain -***You are given a positive integer `$N`. Write a script to find out -the next Palindrome Number higher than the given integer `$N`.*** +***You are given an array of strings. Write a script to find out if the given strings can be chained to form a circle. Print 1 if found otherwise 0.*** -## The solution - naive +## Clarification -We will see this again for the next challenge we just increment `$N` -until we find another palindrome. +Here we make the assumption that the chain includes **ALL** elements. -```perl -sub next_palindrome_naive { - my ($n) = @_; - 1 until ++$n eq reverse $n; - return $n -} -``` - -## The solution - optimized - -First we note that it is easier to compute the palindrome greater than -equal to itself {so we just incremement the passed parameter}. - -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.. +## The solution - a quick filter -### The cases.. +There is a trick to see if we have **NO** solution. If we keep a track +of all the times a letter appears at the beginning of the word AND at +the end then these have to be equal! We can do this in perl using a hash, +for initial letters we increment the value of the hash, for final letters +we decrement it. -There are two cases we need to consider: - - * There are an even number of digits - * There are an odd number of digits.. - -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. - -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.. +If any value in the hash at the end of the loop is non-zero then we have +an imbalance and so we can't find a solution. ```perl -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; - } -} + my %F; + ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; + return 0 if grep {$_} values %F; ``` -## Notes and Summary +If this check is passed we may still not have a solution as we may have +two or more circles. e.g. -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`... - -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. - -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... - -# Challenge 2 - Higher Integer Set Bits - -***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`.*** - - -## The solution - naive +``` + abc a->b->c m->n->o + cde ^ | ^ | + efg | v | v + gha h d t p + mno ^ | ^ | + opq | v | v + qrs g<-f<-e s<-r<-q + stm +``` +## The curse of recursion. -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. +We can use recursion to find out if we have ANY solution which +satisfies this criteria. ```perl -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 exhaust { + my ($init,@words) = @_; + my $n = @words; + if( $n==1) { + return substr($init,-1) eq substr($words[0],0,1) + && substr($init,0,1) eq substr($words[0],-1) ? 1 : 0; } + foreach(1..$n) { + push @words,shift @words; + next unless (substr $init,-1) eq substr $words[0],0,1; + return 1 if exhaust( $init.$words[0], @words[1..($n-1)] ); + } + return 0; } ``` - * 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. - -## The solution - optimized +We rotate the words array to avoid needing to do a complex `splice`... -We can easily find a solution to this problem. +This works - but for complex examples can hit the dreaded +"Deep recursion" warning... -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") +## The cure for recursion... -So e.g. `174 = 1010 1110` - you can replace either of the `01`s to give either: +We don't actually need to recurse here, we know that we can combine +the strings into 2 or more circles (in many different ways potentially). +But if we have two circles that touch - it is is easy to see that by +splicing the two circles together at this point makes a single large +circle... - * `1100 1110 = 206` - * `1011 0110 = 182` +So here comes solution 2.... -We note that to minimize the number we start by replacing the last `01` by `10` +Find a loop, if we have any words left - see if any of those words start +with a letter we have already seen in the loop. If so we repeat the +loop finder with the rest of the words... Probably easier to see in +pictures: -So we have: `182 = 1011 0110 > 174 = 1010 1100` - -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`; - -So now we have: `179 = 1011 0011 > 174 = 1010 110` - -The code then becomes either: - -```perl -sub next_bin_rex { - return oct '0b'.sprintf('0%b',shift) =~ s{01(1*)(0*)$}{10$2$1}r; -} ``` -or +abc + +cde -> a-b-c -> a-b-c -> a b c + | | | | | | +efg h d h d h d + | | | | | | +gha g-f-e g-f-e-o-p g e-o-p + | / \ | +eop e-o-p t q f q + | / |/ \ | +pqz t q z e-t-z + |/ +zte z +``` +So the non-recursive routine is: ```perl -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; +sub circ_single_non_recursive { + ## This quickly filters out those cases in which we + ## can't join end on end + my @words = @_; + my %F; + ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words; + return 0 if grep {$_} values %F; + + ## Now we start at any point and get the first circle, keeping + ## track of letters we have included in the loop(s) `%seen` + my %seen; + while(@words) { + my $init = shift @words; + $seen{ord $init}=1; + my $ptr = 0; + ## Skip this bit if the word is "self-closing" ie starts/ends + ## with same letter... + if( substr($init,0,1) ne substr $init, -1 ) { + while($ptr++ < @words) { + ## If we have a match - we just start again until + ## we do not find a match.... + if( (substr $init,-1) eq substr $words[0],0,1 ) { + $seen{ ord $words[0] } = 1; + $init =shift @words; + $ptr = 0; + return 1 unless @words; ## Return 1 we have got to end of list! + } + ## Rotate the list. + push @words, shift @words; + } + } + return 1 unless @words; ## We have no words left - success... + ## Do we have a loop that will extend the first loop... + ## Find any word which starts with a letter we have already seen! + $ptr=0; + $init=undef; + while( $ptr++ < @words) { + if($seen{ord $words[0]}) { + $init=1; + last; + } + push @words,shift@words; + } + return 0 unless $init; ## No words - so will return 0 + } + return 1; ## Got to the end - no words left! YAY!!! } ``` +## Summary -depending on whether or not you use a regular expression to find -the last "`01`" in the binary representaiton. +Looking at performance - avoiding recursion is good and increases +performance considerably. For small examples it is 5-20% faster, but +for more complex examples the benefit grows rapidly. -## The solution - with go faster stripes... +# Challenge 2 - Largest even -After a discussion on facebook with Eliza Skr, about whether or not -to use regexs rather than `rindex` she supplied a different algorithm -for finding the next number - which didn't involve manipulating the -binary string but by working out the arithmetic to make the changes. +***You are given a list of positive integers (`0`-`9`), single digit. Write a script to find the largest multiple of `2` that can be formed from the list.*** - * The number is of the form is `0 1111 00000000` - * The next hightest number is `1 000000000 111` - * To map `0 1111 00000000` to `1 000000000 000` we need to add - `1 00000000` (which is 2^#zeros) - * To map `1 000000000 000` to `1 000000000 111` we need to add `111` - which is 2^(#ones -1) -1 +## The solution -Eliza's solution was to obtain counts of `0`s and `1`s using a simple -regex `/(1+)(0*)$/` which works - but is still a regular expression, -which as we discussed above is a slow operation. +For once challenge 2 is easier. -We can replace this again with using `rindex`... Also rather than -using `2**$n` we replace it with the much quicker bit-shift operator -`1<<$n` - which achieves the same effect. +To find the largest number we just sort the digits in descending order +and stitch them together. -This gives us: +To find the largest even number we just sort the digits in descending +order, but move the lowest even number to the end. ```perl -sub next_bin_rindex2 { - my $t=rindex my$s=sprintf('%b',$_[0]),'1'; - return $_[0] + (1<<(-1-$t+length$s)) - - 1 + (1<<(-1+$t-rindex$s,'0',$t)); +sub biggest_even { + my $ptr = my @digits = reverse sort @{$_[0]}; + while( $ptr-- ) { + next if $digits[$ptr] & 1; ## Skip if odd... + return join '', + @digits[ 0..$ptr-1, $ptr+1..$#digits, $ptr ]; + } + return ''; } ``` -A few notes: - - * here we use the three parameter version of `rindex`, - which allows you to specify an offset for the search to start (in this - case we want the last "`0`" before the last "`1`" so we use the position - of the "`1`" as the offset) - * We use the bit-shift operator `<<` to raise to the power `2` - rather than the power operator.... If we break down all the efficiency - gains between the the rrev & rind2 methods - most of the gain would - be lost if we reverted back to `2**$n`. - * We looked to see if unpack was more efficient than sprintf - but found - that this was not the case {about 20-40% slower}. - -## Summary - -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`". - -Interestingly the `next_bin_rind2` seems to run at similar speeds for -all ranges of `$N`. - -The naive `next_bin` - doesn't have that property - at all and it -rapidly tails off performance wise. - -Running this a large number of times - we have the following -approximate rates for the calculations.... - -| Size of number | Rate rind2 | Rate rrev | Rate regex | Rate naive | -| -------------- | ---------: | ---------: | ---------: | ---------: | -| 1-500 | 1,900,000 | 1,550,000 | 500,000 | 600,000 | -| Approx 1000 | 1,800,000 | 1,500,000 | 440,000 | 400,000 | -| Approx 1x10^6 | 1,800,000 | 1,350,000 | 390,000 | 4,000 | -| Approx 1x10^9 | 1,850,000 | 1,250,000 | 330,000 | 1 | - -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 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. +The while loop just looks for the smallest even number & moves it +to the end using an array slice. \ No newline at end of file -- cgit From 3885bae764c6dcd435b7f888a714164d17c86fde Mon Sep 17 00:00:00 2001 From: James Smith Date: Sun, 6 Jun 2021 12:13:22 +0100 Subject: Update README.md --- challenge-115/james-smith/README.md | 39 ++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) diff --git a/challenge-115/james-smith/README.md b/challenge-115/james-smith/README.md index 4f9b1b131c..a4832b193e 100644 --- a/challenge-115/james-smith/README.md +++ b/challenge-115/james-smith/README.md @@ -166,6 +166,43 @@ Looking at performance - avoiding recursion is good and increases performance considerably. For small examples it is 5-20% faster, but for more complex examples the benefit grows rapidly. +### A difficult example... + +To test performance I created a random sequence of words (all combinations +of 2 letters!)... There is obvious a solution to this, but there are also +many many shorter solutions... + +The non-recursive solution is approximately 6 times faster. + +``` +pk fz iy oz cf xm gm uy ur te ct zz rw jm aq oq xy mi me rv jc iv sx pq lz nd +cm vj uf rq ij zk ef wm bb cj vv oo og ft fq mj os uh gn ml mz fm az yr zh wa +bm gj xn df yf er xc xb bl uw ri nq nn oi pc ym jr da rz bq vm sr ni jz po oj +wf iu ja tu lk yt nc sl wi zb hm uv th kn hk pv yq ez we im gt za sj nh qr bt +rr ok ai xx qs lg ue fc ws vc vy ki xi wy fv lt rl xw nj gu dz ip zl je pf hn +uk di mv ug vf uz wt yn qx rh sz fh pm sa qz gp gw jp ve le fe ia nw pu km uo +gy li pe hj mn ew hg qg se mq by vh ca hd bn nl xu dd ji bd ol vp wp yo st ac +bh bx fa md zx mm ox qi mc lc jx wz jd xt vr yj pn uj zy ih ul pb id xh wb qq +xg ou sp bo yz bu ec vz fy io hl jo cl zs ge tz qp mf zf kq sk qw as vs rm jw +yk tr cw tk xz kt ra qo tj fu dy hx ic ej nt jt gf ko rd od ep qn sg ek ui bg +iw zm at dv fx kb xr nu xl xs lr xk na ne xe rt jf ga hv kf xq sq pt cp rj fr +fp qf gg ii ey tn ce ya kl wc ks qh em gc ts dn wk is fo pa sd ly uc zn dk wq +bw tq kg xf vn ea hh ik lm nr wd kc mu ru co kx nb gl fs bi hu fk ld qa qy qm +wl cn cr zd ke jl gz wr xp tm tl kj no ex wj su dc sh ee hf dw ax ms hq jj sb +ed qj vw ha ju wx yi sf ln jy rx ei sy ar dm hr al ah mb on ob uq ps lv ad jk +rb fb gk cc rp jq ka my ix nv re vk tp zw rg tb up pp uu ds ho zv nf ty cu kp +eg in lu hy mk um zt hc qt yp tv rk hb pj ph bk af to lq qe ib gi bz jh iz lo +yv ci jg gh yx bj il cz gx ro ff kk vd ub et bs tw si qd ql au ti xj yh yl kr +om nx lw wo gs gq ku mw py tx ll fl xd ch rc go dt lx zu ry hz bc lj la lh ux +sc fn it ir tt mo pr gd sm mx jn cd vl vb mt pz vt he eh ss dh dj yw xv be ov +wh ww pg ao es ye xa vq hs yc yd vu ns zr lf rs pl cs eo zi qb qk so oc wn el +zc yb de mg fw cx cv wv ot cb qu wu nm ow zp rn hw lp ma en vg cy rf tc am ut +cq sv kv oh jb np us ck mh ny gr gb op an kw aa vo zq iq ba px dr un or ze bp +zg eb ud if dl dq zj ky bf vi cg ua br yu mp bv sn pi db ae of kh pd hp qc jv +xo du fg ta do kd dx av ys tg ls fi kz tf eu aj sw vx oa pw fd ab hi va lb dg +ig dp nz js qv ag aw eq mr zo yy ie nk yg ap oe gv oy ht ev ak td ay fj ng wg +``` + # Challenge 2 - Largest even ***You are given a list of positive integers (`0`-`9`), single digit. Write a script to find the largest multiple of `2` that can be formed from the list.*** @@ -193,4 +230,4 @@ sub biggest_even { ``` The while loop just looks for the smallest even number & moves it -to the end using an array slice. \ No newline at end of file +to the end using an array slice. -- cgit