Merge pull request #3040 from drbaggy/master

Completely different solution to ch-1.. which I think is incredibly neat

3 files changed, 101 insertions, 16 deletions

diff --git a/challenge-092/james-smith/perl/ch-1-firstpass.pl b/challenge-092/james-smith/perl/ch-1-firstpass.pl
new file mode 100644
index 0000000000..b4fc12b5e3
--- /dev/null
+++ b/challenge-092/james-smith/perl/ch-1-firstpass.pl
@@ -0,0 +1,34 @@
+#!/usr/local/bin/perl
+
+use strict;
+
+use warnings;
+use feature qw(say);
+use Test::More;
+
+is( iso('abc','xyz'), 1 );
+is( iso('abb','xyy'), 1 );
+is( iso('sum','add'), 0 );
+is( iso('add','sum'), 0 );
+
+done_testing( );
+
+sub iso {
+  my ($a,$b) = @_;
+  my %x;
+  my %y;
+  return 0 unless length $a == length $b;
+  my @b = split m{}, $b;
+  foreach ( split m{}, $a ) {
+    my $t = shift @b;
+    if( exists $x{$_} ) { ## Have we already got a map from 1st letter?
+      return 0 unless $x{$_} eq $t; ## Yes but it doesn't match return...
+    } else {
+      $x{$_} = $t;
+      return 0 if exists $y{$t} && $y{$t} ne $_;
+    }
+    $y{$t} = $_;
+  }
+  return 1;
+}
+
diff --git a/challenge-092/james-smith/perl/ch-1-list-iso-words.pl b/challenge-092/james-smith/perl/ch-1-list-iso-words.pl
new file mode 100644
index 0000000000..040b7e5db1
--- /dev/null
+++ b/challenge-092/james-smith/perl/ch-1-list-iso-words.pl
@@ -0,0 +1,44 @@
+#!/usr/local/bin/perl
+
+use strict;
+
+use warnings;
+use feature qw(say);
+use Test::More;
+
+## Usage
+#
+# perl ch-1-list-iso-words.pl {n} < wordlist.txt
+#
+# Where wordlist is a list of lowercased words with no hyphens etc
+#
+# {n} is optional if 0 - it lists all words
+# {n} > 0 lists all words who have {n} or more repeated characters e.g. abba has two eerie has two
+
+my $filter = 0;
+$filter = $ARGV[0] if @ARGV;
+my %words;
+
+while(<STDIN>) {
+  chomp;
+  ## Initialise letter cache and "counter"
+  next if 1 == length $_;
+  my($x,%m)='a';
+  push @{$words{join '',  ## Stitch back the word and return it....
+    map { $m{$_}||=$x++ } ## Return letter from cache (or next letter)
+    split m{}, $_         ## Split into individual characters
+  }}, $_;
+}
+
+foreach ( sort { (length($a)<=> length($b)) || (reverse($a) cmp reverse($b)) } keys %words) {
+  next if @{$words{$_}} <2;
+  if( $filter > 0 ) {
+    my %t;
+    %t = map { $_=>1 } split m{}, $_;
+    my $l = scalar keys %t;
+    next unless $l < length($_) - $filter -1;
+  }
+  printf "%4d : %4d : %5d : %20s : %s\n",
+    length $_, length($_)-$l, (scalar @{$words{$_}}), $_, "@{$words{$_}}";
+}
+
diff --git a/challenge-092/james-smith/perl/ch-1.pl b/challenge-092/james-smith/perl/ch-1.pl
index b4fc12b5e3..43a1d4c5e3 100644
--- a/challenge-092/james-smith/perl/ch-1.pl
+++ b/challenge-092/james-smith/perl/ch-1.pl
@@ -14,21 +14,28 @@ is( iso('add','sum'), 0 );
 done_testing( );
 
 sub iso {
-  my ($a,$b) = @_;
-  my %x;
-  my %y;
-  return 0 unless length $a == length $b;
-  my @b = split m{}, $b;
-  foreach ( split m{}, $a ) {
-    my $t = shift @b;
-    if( exists $x{$_} ) { ## Have we already got a map from 1st letter?
-      return 0 unless $x{$_} eq $t; ## Yes but it doesn't match return...
-    } else {
-      $x{$_} = $t;
-      return 0 if exists $y{$t} && $y{$t} ne $_;
-    }
-    $y{$t} = $_;
-  }
-  return 1;
+  ## This one needs a bit of explanation....
+  ## We are going to normalise the strings - by replacing first chr
+  ## and all its subsequent occurances with 'a', 2nd (different) character
+  ## with 'b' .....
+  ## so above examples we get...
+  ##   abc -> abc   xyz -> abc
+  ##   abb -> abb   xyy -> abb
+  ##   sum -> abc   add -> abb
+  ##   add -> abc   sum -> abc
+
+  my ($a,$b) = map {
+    ## Initialise letter cache and "counter"
+    my ($x,%m)='a';
+    join '',                ## Stitch back the word and return it....
+      map { $m{$_}||=$x++ } ## Return letter from cache (or next letter)
+      split m{}, $_         ## Split into individual characters
+  } @_;
+  return $a eq $b || 0;  ## Check to see if generated words are isomorphic
+}
+
+sub iso_without_comments {
+  my ($a,$b) = map { my ($x,%m)='a'; join '', map { $m{$_}||=$x++ } split m{}, $_ } @_;
+  return $a eq $b || 0;
 }