diff options
| -rw-r--r-- | challenge-115/james-smith/perl/ch-2.pl | 75 |
1 files 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; |