two Perl scripts for the interesting tasks this week

2 files changed, 81 insertions, 0 deletions

diff --git a/challenge-102/cheok-yin-fung/perl/ch-1.pl b/challenge-102/cheok-yin-fung/perl/ch-1.pl
new file mode 100644
index 0000000000..eab209da06
--- /dev/null
+++ b/challenge-102/cheok-yin-fung/perl/ch-1.pl
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+# The Weekly Challenge #102 Task 1 Rare Numbers
+# Usage: ch-1.pl [number of digits]
+use strict;
+use warnings;
+
+sub rvrse {
+    my $r = $_[0];
+    my $r1 = join "", reverse split //, $r;
+    return $r1;
+}
+
+sub check_sq {
+    return (sqrt $_[0]) =~ /^\d+$/;
+}   
+
+sub check_rare {
+    my $r = $_[0];
+    my $a = substr($r,0,1);
+    my $q = substr($r,-1,1);
+    return undef if $a % 2 == 1;  
+    return undef if 
+        $a == 2 
+        && !( $q == 2   
+              && substr($r,1,1) == substr($r,-2,1) );
+    return undef if 
+        $a == 4 && !($q == 0);
+    return undef if
+        $a == 6 && !($q == 0 || $q == 5);
+    return undef if
+        $a == 8 && !($q == 2 || $q == 3 || $q == 7 || $q == 8);
+   # above: properties of rare number, as noted in website
+   # http://www.shyamsundergupta.com/rare.htm
+
+    my $r1 = rvrse $r;
+    return undef if $r1 > $r;
+    return check_sq($r+$r1) && check_sq($r-$r1);
+}
+
+my $N = $ARGV[0];
+
+if ($N == 1) {
+    print "2\n8\n";
+    exit;
+}
+
+my $bN = "1" . "0" x ($N-1);
+my $eN = "9" x $N;
+
+for my $k ($bN..$eN) {
+    print $k , "\n" if check_rare $k;
+}
+
+# PERFORMANCE COMMENT:
+# reasonable time for length = 7 ,
+# be patient for length = 8 (one term, which is palindromic)
+# over 2 min and killed for length = 9 ...
diff --git a/challenge-102/cheok-yin-fung/perl/ch-2.pl b/challenge-102/cheok-yin-fung/perl/ch-2.pl
new file mode 100644
index 0000000000..063d0d05fe
--- /dev/null
+++ b/challenge-102/cheok-yin-fung/perl/ch-2.pl
@@ -0,0 +1,24 @@
+#!/usr/bin/perl
+# The Weekly Challenge #102
+# Task 2 Hash-counting String
+# Usage: ch-2.pl [positive integer]
+use strict;
+use warnings;
+use Test::Simple tests => 5;
+
+sub hcs {
+    my $N = $_[0];
+    return "#" if $N == 1;
+    return "2#" if $N == 2;
+    my $p = length $N;
+    return (hcs($N-$p-1) . "$N" . "#");
+}
+
+print hcs($ARGV[0]), "\n" 
+    if defined($ARGV[0]) && $ARGV[0] > 0 && $ARGV[0]=~/^\d+$/;
+
+ok hcs(1) eq "#", "Example a" ;
+ok hcs(2) eq "2#", "Example b";
+ok hcs(3) eq "#3#", "Example c";
+ok hcs(10) eq "#3#5#7#10#", "Example d";
+ok hcs(14) eq "2#4#6#8#11#14#", "Example e";