first commit

perl/Examples/Chap3/RGB-CMYK

@@ -0,0 +1,16 @@
+
+
+###
+### RGB_to_CMYK
+###
+
+## Chapter 3 section 
+
+sub RGB_to_CMYK {
+  my ($r, $g, $b) = @_;
+  my ($c, $m, $y) = (255-$r, 255-$g, 255-$b);
+  my $k = $c < $m ? ($c < $y ? $c : $y)
+                  : ($m < $y ? $m : $y);  # Minimum
+  for ($c, $m, $y) { $_ -= $k }
+  [$c, $m, $y, $k];  
+}     

perl/Examples/Chap3/RGB-CMYK-caching

@@ -0,0 +1,20 @@
+
+
+###
+### RGB_to_CMYK_caching
+###
+
+## Chapter 3 section 
+
+my %cache;        
+
+sub RGB_to_CMYK {
+  my ($r, $g, $b) = @_;
+  my $key = join ',', $r, $g, $b;
+  return $cache{$key} if exists $cache{$key}; 
+  my ($c, $m, $y) = (255-$r, 255-$g, 255-$b);
+  my $k = $c < $m ? ($c < $y ? $c : $y)
+                  : ($m < $y ? $m : $y);  # Minimum
+  for ($c, $m, $y) { $_ -= $k }
+  return $cache{$key} = [$c, $m, $y, $k];  
+}

perl/Examples/Chap3/chrono-1

@@ -0,0 +1,27 @@
+
+
+###
+### chronologically
+###
+
+## Chapter 3 section 10
+
+@sorted_dates = sort chronologically @dates;
+
+%m2n = 
+   ( jan =>  1, feb =>  2, mar =>  3,
+     apr =>  4, may =>  5, jun =>  6, 
+     jul =>  7, aug =>  8, sep =>  9, 
+     oct => 10, nov => 11, dec => 12, );
+
+sub chronologically {
+  my ($am, $ad, $ay) = 
+    ($a =~ /(\w{3}) (\d+), (\d+)/);
+
+  my ($bm, $bd, $by) = 
+    ($b =~ /(\w{3}) (\d+), (\d+)/);
+
+             $ay  <=>         $by  
+  || $m2n{lc $am} <=> $m2n{lc $bm} 
+  ||         $ad  <=>         $bd;
+}

perl/Examples/Chap3/chrono-2

@@ -0,0 +1,28 @@
+
+
+###
+### chronologically-2
+###
+
+## Chapter 3 section 10
+
+@sorted_dates = sort chronologically @dates;
+
+%m2n = 
+   ( jan =>  1, feb =>  2, mar =>  3,
+     apr =>  4, may =>  5, jun =>  6, 
+     jul =>  7, aug =>  8, sep =>  9, 
+     oct => 10, nov => 11, dec => 12, );
+
+sub chronologically {
+  my ($am, $ad, $ay) = split_date($a);
+  my ($bm, $bd, $by) = split_date($b);
+
+             $ay  <=>         $by  
+  || $m2n{lc $am} <=> $m2n{lc $bm} 
+  ||         $ad  <=>         $bd;
+}
+
+sub split_date {
+  $_[0] =~ /(\w{3}) (\d+), (\d+)/;
+}

perl/Examples/Chap3/chrono-3

@@ -0,0 +1,24 @@
+
+
+###
+### chronologically-3
+###
+
+## Chapter 3 section 10
+
+@sorted_dates = sort chronologically @dates;
+
+%m2n = 
+   ( jan =>  1, feb =>  2, mar =>  3,
+     apr =>  4, may =>  5, jun =>  6, 
+     jul =>  7, aug =>  8, sep =>  9, 
+     oct => 10, nov => 11, dec => 12, );
+
+sub chronologically {
+  date_to_string($a) cmp date_to_string($b)
+}
+
+sub date_to_string {
+  my ($m, $d, $y) = ($_[0] =~ /(\w{3}) (\d+), (\d+)/);
+  sprintf "%04d%02d%02d", $y, $m2n{lc $m}, $d;
+}

perl/Examples/Chap3/chrono-orc

@@ -0,0 +1,15 @@
+
+
+###
+### chronologically-orcish
+###
+
+## Chapter 3 section 10
+
+{ my %cache;
+  sub chronologically {
+    ($cache{$a} ||= date_to_string($a))
+       cmp
+    ($cache{$b} ||= date_to_string($b))
+  }
+}

perl/Examples/Chap3/closure-example

@@ -0,0 +1,18 @@
+
+
+###
+### closure-example
+###
+
+## Chapter 3 section 5.2
+
+sub make_counter {
+  my $n = shift;
+  return sub { print "n is ", $n++ };
+}
+
+my $x = make_counter(7);
+my $y = make_counter(20);
+$x->();  $x->();  $x->();
+$y->();  $y->();  $y->();
+$x->();

perl/Examples/Chap3/delivery-charge

@@ -0,0 +1,16 @@
+
+
+###
+### delivery-charge
+###
+
+## Chapter 3 section 7.5
+
+sub delivery_charge {
+  my ($quantity_ordered) = @_;
+  my ($hour, $day_of_week) = (localtime)[2,6];
+  # perform complex computatation involving $weight, $gross_cost,
+  #     $hour, $day_of_week, and $quantity_ordered
+  # ...
+  return $delivery_charge;
+}

perl/Examples/Chap3/fib-automemo

@@ -0,0 +1,19 @@
+
+
+###
+### fib-automemo
+###
+
+## Chapter 3 section 4
+
+use Memoize;
+memoize 'fib';
+
+# Compute the number of pairs of rabbits alive in month n
+sub fib {
+  my ($month) = @_;
+  if ($month < 2) { 1 }
+  else {
+      fib($month-1) + fib($month-2);
+  }
+} 

perl/Examples/Chap3/fib-cached

@@ -0,0 +1,21 @@
+
+
+###
+### fib-cached
+###
+
+## Chapter 3 section 2
+
+# Compute the number of pairs of rabbits alive in month n
+{ my %cache;
+  sub fib {
+    my ($month) = @_;
+    unless (exists $cache{$month}) {
+      if ($month < 2) { $cache{$month} = 1 }
+      else {
+        $cache{$month} = fib($month-1) + fib($month-2);
+      }
+    } 
+    return $cache{$month};
+  }
+}

perl/Examples/Chap3/memoize

@@ -0,0 +1,18 @@
+
+
+###
+### memoize
+###
+
+## Chapter 3 section 5
+
+sub memoize {
+  my ($func) = @_;
+  my %cache;
+  my $stub = sub {
+    my $key = join ',', @_;
+    $cache{$key} = $func->(@_) unless exists $cache{$key};
+    return $cache{$key};
+  };
+  return $stub;
+}

perl/Examples/Chap3/memoize-method

@@ -0,0 +1,16 @@
+
+
+###
+### memoize_method
+###
+
+## Chapter 3 section 8.1
+
+sub memoize_method {
+  my ($method, $key) = @_;
+  return sub {
+    my $self = shift;
+    return $self->{$key} if exists $self->{$key};
+    return $self->{$key} = $method->($self, @_);
+  };
+}

perl/Examples/Chap3/memoize-norm3

@@ -0,0 +1,22 @@
+
+
+###
+### memoize-normalize3
+###
+
+## Chapter 3 section 7
+
+sub memoize {
+  my ($func, $keygen) = @_;
+  $keygen ||= q{join ',', @_};
+
+  my %cache;
+  my $newcode = q{ 
+    sub { my $key = do { KEYGEN };
+          $cache{$key} = $func->(@_) unless exists $cache{$key};
+          return $cache{$key};
+        }
+  };
+  $newcode =~ s/KEYGEN/$keygen/g;
+  return eval $newcode;
+}

perl/Examples/Chap3/memoize-norm4

@@ -0,0 +1,27 @@
+
+
+###
+### memoize-normalize4
+###
+
+## Chapter 3 section 7
+
+sub memoize {
+  my ($func, $keygen) = @_;
+  my $keyfunc;
+  if ($keygen eq '') {
+    $keygen = q{join ',', @_} 
+  } elsif (UNIVERSAL::isa($keygen, 'CODE')) {
+    $keyfunc = $keygen;
+    $keygen = q{$keyfunc->(@_)};
+  }
+  my %cache;
+  my $newcode = q{ 
+    sub { my $key = do { KEYGEN };
+          $cache{$key} = $func->(@_) unless exists $cache{$key};
+          return $cache{$key};
+        }
+  };
+  $newcode =~ s/KEYGEN/$keygen/g;
+  return eval $newcode;
+}

perl/Examples/Chap3/profile

@@ -0,0 +1,30 @@
+
+
+###
+### profile
+###
+
+## Chapter 3 section 12.2
+
+use Time::HiRes 'time';
+my (%time, %calls);
+
+sub profile {
+  my ($func, $name) = @_;
+  my $stub = sub {
+    my $start = time;
+    my $return = $func->(@_);
+    my $end = time;
+    my $elapsed = $end - $start;
+    $calls{$name} += 1;
+    $time{$name}  += $elapsed;
+    return $return;
+  };
+  return $stub;
+}
+END {
+  printf STDERR "%-12s %9s %6s\n", "Function", "# calls", "Elapsed";
+  for my $name (sort {$time{$b} <=> $time{$a}} (keys %time)) {
+    printf "%-12s %9d %6.2f\n", $name, $calls{$name}, $time{$name};
+  }
+}