week 114 Perl scripts

2 files changed, 126 insertions, 0 deletions

diff --git a/challenge-114/cheok-yin-fung/perl/ch-1.pl b/challenge-114/cheok-yin-fung/perl/ch-1.pl
new file mode 100644
index 0000000000..d061baf685
--- /dev/null
+++ b/challenge-114/cheok-yin-fung/perl/ch-1.pl
@@ -0,0 +1,61 @@
+#!/usr/bin/perl
+# The Weekly Challenge 114
+# Task 1 Next Palindrome Number
+# Usage: ch-1.pl [positive integer]
+use strict;
+use warnings;
+
+my $integer = $ARGV[0] || 123454320;
+die "Please input a decimal positive integer.\n"
+    unless $integer =~ /^[1-9][0-9]*$/;
+
+print higher_pal($integer), "\n";
+
+
+
+sub higher_pal {
+    my $n = $_[0];
+    if ($n == (10**length $n) - 1 ) {
+        return (10**length $n)+1;
+    }
+
+    my $suff = substr($n, 0, ((length $n) + 1)/2);
+    my $p = pal_from_half( $suff, (length $n) % 2 );
+    if ($n >= $p) {
+        return pal_from_half( $suff+1, (length $n) % 2 );
+    } 
+    else {
+        return $p;
+    }
+}
+
+sub pal_from_half {
+    my $s = $_[0];
+    my $suf = substr( $s  , 0 , (length $s) - $_[1] );
+    my $mid = $_[1] ? substr($s, -1, 1) : "";
+    my $new = join "", $suf, $mid, reverse (split //, $suf);
+    return $new;
+}
+
+=pod TEST DATA:
+my %data_ret = 
+   (103 => 111,
+    999 => 1001,
+    9999 => 10001,
+    123 => 131,
+    121 => 131,
+    1048576 => 1049401,
+    1234 => 1331,
+   );
+...
+
+test case parameter 103: passed 
+test case parameter 123: passed 
+test case parameter 1234: passed 
+test case parameter 9999: passed 
+test case parameter 121: passed 
+test case parameter 999: passed 
+test case parameter 1048576: passed 
+
+done 7 test case(s); PASS: 7 case(s) .
+=cut
diff --git a/challenge-114/cheok-yin-fung/perl/ch-2.pl b/challenge-114/cheok-yin-fung/perl/ch-2.pl
new file mode 100644
index 0000000000..e10b8fe810
--- /dev/null
+++ b/challenge-114/cheok-yin-fung/perl/ch-2.pl
@@ -0,0 +1,65 @@
+#!/usr/bin/perl
+# The Weekly Challenge 114
+# Task 2 Higher Integer Set Bits
+# Usage: ch-2.pl [positive integer]
+# case I: bitstrings having the form 1..10..0
+# case II : bitstring having the form 1..1
+# case III: bitstrings ends with 1(s) and there exists 0 in the string
+# case IV : bitstring ends with 0(s) and 
+#                   there exists 0 besides the trailing zero(s)
+use strict;
+use warnings;
+use experimental 'switch';
+
+my $N = $ARGV[0] || 1048576; 
+
+die "Please input a decimal positive integer.\n"
+    unless $N =~ /^[1-9][0-9]*$/;
+
+my $bitstr = sprintf("%0b",$N);
+
+#print $N, "->", $bitstr, "->", hisb($bitstr), "->";
+print bin2dec(hisb($bitstr)), "\n";
+
+
+
+sub hisb {
+    given ($bitstr) {
+        when( /^[1]+[0]+$/ ) {
+            my $copyo = $_;
+            my $copyz = $_;
+            $copyo =~ tr/0//d;
+            $copyz =~ tr/1//d;
+            my $n_o = length $copyo;
+            my $n_z = length $copyz;
+            return "1" . "0" x ($n_z+1) . "1" x ($n_o-1);
+        }
+        when( /^[1]+$/ ) {
+            return "1"."0". "1" x  ((length $_) - 1);
+        }
+        when( /0/ && /1$/ ) {
+            $bitstr =~ /([1]+)$/;
+            my $n_end_o = length $1;
+            return 
+                 substr( $bitstr ,0, (length $bitstr) - $n_end_o - 1 )
+                ."1"
+                ."0"
+                ."1" x ($n_end_o-1);
+        }
+        when( /0/ && /0$/ ) {
+            $bitstr =~ /0([1]+)([0]+)$/;
+            my $n_mid_o = length $1;
+            my $n_end_z = length $2;
+            return
+                 substr( $bitstr, 0, (length $bitstr) - $n_mid_o - $n_end_z - 1)
+                ."1"
+                ."0" x ($n_end_z+1)
+                ."1" x ($n_mid_o-1);
+        }
+    }
+}
+
+sub bin2dec {            #copy from Perl Cookbook
+    return unpack("N", pack("B32", substr("0" x 32 . $_[0], -32)));
+}
+