Merge pull request #4207 from drbaggy/master

tweak to graphic

3 files changed, 96 insertions, 188 deletions

diff --git a/challenge-115/james-smith/README.md b/challenge-115/james-smith/README.md
index a4832b193e..3664833537 100644
--- a/challenge-115/james-smith/README.md
+++ b/challenge-115/james-smith/README.md
@@ -81,127 +81,50 @@ This works - but for complex examples can hit the dreaded
 
 ## The cure for recursion...
 
-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...
+It turns out we don't have to do this recursive search. Instead
+we can use a simple loop to propogate our search from a starting
+word.
 
-So here comes solution 2....
+We create a "tree" structure where each letter "node" is connected
+to another "node"... We get a hash of hashes.
 
-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:
+We choose one starting "word" and see which words we can attach
+to the end to get the "2nd level" of letters, and repeate.
 
-```
-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 
-```
+This loop boils down to 2 operations:
+
+ * Remove elements from the graph that we have processed
+ * Check elements we have just found...
+
+We repeat until we no-longer remove elements.
 
-So the non-recursive routine is:
+If we have removed all the elements we do have a single loop, otherwise
+it will be connected.
+   
 ```perl
-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
+sub circ_single_connected_nc {
+  my( %F, %ends );
+
+  ( $F{ substr $_, 0, 1 }++, $F{    substr $_, -1   }-- ) foreach @_;
+  return 0 if grep {$_} values %F;
+
+  $ends{ substr $_, 0, 1 }{ substr $_, -1 }=1 foreach @_;
+  my @seeds = [keys %ends]->[0];
+  while(@seeds) {
+    my %x   = map { $_ => 1 }
+              map { keys %{ delete $ends{$_} } }
+              @seeds;
+    @seeds  = grep { exists $ends{$_} } keys %x;
   }
-  return 1; ## Got to the end - no words left! YAY!!!
+  return keys %ends ? 0 : 1;
 }
 ```
 ## Summary
 
 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
-```
+performance considerably. For simple examples there is a slight
+gain but as the "graph" gets more complex then the performance
+improves dramatically.
 
 # Challenge 2 - Largest even
 
diff --git a/challenge-115/james-smith/blog.txt b/challenge-115/james-smith/blog.txt
new file mode 100644
index 0000000000..e247114a1c
--- /dev/null
+++ b/challenge-115/james-smith/blog.txt
@@ -0,0 +1 @@
+https://github.com/drbaggy/perlweeklychallenge-club/tree/master/challenge-115/james-smith
diff --git a/challenge-115/james-smith/perl/ch-1.pl b/challenge-115/james-smith/perl/ch-1.pl
index b7ea0e4418..df88d84a2c 100644
--- a/challenge-115/james-smith/perl/ch-1.pl
+++ b/challenge-115/james-smith/perl/ch-1.pl
@@ -8,76 +8,82 @@ 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 ],
+  [ [qw(abc dea cd)], 1],
+  [ [qw(ade cbd fgh)], 0 ],
+  [ [qw(ab bc ca de ef fd)], 0 ],
+  [ [qw(ab bc ca ae)], 0 ],
+  [ [qw(bad bed bid bod bud dub dob dib deb dab)], 1 ],
+  [ [qw(abc def fed)], 0 ],
+  [ [qw(ana)], 1 ],
+  [ [qw(ana bob)], 0 ],
+  [ [qw(ana one ant glo ten era nag )], 1 ],
+  [ [qw(ana bad bed dab deb)], 0 ],
+  [ [qw(bad bed ana dab deb)], 0 ],
+  [ [qw(abc cde efg ghi ijk kla cpq qpc eft the ilm mli)], 1 ],
+#); @examples = (
+  [ [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 ],
 );
 
-warn "SNR";
-is(circ_single_non_recursive(@{$_->[0]}),$_->[1]) foreach @examples;
-warn "S";
+is(circ_single_connected(@{$_->[0]}),$_->[1]) foreach @examples;
 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; },
+  nr => sub { circ_single_connected(@{$_->[0]}) foreach @examples; },
+  r  => sub { circ_single(@{$_->[0]}) foreach @examples; },
 } );
 
-sub circ_single_non_recursive {
-  my @words = @_;
-  my %F;
-  ($F{substr$_,0,1}++,$F{substr$_,-1}--) foreach @words;
+sub circ_single_connected {
+  my(%F,%ends);
+
+  ## %F    contains the number of starts - number of ends...
+  ## %ends contains a hash of hashes - first key is the first letter of the world,
+  ##                                   2nd level end of the world.
+
+  ( $F{ substr $_, 0, 1 }++, $F{    substr $_, -1   }-- ) foreach @_;
+  ## Rule out those that cannot be connected in loop....
   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 have to see if we have connectivity...
+  ## Take any (the first) element...
+
+  $ends{ substr $_, 0, 1 }{ substr $_, -1 }++ foreach @_;
+  my @seeds = [keys %ends]->[0];
+
+  while(@seeds) { ## If we have any seeds then we
+    ## Remove the information about ends from the list for each
+    ## letter in the seed list.. (start words)
+    ## For each of these we collect the end letters (using a hash
+    ## to uniqueify them)
+    my %x  = map { $_ => 1 }
+             map { keys %{ delete $ends{$_} } }
+             @seeds;
+    ## We then remove any letters which we have already processed
+    ## {i.e. those that have already been removed from %ends}
+    @seeds = grep { exists $ends{$_} } keys %x;
+  }
+  ## If we have stuff left it ends there will be 2 or more connected loops.
+  return keys %ends ? 0 : 1;
   ## 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;
+}
+
+sub circ_single_connected_nc {
+  my( %F, %ends );
+  ( $F{ substr $_, 0, 1 }++, $F{    substr $_, -1   }-- ) foreach @_;
+  return 0 if grep {$_} values %F;
+
+  $ends{ substr $_, 0, 1 }{ substr $_, -1 }=1 foreach @_;
+  my @seeds = [keys %ends]->[0];
+  while(@seeds) {
+    my %x   = map { $_ => 1 }
+              map { keys %{ delete $ends{$_} } }
+              @seeds;
+    @seeds  = grep { exists $ends{$_} } keys %x;
   }
-  return 1;
+  return keys %ends ? 0 : 1;
 }
 
 sub circ_single {
@@ -121,25 +127,3 @@ no warnings 'recursion'; ## Disable deep recursion warning - this gets messy...
   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;
-}