first commit

perl/Examples/Chap1/binary

@@ -0,0 +1,16 @@
+
+
+###
+### binary
+###
+
+## Chapter 1 section 1
+
+sub binary {
+  my ($n) = @_;
+  return $n if $n == 0 || $n == 1; 
+  my $k = int($n/2);
+  my $b = $n % 2;
+  my $E = binary($k);
+  return $E . $b;
+}

perl/Examples/Chap1/check-move

@@ -0,0 +1,29 @@
+
+
+###
+### check_move
+###
+
+## Chapter 1 section 3
+
+@position = (' ', ('A') x 3); # Disks are all initially on peg A
+
+sub check_move {
+  my $i;
+  my ($disk, $start, $end) = @_;
+  if ($disk < 1 || $disk > $#position) {
+    die "Bad disk number $disk. Should be 1..$#position.\n";
+  }
+  unless ($position[$disk] eq $start) {
+    die "Tried to move disk $disk from $start, but it is on peg $position[$disk].\n";
+  }
+  for $i (1 .. $disk-1) {
+    if ($position[$i] eq $start) {
+      die "Can't move disk $disk from $start because $i is on top of it.\n";
+    } elsif ($position[$i] eq $end) {
+      die "Can't move disk $disk to $end because $i is already there.\n";
+    }
+  }
+  print "Moving disk $disk from $start to $end.\n";
+  $position[$disk] = $end;
+}

perl/Examples/Chap1/dir-walk-cb

@@ -0,0 +1,29 @@
+
+
+###
+### dir_walk_callbacks
+###
+
+## Chapter 1 section 5
+
+sub dir_walk {
+  my ($top, $filefunc, $dirfunc) = @_;
+  my $DIR;
+
+  if (-d $top) {
+    my $file;
+    unless (opendir $DIR, $top) {
+      warn "Couldn't open directory $code: $!; skipping.\n";
+      return;
+    }
+
+    my @results;
+    while ($file = readdir $DIR) {
+      next if $file eq '.' || $file eq '..';
+      push @results, dir_walk("$top/$file", $filefunc, $dirfunc);
+    }
+    return $dirfunc->($top, @results);
+  } else {
+    return $filefunc->($top);
+  }
+}

perl/Examples/Chap1/dir-walk-cb-def

@@ -0,0 +1,29 @@
+
+
+###
+### dir_walk_callbacks_defaults
+###
+
+## Chapter 1 section 5
+
+sub dir_walk {
+  my ($top, $filefunc, $dirfunc) = @_;
+  my $DIR;
+
+  if (-d $top) {
+    my $file;
+    unless (opendir $DIR, $top) {
+      warn "Couldn't open directory top: $!; skipping.\n";
+      return;
+    }
+
+    my @results;
+    while ($file = readdir $DIR) {
+      next if $file eq '.' || $file eq '..';
+      push @results, dir_walk("$top/$file", $filefunc, $dirfunc);
+    }
+    return $dirfunc ? $dirfunc->($top, @results) : () ;
+  } else {
+    return $filefunc ? $filefunc->($top): () ;
+  }
+}

perl/Examples/Chap1/dir-walk-simple

@@ -0,0 +1,26 @@
+
+
+###
+### dir_walk_simple
+###
+
+## Chapter 1 section 5
+
+sub dir_walk {
+  my ($top, $code) = @_;
+  my $DIR;
+  
+  $code->($top);
+  
+  if (-d $top) {
+    my $file;
+    unless (opendir $DIR, $top) {
+      warn "Couldn't open directory $top: $!; skipping.\n";
+      return;
+    }
+    while ($file = readdir $DIR) {
+      next if $file eq '.' || $file eq '..';
+      dir_walk("$top/$file", $code);
+    }
+  }
+}

perl/Examples/Chap1/dir-walk-sizehash

@@ -0,0 +1,27 @@
+
+
+###
+### dir-walk-sizehash
+###
+
+## Chapter 1 section 5
+
+sub file {
+  my $file = shift;
+  [short($file), -s $file];
+}
+
+sub short {
+  my $path = shift;
+  $path =~ s{.*/}{};
+  $path;
+}
+sub dir {
+  my ($dir, @subdirs) = @_;
+  my %new_hash;
+  for (@subdirs) {      
+    my ($subdir_name, $subdir_structure) = @$_;
+    $new_hash{$subdir_name} = $subdir_structure;
+  }
+  return [short($dir), \%new_hash];
+}

perl/Examples/Chap1/extract-headers

@@ -0,0 +1,28 @@
+
+
+###
+### extract_headers
+###
+
+## Chapter 1 section 7
+
+@tagged_texts = walk_html($tree, sub { ['MAYBE', $_[0]] }, 
+                                 \&promote_if_h1tag);
+
+sub promote_if_h1tag {
+  my $element = shift;
+  if ($element->{_tag} eq 'h1') {
+    return ['KEEPER', join '', map {$_->[1]} @_];
+  } else {
+    return @_;
+  }
+}
+sub extract_headers {
+  my $tree = shift;
+  my @tagged_texts = walk_html($tree, sub { ['MAYBE', $_[0]] }, 
+                                      \&promote_if_h1tag);
+  my @keepers = grep { $_->[0] eq 'KEEPER' } @tagged_texts;
+  my @keeper_text = map { $_->[1] } @keepers;
+  my $header_text = join '', @keeper_text;
+  return $header_text;
+}

perl/Examples/Chap1/factorial-broken

@@ -0,0 +1,13 @@
+
+
+###
+### factorial_nonreentrant
+###
+
+## Chapter 1 section 2.1
+
+sub factorial {
+  ($n) = @_;
+  return 1 if $n == 0;
+  return factorial($n-1) * $n;
+}

perl/Examples/Chap1/find-share

@@ -0,0 +1,17 @@
+
+
+###
+### find_share.pl
+###
+
+## Chapter 1 section 8.2
+
+sub find_share {
+  my ($target, $treasures) = @_;
+  return [] if $target == 0;
+  return    if $target < 0 || @$treasures == 0;
+  my ($first, @rest) = @$treasures;
+  my $solution = find_share($target-$first, \@rest);
+  return [$first, @$solution] if $solution;
+  return         find_share($target       , \@rest);
+}

perl/Examples/Chap1/hanoi

@@ -0,0 +1,23 @@
+
+
+###
+### hanoi
+###
+
+## Chapter 1 section 3
+
+# hanoi(N, start, end, extra)
+# Solve Tower of Hanoi problem for a tower of N disks,
+# of which the largest is disk #N.  Move the entire tower from
+# peg `start' to peg `end', using peg `extra' as a work space
+  
+sub hanoi {
+  my ($n, $start, $end, $extra) = @_;
+  if ($n == 1) { 
+    print "Move disk #1 from $start to $end.\n";  # Step 1
+  } else {
+    hanoi($n-1, $start, $extra, $end);            # Step 2
+    print "Move disk #$n from $start to $end.\n"; # Step 3
+    hanoi($n-1, $extra, $end, $start);            # Step 4
+  }
+}

perl/Examples/Chap1/promote-if

@@ -0,0 +1,27 @@
+
+
+###
+### promote_if
+###
+
+## Chapter 1 section 7.1
+
+sub promote_if {
+  my $is_interesting = shift;          
+  my $element = shift;
+  if ($is_interesting->($element->{_tag}) {
+    return ['keeper', join '', map {$_->[1]} @_];
+  } else {
+    return @_;
+  }
+}
+
+
+## Chapter 1 section 7.1
+
+my @tagged_texts = walk_html($tree, 
+                             sub { ['maybe', $_[0]] }, 
+                             sub { promote_if(
+                                     sub { $_[0] eq 'h1' },
+                                     $_[0])
+                             });

perl/Examples/Chap1/total-size

@@ -0,0 +1,28 @@
+
+
+###
+### total_size
+###
+
+## Chapter 1 section 4
+
+sub total_size {
+  my ($top) = @_;
+  my $total = -s $top;
+  my $DIR;
+
+  return $total if -f $top;
+  unless (opendir $DIR, $top) {
+    warn "Couldn't open directory $top: $!; skipping.\n";
+    return $total;
+  }
+
+  my $file;
+  while ($file = readdir $DIR) {
+    next if $file eq '.' || $file eq '..';
+    $total += total_size("$top/$file");
+  }          
+  
+  closedir $DIR;
+  return $total;
+}

perl/Examples/Chap1/total-size-broken

@@ -0,0 +1,24 @@
+
+
+###
+### total_size_broken
+###
+
+## Chapter 1 section 4
+
+sub total_size {
+  my ($top) = @_;
+  my $total = -s $top;
+  return $total if -f $top;
+  unless (opendir DIR, $top) {
+    warn "Couldn't open directory $top: $!; skipping.\n";
+    return $total;
+  }
+  my $file;
+  while ($file = readdir DIR) {
+    next if $file eq '.' || $file eq '..';
+    $total += total_size("$top/$file");
+  }
+  closedir DIR;
+  return $total;
+}

perl/Examples/Chap1/untag-html

@@ -0,0 +1,19 @@
+
+
+###
+### untag_html
+###
+
+## Chapter 1 section 7
+
+sub untag_html {
+  my ($html) = @_;
+  return $html unless ref $html;   # It's a plain string
+
+  my $text = '';
+  for my $item (@{$html->{_content}}) {
+    $text .= untag_html($item);
+  }
+    
+  return $text;
+}

perl/Examples/Chap1/walk-html

@@ -0,0 +1,18 @@
+
+
+###
+### walk_html
+###
+
+## Chapter 1 section 7
+
+sub walk_html {
+  my ($html, $textfunc, $elementfunc) = @_;
+  return $textfunc->($html) unless ref $html;   # It's a plain string
+
+  my @results;
+  for my $item (@{$html->{_content}}) {
+    push @results, walk_html($item, $textfunc, $elementfunc);
+  }
+  return $elementfunc->($html, @results);
+}

perl/Examples/Chap2/AST-to-string

@@ -0,0 +1,19 @@
+
+
+###
+### AST_to_string
+###
+
+## Chapter 2 section 2
+
+sub AST_to_string {
+  my ($tree) = @_;
+  if (ref $tree) {
+    my ($op, $a1, $a2) = @$tree;
+    my ($s1, $s2) = (AST_to_string($a1),
+                     AST_to_string($a2));
+    "($s1 $op $s2)";
+  } else {
+    $tree;
+  }
+}

perl/Examples/Chap2/def-cdir-tablearg

@@ -0,0 +1,26 @@
+
+
+###
+### define_config_directive_tablearg
+###
+
+## Chapter 2 section 1.2
+
+sub define_config_directive {
+  my ($rest, $dispatch_table) = @_;
+  $rest =~ s/^\s+//;
+  my ($new_directive, $def_txt) = split /\s+/, $rest, 2;
+
+  if (exists $dispatch_table->{$new_directive}) {
+    warn "$new_directive already defined; skipping.\n";
+    return;
+  }
+
+  my $def = eval "sub { $def_txt }";
+  if (not defined $def) {
+    warn "Could not compile definition for `$new_directive': $@; skipping.\n";
+    return;       
+  }
+
+  $dispatch_table->{$new_directive} = $def;
+}

perl/Examples/Chap2/def-conf-dir

@@ -0,0 +1,26 @@
+
+
+###
+### define_config_directive
+###
+
+## Chapter 2 section 1.2
+
+sub define_config_directive {
+  my $rest = shift;
+  $rest =~ s/^\s+//;
+  my ($new_directive, $def_txt) = split /\s+/, $rest, 2;
+
+  if (exists $CONFIG_DIRECTIVE_TABLE{$new_directive}) {
+    warn "$new_directive already defined; skipping.\n";
+    return;
+  }
+
+  my $def = eval "sub { $def_txt }";
+  if (not defined $def) {
+    warn "Could not compile definition for `$new_directive': $@; skipping.\n";
+    return;       
+  }
+
+  $CONFIG_DIRECTIVE_TABLE{$new_directive} = $def;
+}

perl/Examples/Chap2/rdconfig-default

@@ -0,0 +1,23 @@
+
+
+###
+### read_config_default
+###
+
+## Chapter 2 section 1.4
+
+sub read_config {
+  my ($filename, $actions, $userparam) = @_;        
+  open my($CF), $filename or return;  # Failure
+  while (<$CF>) {
+    chomp;
+    my ($directive, $rest) = split /\s+/, $_, 2;
+    my $action = $actions->{$directive} || $actions->{_DEFAULT_};
+    if ($action) {
+      $action->($directive, $rest, $actions, $userparam);
+    } else {
+      die "Unrecognized directive $directive on line $. of $filename; aborting";
+    }
+  }
+  return 1;  # Success
+}

perl/Examples/Chap2/rdconfig-tablearg

@@ -0,0 +1,22 @@
+
+
+###
+### read_config_tablearg
+###
+
+## Chapter 2 section 1.2
+
+sub read_config {
+  my ($filename, $actions) = @_;        
+  open my($CF), $filename or return;  # Failure
+  while (<$CF>) {
+    chomp;
+    my ($directive, $rest) = split /\s+/, $_, 2;
+    if (exists $actions->{$directive}) {
+       $actions->{$directive}->($rest, $actions);
+    } else {
+      die "Unrecognized directive $directive on line $. of $filename; aborting";
+    }
+  }
+  return 1;  # Success
+}

perl/Examples/Chap2/rdconfig-tabular

@@ -0,0 +1,22 @@
+
+
+###
+### read_config_tabular
+###
+
+## Chapter 2 section 1.1
+
+sub read_config {
+  my ($filename, $actions) = @_;        
+  open my($CF), $filename or return;  # Failure
+  while (<$CF>) {
+    chomp;
+    my ($directive, $rest) = split /\s+/, $_, 2;
+    if (exists $actions->{$directive}) {
+      $actions->{$directive}->($rest);
+    } else {
+      die "Unrecognized directive $directive on line $. of $filename; aborting";
+    }
+  }
+  return 1;  # Success
+}

perl/Examples/Chap2/rdconfig-tagarg

@@ -0,0 +1,21 @@
+
+
+###
+### read_config_tagarg
+###
+
+## Chapter 2 section 1.3
+
+sub read_config {
+  my ($filename, $actions, $userparam) = @_;        
+  open my($CF), $filename or return;  # Failure
+  while (<$CF>) {
+    my ($directive, $rest) = split /\s+/, $_, 2;
+    if (exists $actions->{$directive}) {
+      $actions->{$directive}->($directive, $rest, $actions, $userparam);
+    } else {
+      die "Unrecognized directive $directive on line $. of $filename; aborting";
+    }
+  }
+  return 1;  # Success
+}

perl/Examples/Chap2/rdconfig-uparam

@@ -0,0 +1,21 @@
+
+
+###
+### read_config_userparam
+###
+
+## Chapter 2 section 1.3
+
+sub read_config {
+  my ($filename, $actions, $user_param) = @_;        
+  open my($CF), $filename or return;  # Failure
+  while (<$CF>) {
+    my ($directive, $rest) = split /\s+/, $_, 2;
+    if (exists $actions->{$directive}) {
+        $actions->{$directive}->($rest, $userparam, $actions);
+    } else {
+      die "Unrecognized directive $directive on line $. of $filename; aborting";
+    }
+  }
+  return 1;  # Success
+}

perl/Examples/Chap2/rpn-ifelse

@@ -0,0 +1,34 @@
+
+
+###
+### rpn_ifelse
+###
+
+## Chapter 2 section 2
+
+my $result = evaluate($ARGV[0]);
+print "Result: $result\n";
+
+sub evaluate {
+  my @stack;
+  my ($expr) = @_;
+  my @tokens = split /\s+/, $expr;
+  for my $token (@tokens) {
+    if ($token =~ /^\d+$/) {   # It's a number
+      push @stack, $token;
+    } elsif ($token eq '+') {
+       push @stack, pop(@stack) + pop(@stack);
+    } elsif ($token eq '-') {
+       my $s = pop(@stack);
+       push @stack, pop(@stack) - $s
+    } elsif ($token eq '*') {
+       push @stack, pop(@stack) * pop(@stack);
+    } elsif ($token eq '/') {
+       my $s = pop(@stack);
+       push @stack, pop(@stack) / $s
+    } else {
+      die "Unrecognized token `$token'; aborting";
+    }
+   }
+  return pop(@stack);
+}

perl/Examples/Chap2/rpn-table

@@ -0,0 +1,37 @@
+
+
+###
+### rpn_table
+###
+
+## Chapter 2 section 2
+
+my @stack;
+my $actions = {
+  '+' => sub { push @stack, pop(@stack) + pop(@stack) },
+  '*' => sub { push @stack, pop(@stack) * pop(@stack) },
+  '-' => sub { my $s = pop(@stack); push @stack, pop(@stack) - $s },
+  '/' => sub { my $s = pop(@stack); push @stack, pop(@stack) / $s },
+  'NUMBER' => sub { push @stack, $_[0] },
+  '_DEFAULT_' => sub { die "Unrecognized token `$_[0]'; aborting" }
+};
+
+my $result = evaluate($ARGV[0], $actions);
+print "Result: $result\n";
+
+sub evaluate {
+  my ($expr, $actions) = @_;
+  my @tokens = split /\s+/, $expr;
+  for my $token (@tokens) {
+    my $type;
+    if ($token =~ /^\d+$/) {   # It's a number
+      $type = 'NUMBER'; 
+    }
+  
+    my $action = $actions->{$type} 
+              || $actions->{$token} 
+              || $actions->{_DEFAULT_};
+    $action->($token, $type, $actions);
+  }
+  return pop(@stack);
+}

perl/Examples/Chap2/walk-html-disp

@@ -0,0 +1,22 @@
+
+
+###
+### walk_html_dispatch
+###
+
+## Chapter 2 section 2.1
+
+sub walk_html {
+  my ($html, $textfunc, $elementfunc_table) = @_;
+  return $textfunc->($html) unless ref $html;   # It's a plain string
+
+  my ($item, @results);
+  for $item (@{$html->{_content}}) {
+    push @results, walk_html($item, $textfunc, $elementfunc_table);
+  }
+  my $tag = $html->{_tag};
+  my $elementfunc =  $elementfunc_table->{$tag} 
+               || $elementfunc_table->{_DEFAULT_}
+               || die "No function defined for tag `$tag'";
+  return $elementfunc->($html, @results);
+}

perl/Examples/Chap2/walk-html-uparam

@@ -0,0 +1,18 @@
+
+
+###
+### walk_html_userparam
+###
+
+## Chapter 2 section 2.1
+
+sub walk_html {
+  my ($html, $textfunc, $elementfunc, $userparam) = @_;
+  return $textfunc->($html, $userparam) unless ref $html;
+
+  my ($item, @results);
+  for $item (@{$html->{_content}}) {
+    push @results, walk_html($item, $textfunc, $elementfunc, $userparam);
+  }
+  return $elementfunc->($html, $userparam, @results);
+}

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};
+  }
+}

perl/Examples/Chap4/FlatDB.pm

@@ -0,0 +1,82 @@
+
+
+###
+### FlatDB.pm
+###
+
+## Chapter 4 section 3.4
+
+package FlatDB;
+my $FIELDSEP = qr/:/;
+
+sub new {
+  my $class = shift;
+  my $file = shift;
+  open my $fh, "< $file" or return;
+  chomp(my $schema = <$fh>);
+  my @field = split $FIELDSEP, $schema;
+  my %fieldnum = map { uc $field[$_] => $_ } (0..$#field);
+  bless { FH => $fh, FIELDS => \@field, FIELDNUM => \%fieldnum,
+          FIELDSEP => $FIELDSEP }   => $class;
+}
+
+
+## Chapter 4 section 3.4.1
+
+# usage: $dbh->query(fieldname, value)
+# returns all records for which (fieldname) matches (value)
+use Fcntl ':seek';
+sub query {
+  my $self = shift;
+  my ($field, $value) = @_;
+  my $fieldnum = $self->{FIELDNUM}{uc $field};
+  return unless defined $fieldnum;
+  my $fh = $self->{FH};
+  seek $fh, 0, SEEK_SET;
+  <$fh>;                # discard header line
+  my $position = tell $fh;
+
+  return Iterator {
+    local $_;
+    seek $fh, $position, SEEK_SET;
+    while (<$fh>) {
+      $position = tell $fh;         
+      my @fields = split $self->{FIELDSEP};
+      my $fieldval = $fields[$fieldnum];
+      return $_ if $fieldval eq $value;
+    }
+    return;
+  };
+}
+
+
+## Chapter 4 section 3.4.1
+
+# callbackquery with bug fix
+use Fcntl ':seek';
+sub callbackquery {
+  my $self = shift;
+  my $is_interesting = shift;
+  my $fh = $self->{FH};
+  seek $fh, 0, SEEK_SET;
+  <$fh>;                # discard header line
+  my $position = tell $fh;
+
+  return Iterator {
+    local $_;
+    seek $fh, $position, SEEK_SET;
+    while (<$fh>) {
+      $position = tell $fh;         
+      my %F;
+      my @fieldnames = @{$self->{FIELDS}};
+      my @fields = split $self->{FIELDSEP};
+      for (0 .. $#fieldnames) {
+        $F{$fieldnames[$_]} = $fields[$_];
+      }
+      return [$position, $_] if $is_interesting->(%F);
+    }
+    return;
+  };
+}
+
+1;

perl/Examples/Chap4/Iterator_Utils.pm

@@ -0,0 +1,105 @@
+
+
+###
+### Iterator_Utils.pm
+###
+
+## Chapter 4 section 2.1
+
+package Iterator_Utils;
+use base Exporter;
+@EXPORT_OK = qw(NEXTVAL Iterator 
+                append imap igrep
+                iterate_function filehandle_iterator list_iterator);
+%EXPORT_TAGS = ('all' => \@EXPORT_OK);
+
+sub NEXTVAL { $_[0]->() }
+
+
+## Chapter 4 section 2.1.1
+
+sub Iterator (&) { return $_[0] }
+
+
+## Chapter 4 section 3.1
+
+sub iterate_function {
+  my $n = 0;
+  my $f = shift;
+  return Iterator {  
+    return $f->($n++);
+  };
+}
+
+
+## Chapter 4 section 3.3
+
+sub filehandle_iterator {
+  my $fh = shift;
+  return Iterator { <$fh> };
+}
+1;
+
+
+## Chapter 4 section 4.1
+
+sub imap (&$) {
+  my ($transform, $it) = @_;
+  return Iterator {
+    local $_ = NEXTVAL($it);
+    return unless defined $_;
+    return $transform->();
+  }
+}
+
+
+## Chapter 4 section 4.2
+
+sub igrep (&$) {
+  my ($is_interesting, $it) = @_;
+  return Iterator {
+    local $_;
+    while (defined ($_ = NEXTVAL($it))) {
+      return $_ if $is_interesting->();
+    }
+    return;
+  }
+}
+
+
+## Chapter 4 section 4.3
+
+sub list_iterator {
+  my @items = @_;
+  return Iterator {
+    return shift @items;
+  };
+}
+
+
+## Chapter 4 section 4.4
+
+sub append {
+  my @its = @_;
+  return Iterator {
+    while (@its) {
+      my $val = NEXTVAL($its[0]);
+      return $val if defined $val;
+      shift @its;  # Discard exhausted iterator
+    }
+    return;
+  };
+}
+
+
+## Chapter 4 section 7.2
+
+sub igrep_l (&$) {
+  my ($is_interesting, $it) = @_;
+  return Iterator {
+    while (my @vals = NEXTVAL($it)) {
+      return @vals if $is_interesting->(@vals);
+    }
+    return;
+  }
+}

perl/Examples/Chap4/db.txt

@@ -0,0 +1,7 @@
+LASTNAME:FIRSTNAME:CITY:STATE:OWES
+Adler:David:New York:NY:157.00
+Ashton:Elaine:Boston:MA:0.00
+Dominus:Mark:Philadelphia:PA:0.00
+Orwant:Jon:Cambridge:MA:26.30
+Schwern:Michael:New York:NY:149658.23
+Wall:Larry:Mountain View:CA:-372.14

perl/Examples/Chap4/dir-walk-iterator

@@ -0,0 +1,25 @@
+
+
+###
+### dir_walk-iterator
+###
+
+## Chapter 4 section 2.2
+
+# iterator version
+sub dir_walk {          
+  my @queue = shift;
+  return Iterator {
+    if (@queue) {
+      my $file = shift @queue;
+      if (-d $file) { 
+        opendir my $dh, $file or next;
+        my @newfiles = grep {$_ ne "." && $_ ne ".."} readdir $dh;
+        push @queue, map "$file/$_", @newfiles;
+      }
+      return $file;
+    } else {
+      return;
+    }
+  };
+}

perl/Examples/Chap4/make-genes-1

@@ -0,0 +1,35 @@
+
+
+###
+### make_genes
+###
+
+## Chapter 4 section 3.2
+
+sub make_genes {
+  my $pat = shift;
+  my @tokens = split /[()]/, $pat;
+  for (my $i = 1; $i < @tokens; $i += 2) {
+    $tokens[$i] = [0, split(//, $tokens[$i])];
+  }
+  my $FINISHED = 0;
+  return Iterator {
+    return if $FINISHED;
+    my $finished_incrementing = 0;
+    my $result = "";
+    for my $token (@tokens) {
+      if (ref $token eq "") {    # plain string
+        $result .= $token;
+      } else {                   # wildcard
+        my ($n, @c) = @$token;
+        $result .= $c[$n];
+        unless ($finished_incrementing) {
+          if ($n == $#c) { $token->[0] = 0 }
+          else { $token->[0]++; $finished_incrementing = 1 }
+        }                
+      }
+    }
+    $FINISHED = 1 unless $finished_incrementing;
+    return $result;
+  }
+}

perl/Examples/Chap4/make-genes-2

@@ -0,0 +1,19 @@
+
+
+###
+### make_genes-2
+###
+
+## Chapter 4 section 3.2
+
+%n_expand = qw(N ACGT
+               B CGT    D AGT    H ACT    V ACG
+               K GT   M AC   R AG   S CG   W AT   Y CT);
+
+sub make_dna_sequences {
+  my $pat = shift;
+  for my $abbrev (keys %n_expand) {
+    $pat =~ s/$abbrev/($n_expand{$abbrev})/g;
+  }
+  return make_genes($pat);
+}

perl/Examples/Chap4/permute

@@ -0,0 +1,46 @@
+
+
+###
+### permute
+###
+
+## Chapter 4 section 3.1
+
+sub permute {
+  my @items = @_;
+  my @pattern = (0) x @items;
+  return Iterator {
+    return unless @pattern;
+    my @result = pattern_to_permutation(\@pattern, \@items);
+    @pattern = increment_pattern(@pattern);
+    return @result;
+  };
+}
+sub pattern_to_permutation {
+  my $pattern = shift;
+  my @items = @{shift()};
+  my @r;
+  for (@$pattern) {
+    push @r, splice(@items, $_, 1);
+  }
+  @r;
+}
+
+
+## Chapter 4 section 3.1
+
+sub increment_pattern {
+  my @odometer = @_;
+  my $wheel = $#odometer;    # start at rightmost wheel
+
+  until ($odometer[$wheel] < $#odometer-$wheel  ||  $wheel < 0) {
+    $odometer[$wheel] = 0;  
+    $wheel--;  # next wheel to the left
+  }
+  if ($wheel < 0) {
+    return;   # fell off the left end; no more sequences
+  } else {
+    $odometer[$wheel]++;  # this wheel now turns one notch
+    return @odometer;
+  }
+}

perl/Examples/Chap4/permute-flop

@@ -0,0 +1,29 @@
+
+
+###
+### permute-flop
+###
+
+## Chapter 4 section 3.1
+
+sub permute {
+  my @items = @_;
+  my $n = 0;
+  return Iterator {
+    $n++, return @items if $n==0;
+    my $i;
+    my $p = $n;
+    for ($i=1; $i<=@items && $p%$i==0; $i++) {
+      $p /= $i;
+    }
+    my $d = $p % $i;
+    my $j = @items - $i;
+    return if $j < 0;
+
+    @items[$j+1..$#items] = reverse @items[$j+1..$#items];
+    @items[$j,$j+$d] = @items[$j+$d,$j];
+
+    $n++;
+    return @items;
+  };
+}

perl/Examples/Chap4/permute-n

@@ -0,0 +1,27 @@
+
+
+###
+### permute-n
+###
+
+## Chapter 4 section 3.1
+
+sub n_to_pat {
+  my @odometer;
+  my ($n, $length) = @_;
+  for my $i (1 .. $length) {
+    unshift @odometer, $n % $i;
+    $n = int($n/$i);
+  }
+  return $n ? () : @odometer;
+}
+sub permute {
+  my @items = @_;
+  my $n = 0;
+  return Iterator {
+    my @pattern = n_to_pat($n, scalar(@items));
+    my @result = pattern_to_permutation(\@pattern, \@items);
+    $n++;
+    return @result;
+  };
+}

perl/Examples/Chap4/rng-iterator.pl

@@ -0,0 +1,15 @@
+
+
+###
+### rng-iterator.pl
+###
+
+## Chapter 4 section 3.6
+
+sub make_rand {
+  my $seed = shift || (time & 0x7fff);
+  return Iterator {
+    $seed = (29*$seed+11111) & 0x7fff;
+    return $seed;
+  }
+}

perl/Examples/Chap4/upto

@@ -0,0 +1,14 @@
+
+
+###
+### upto
+###
+
+## Chapter 4 section 2.1
+
+sub upto {
+  my ($m, $n) = @_;
+  return sub {
+    return $m <= $n ? $m++ : undef;
+  };
+}

perl/Examples/Chap5/binary-1

@@ -0,0 +1,17 @@
+
+
+###
+### binary1
+###
+
+## Chapter 5 section 4.2
+
+sub binary {
+  my ($n, $RETVAL) = @_;
+  $RETVAL = "" unless defined $RETVAL;
+  my $k = int($n/2);
+  my $b = $n % 2;
+  $RETVAL = "$b$RETVAL";
+  return $RETVAL if $n == 0 || $n == 1;
+  binary($k, $RETVAL);
+}

perl/Examples/Chap5/binary-2

@@ -0,0 +1,19 @@
+
+
+###
+### binary2
+###
+
+## Chapter 5 section 4.2
+
+sub binary {
+  my ($n, $RETVAL) = @_;
+  $RETVAL = "";
+  while (1) {
+    my $k = int($n/2);
+    my $b = $n % 2;
+    $RETVAL = "$b$RETVAL";
+    return $RETVAL if $n == 0 || $n == 1;
+    $n = $k;
+  }
+}

perl/Examples/Chap5/binary-3

@@ -0,0 +1,18 @@
+
+
+###
+### binary3
+###
+
+## Chapter 5 section 4.2
+
+sub binary {
+  my ($n, $RETVAL) = @_;
+  $RETVAL = "";
+  while (1) {
+    my $b = $n % 2;
+    $RETVAL = "$b$RETVAL";
+    return $RETVAL if $n == 0 || $n == 1;
+    $n = int($n/2);
+  }
+}

perl/Examples/Chap5/factorial-0

@@ -0,0 +1,13 @@
+
+
+###
+### factorial0
+###
+
+## Chapter 5 section 4.2
+
+sub factorial {
+  my ($n) = @_;
+  return 1 if $n == 0;
+  return factorial($n-1) * $n;
+}

perl/Examples/Chap5/factorial-1

@@ -0,0 +1,14 @@
+
+
+###
+### factorial1
+###
+
+## Chapter 5 section 4.2
+
+sub factorial {
+  my ($n, $product) = @_;
+  $product = 1 unless defined $product;
+  return $product if $n == 0;
+  return factorial($n-1, $n * $product);
+}

perl/Examples/Chap5/factorial-2

@@ -0,0 +1,17 @@
+
+
+###
+### factorial2
+###
+
+## Chapter 5 section 4.2
+
+sub factorial {
+  my ($n) = @_;
+  my $product = 1;
+  until ($n == 0) {
+    $product *= $n;
+    $n--;
+  }
+  return $product;
+}

perl/Examples/Chap5/fib-0

@@ -0,0 +1,13 @@
+
+
+###
+### fib0
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  if ($n < 2) { return $n }
+  fib($n-2) + fib($n-1);
+}

perl/Examples/Chap5/fib-1

@@ -0,0 +1,18 @@
+
+
+###
+### fib1
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  if ($n < 2) {
+    return $n;
+  } else {
+    my $s1 = fib($n-2);
+    my $s2 = fib($n-1);
+    return $s1 + $s2;
+  }
+}

perl/Examples/Chap5/fib-10

@@ -0,0 +1,35 @@
+
+
+###
+### fib10
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push (@STACK, [ $BRANCH, 0, $n ]), $n -= 2 while $n >= 2;
+        $return = $n;
+      } elsif ($BRANCH == 1) {
+        push @STACK, [ $BRANCH, $return, $n ];
+        $n -= 1;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $return += $s1;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $n) = @{pop @STACK};
+    $BRANCH++;
+  }
+}

perl/Examples/Chap5/fib-11

@@ -0,0 +1,35 @@
+
+
+###
+### fib11
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push (@STACK, [ $BRANCH, 0, $n ]), $n -= 1 while $n >= 2;
+        $return = $n;
+      } elsif ($BRANCH == 1) {
+        push @STACK, [ $BRANCH, $return, $n ];
+        $n -= 2;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $return += $s1;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $n) = @{pop @STACK};
+    $BRANCH++;
+  }
+}

perl/Examples/Chap5/fib-12

@@ -0,0 +1,34 @@
+
+
+###
+### fib12
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push (@STACK, [ 1, 0, $n ]), $n -= 1 while $n >= 2;
+        $return = $n;
+      } elsif ($BRANCH == 1) {
+        push @STACK, [ 2, $return, $n ];
+        $n -= 2;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $return += $s1;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $n) = @{pop @STACK};
+  }
+}

perl/Examples/Chap5/fib-2

@@ -0,0 +1,20 @@
+
+
+###
+### fib2
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  while (1) {
+    if ($n < 2) {
+      return $n;
+    } else {
+      my $s1 = fib($n-2);
+      my $s2 = fib($n-1);
+      return $s1 + $s2;
+    }
+  }
+}

perl/Examples/Chap5/fib-3

@@ -0,0 +1,27 @@
+
+
+###
+### fib3
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  while (1) {
+    if ($n < 2) {
+      return $n;
+    } else {
+      if ($BRANCH == 0) {
+        $return = fib($n-2);
+      } elsif ($BRANCH == 1) {
+        $s1 = $return;
+        $return = fib($n-1);
+      } elsif ($BRANCH == 2) {
+        $s2 = $return;
+        $return = $s1 + $s2;
+      }
+    }
+  }
+}

perl/Examples/Chap5/fib-4

@@ -0,0 +1,28 @@
+
+
+###
+### fib4
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  my $BRANCH = 0;
+  while (1) {
+    if ($n < 2) {
+      return $n;
+    } else {
+      if ($BRANCH == 0) {
+        $return = fib($n-2);
+      } elsif ($BRANCH == 1) {
+        $s1 = $return;
+        $return = fib($n-1);
+      } elsif ($BRANCH == 2) {
+        $s2 = $return;
+        $return = $s1 + $s2;
+      }
+    }
+  }
+}

perl/Examples/Chap5/fib-5

@@ -0,0 +1,27 @@
+
+
+###
+### fib5
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  my $BRANCH = 0;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        $return = fib($n-2);
+      } elsif ($BRANCH == 1) {
+        $s1 = $return;
+        $return = fib($n-1);
+      } elsif ($BRANCH == 2) {
+        $return = $s1 + $s2;
+      }
+    }
+  }
+}

perl/Examples/Chap5/fib-6

@@ -0,0 +1,35 @@
+
+
+###
+### fib6
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push @STACK, [ $BRANCH, $s1, $s2, $n ];
+        $n -= 2;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 1) {
+        $s1 = $return;
+        push @STACK, [ $BRANCH, $s1, $s2, $n ];
+        $n -= 1;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $s2 = $return;
+        $return = $s1 + $s2;
+      }
+    }
+  }
+}

perl/Examples/Chap5/fib-7

@@ -0,0 +1,39 @@
+
+
+###
+### fib7
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push @STACK, [ $BRANCH, $s1, $s2, $n ];
+        $n -= 2;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 1) {
+        $s1 = $return;
+        push @STACK, [ $BRANCH, $s1, $s2, $n ];
+        $n -= 1;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $s2 = $return;
+        $return = $s1 + $s2;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $s2, $n) = @{pop @STACK};
+    $BRANCH++;
+  }
+}

perl/Examples/Chap5/fib-8

@@ -0,0 +1,37 @@
+
+
+###
+### fib8
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $s2, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push @STACK, [ $BRANCH, 0, $s2, $n ];
+        $n -= 2;
+        next;
+      } elsif ($BRANCH == 1) {
+        push @STACK, [ $BRANCH, $return, $s2, $n ];
+        $n -= 1;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $s2 = $return;
+        $return = $s1 + $s2;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $s2, $n) = @{pop @STACK};
+    $BRANCH++;
+  }
+}

perl/Examples/Chap5/fib-9

@@ -0,0 +1,36 @@
+
+
+###
+### fib9
+###
+
+## Chapter 5 section 4.3.1
+
+sub fib {
+  my $n = shift;
+  my ($s1, $return);
+  my $BRANCH = 0;
+  my @STACK;
+  while (1) {
+    if ($n < 2) {
+      $return = $n;
+    } else {
+      if ($BRANCH == 0) {
+        push @STACK, [ $BRANCH, 0, $n ];
+        $n -= 2;
+        next;
+      } elsif ($BRANCH == 1) {
+        push @STACK, [ $BRANCH, $return, $n ];
+        $n -= 1;
+        $BRANCH = 0;
+        next;
+      } elsif ($BRANCH == 2) {
+        $return += $s1;
+      }
+    }
+
+    return $return unless @STACK;
+    ($BRANCH, $s1, $n) = @{pop @STACK};
+    $BRANCH++;
+  }
+}

perl/Examples/Chap5/make-dfs

@@ -0,0 +1,24 @@
+
+
+###
+### make-dfs-search
+###
+
+## Chapter 5 section 3
+
+use Iterator_Utils 'Iterator';
+
+sub make_dfs_search {
+  my ($root, $children, $is_interesting) = @_;
+  my @agenda = $root;
+  return Iterator {
+    while (@agenda) {
+      my $node = pop @agenda;
+      push @agenda, $children->($node);
+      return $node if !$is_interesting || $is_interesting->($node);
+    }
+    return;
+  };
+}       
+
+1;

perl/Examples/Chap5/make-dfs-simple

@@ -0,0 +1,20 @@
+
+
+###
+### make-dfs-search-simple
+###
+
+## Chapter 5 section 3
+
+use Iterator_Utils 'Iterator';
+
+sub make_dfs_search {
+  my ($root, $children) = @_;
+  my @agenda = $root;
+  return Iterator {
+    return unless @agenda;
+    my $node = pop @agenda;
+    push @agenda, $children->($node);
+    return $node;
+  };
+}       

perl/Examples/Chap5/make-dfs-value

@@ -0,0 +1,29 @@
+
+
+###
+### make-value-search
+###
+
+## Chapter 5 section 3
+
+sub make_dfs_value_search {
+  my ($root, $children, $is_interesting, $evaluate) = @_;
+  $evaluate = memoize($evaluate);
+  my @agenda = $root;
+  return Iterator {
+    while (@agenda) {
+      my $best_node_so_far = 0;
+      my $best_node_value = $evaluate->($agenda[0]);
+      for (0 .. $#agenda) {
+        my $val = $evaluate->($agenda[$_]);
+        next unless $val > $best_node_value;
+        $best_node_value = $val;
+        $best_node_so_far = $_;
+      }
+      my $node = splice @agenda, $best_node_so_far, 1;
+      push @agenda, $children->($node);
+      return $node if !$is_interesting || $is_interesting->($node);
+    }
+    return;
+  };
+}       

perl/Examples/Chap5/make-part-dfs-1

@@ -0,0 +1,19 @@
+
+
+###
+### make_partition_dfs
+###
+
+## Chapter 5 section 3
+
+sub make_partition {
+  my $n = shift;
+  my $root = [$n];
+  my $children = sub {
+    my ($largest, @rest) = @{shift()};
+    my $min = $rest[0] || 1;
+    my $max  = int($largest/2);
+    map [$largest-$_, $_, @rest], ($min .. $max);
+  };
+  make_dfs_search($root, $children);
+}

perl/Examples/Chap5/make-part-dfs-2

@@ -0,0 +1,24 @@
+
+
+###
+### make_partition_dfs_search
+###
+
+## Chapter 5 section 3
+
+require 'make-dfs-search';
+
+sub make_partition {
+  my $n = shift;
+  my $root = [$n, 1, []];
+  my $children = sub {
+    my ($n, $min, $parts) = @{shift()};
+    map [$n-$_, $_, [@$parts, $_]], ($min .. $n);
+  };
+  my $is_complete = sub {
+    my ($n) = @{shift()};
+    $n == 0;
+  };
+   imap { $_->[2] }
+    make_dfs_search($root, $children, $is_complete);
+}

perl/Examples/Chap5/make-part-sorted

@@ -0,0 +1,24 @@
+
+
+###
+### make_partition_partitions
+###
+
+## Chapter 5 section 2
+
+sub make_partition {
+  my $n = shift;
+  my @agenda = [$n];
+  return Iterator {
+    return unless @agenda;
+    my $item = pop @agenda;
+    my ($largest, @rest) = @$item;
+    my $min = $rest[0] || 1;
+    my $max  = int($largest/2);
+    for ($min .. $max) {
+      push @agenda, [$largest-$_, $_, @rest];
+    } 
+    @agenda = sort partitions @agenda;
+    return $item;
+  };
+}

perl/Examples/Chap5/make-partition-1

@@ -0,0 +1,25 @@
+
+
+###
+### make_partition
+###
+
+## Chapter 5 section 2
+
+sub make_partition {
+  my $n = shift;
+  my @agenda = [$n];
+  return Iterator {
+    while (@agenda) {
+      my $item = pop @agenda;
+      my ($largest, @rest) = @$item;
+      my $min = $rest[0] || 1;
+      my $max  = int($largest/2);
+      for ($min .. $max) {
+        push @agenda, [$largest-$_, $_, @rest];
+      }
+      return $item;
+    }
+    return;
+  };
+}

perl/Examples/Chap5/make-partition-2

@@ -0,0 +1,23 @@
+
+
+###
+### make_partition_cleaner
+###
+
+## Chapter 5 section 2
+
+sub make_partition {
+  my $n = shift;
+  my @agenda = [$n];
+  return Iterator {
+    return unless @agenda;
+    my $item = pop @agenda;
+    my ($largest, @rest) = @$item;
+    my $min = $rest[0] || 1;
+    my $max  = int($largest/2);
+    for ($min .. $max) {
+      push @agenda, [$largest-$_, $_, @rest];
+    }
+    return $item;
+  };
+}

perl/Examples/Chap5/partition

@@ -0,0 +1,17 @@
+
+
+###
+### partition
+###
+
+## Chapter 5 section 2
+
+sub partition {
+  print "@_\n";
+  my ($largest, @rest) = @_;
+  my $min = $rest[0] || 1;
+  my $max  = int($largest/2);
+  for ($min .. $max) {
+    partition($largest-$_, $_, @rest);
+  }
+}

perl/Examples/Chap5/partition-all

@@ -0,0 +1,18 @@
+
+
+###
+### partition-all
+###
+
+## Chapter 5 section 1.1
+
+sub partition {
+  my ($target, $treasures) = @_;
+  return [] if $target == 0;
+  return () if $target < 0 || @$treasures == 0;
+
+  my ($first, @rest) = @$treasures;
+  my @solutions = partition($target-$first, \@rest);
+  return ((map {[$first, @$_]} @solutions), 
+          partition($target, \@rest));
+}

perl/Examples/Chap5/partition-it

@@ -0,0 +1,24 @@
+
+
+###
+### partition-it
+###
+
+## Chapter 5 section 1.1
+
+sub make_partitioner {
+  my ($n, $treasures) = @_;
+  my @todo = [$n, $treasures, []];
+  sub { 
+    while (@todo) {
+      my $cur = pop @todo;
+      my ($target, $pool, $share) = @$cur;
+      if ($target == 0) { return $share }
+      next if $target < 0 || @$pool == 0;
+      my ($first, @rest) = @$pool;        
+      push @todo, [$target-$first, \@rest, [@$share, $first]],
+                  [$target       , \@rest,   $share         ];
+    }
+    return undef;
+  } # end of anonymous iterator function       
+} # end of make_partitioner

perl/Examples/Chap5/partition-iterator-2

@@ -0,0 +1,31 @@
+
+
+###
+### partition-iterator-clumsy
+###
+
+## Chapter 5 section 2
+
+sub make_partition {
+  my $n = shift;
+  my @agenda = ([$n,            # $largest
+                 [],            # \@rest
+                 1,             # $min
+                 int($n/2),     # $max
+                ]);
+  return Iterator {
+    while (@agenda) {
+      my $item = pop @agenda;
+      my ($largest, $rest, $min, $max) = @$item;
+      for ($min .. $max) {
+        push @agenda, [$largest - $_,          # $largest
+                       [$_, @$rest],           # \@rest
+                       $_,                     # $min
+                       int(($largest - $_)/2), # $max
+                      ];
+      }
+      return [$largest, @$rest];
+    }
+    return;
+  };
+}

perl/Examples/Chap5/partition-repeats

@@ -0,0 +1,15 @@
+
+
+###
+### partition-repeats
+###
+
+## Chapter 5 section 2
+
+sub partition {
+  print "@_\n";
+  my ($n, @parts) = @_;
+  for (1 .. $n-1) {
+    partition($n-$_, $_, @parts);
+  }
+}

perl/Examples/Chap5/partitions

@@ -0,0 +1,15 @@
+
+
+###
+### partitions
+###
+
+## Chapter 5 section 2
+
+# Compare two partitions for preferred order
+sub partitions {
+  for my $i (0 .. $#$a) {
+    my $cmp = $b->[$i] <=> $a->[$i];
+    return $cmp if $cmp;
+  }
+}

perl/Examples/Chap5/powerset-0

@@ -0,0 +1,47 @@
+
+
+###
+### powerset_recurse0
+###
+
+## Chapter 5 section 4.1.1
+
+sub powerset_recurse ($;@) {
+    my ( $set, $powerset, $keys, $values, $n, $i ) = @_;
+
+    if ( @_ == 1 ) { # Initialize.
+        my $null   = { };
+        $powerset  = { $null, $null };
+        $keys      = [ keys   %{ $set } ];
+        $values    = [ values %{ $set } ];
+        $nmembers  = keys %{ $set };    # This many rounds.
+        $i         = 0;                 # The current round.
+    }
+
+    # Ready?
+    return $powerset if $i == $nmembers;
+
+    # Remap.
+
+    my @powerkeys   = keys   %{ $powerset };
+    my @powervalues = values %{ $powerset };
+    my $powern      = @powerkeys;
+    my $j;
+
+    for ( $j = 0; $j < $powern; $j++ ) {
+        my %subset = ( );
+
+        # Copy the old set to the subset.
+        @subset{keys   %{ $powerset->{ $powerkeys  [ $j ] } }} =
+                values %{ $powerset->{ $powervalues[ $j ] } };
+
+        # Add the new member to the subset.
+        $subset{$keys->[ $i ]} = $values->[ $i ];
+
+        # Add the new subset to the powerset.
+        $powerset->{ \%subset } = \%subset;
+    }
+
+    # Recurse.
+    powerset_recurse( $set, $powerset, $keys, $values, $nmembers, $i+1 );
+}

perl/Examples/Chap5/powerset-1

@@ -0,0 +1,46 @@
+
+
+###
+### powerset_recurse1
+###
+
+## Chapter 5 section 4.1.1
+
+sub powerset_recurse ($) {
+    my ( $set ) = @_;
+    my $null = { };
+    my $powerset  = { $null, $null };
+    my $keys      = [ keys   %{ $set } ];
+    my $values    = [ values %{ $set } ];
+    my $nmembers  = keys %{ $set };    # This many rounds.
+    my $i         = 0;                 # The current round.
+
+    until ($i == $nmembers) {
+
+      # Remap.
+
+      my @powerkeys   = keys   %{ $powerset };
+      my @powervalues = values %{ $powerset };
+      my $powern      = @powerkeys;
+      my $j;
+
+      for ( $j = 0; $j < $powern; $j++ ) {
+          my %subset = ( );
+
+          # Copy the old set to the subset.
+          @subset{keys   %{ $powerset->{ $powerkeys  [ $j ] } }} =
+                  values %{ $powerset->{ $powervalues[ $j ] } };
+
+          # Add the new member to the subset.
+          $subset{$keys->[ $i ]} = $values->[ $i ];
+
+          # Add the new subset to the powerset.
+          $powerset->{ \%subset } = \%subset;
+      }
+
+      $i++;        
+
+    }
+
+    return $powerset;
+}

perl/Examples/Chap5/powerset-2

@@ -0,0 +1,42 @@
+
+
+###
+### powerset_recurse2
+###
+
+## Chapter 5 section 4.1.1
+
+sub powerset_recurse ($) {
+    my ( $set ) = @_;
+    my $null = { };
+    my $powerset  = { $null, $null };
+    my $keys      = [ keys   %{ $set } ];
+    my $values    = [ values %{ $set } ];
+    my $nmembers  = keys %{ $set };    # This many rounds.
+
+    for my $i (0 .. $nmembers-1) {
+
+      # Remap.
+
+      my @powerkeys   = keys   %{ $powerset };
+      my @powervalues = values %{ $powerset };
+      my $powern      = @powerkeys;
+      my $j;
+
+      for ( $j = 0; $j < $powern; $j++ ) {
+          my %subset = ( );
+
+          # Copy the old set to the subset.
+          @subset{keys   %{ $powerset->{ $powerkeys  [ $j ] } }} =
+                  values %{ $powerset->{ $powervalues[ $j ] } };
+
+          # Add the new member to the subset.
+          $subset{$keys->[ $i ]} = $values->[ $i ];
+
+          # Add the new subset to the powerset.
+          $powerset->{ \%subset } = \%subset;
+      }
+    }
+
+    return $powerset;
+}

perl/Examples/Chap5/powerset-3

@@ -0,0 +1,39 @@
+
+
+###
+### powerset_recurse3
+###
+
+## Chapter 5 section 4.1.1
+
+sub powerset_recurse ($) {
+    my ( $set ) = @_;
+    my $null = { };
+    my $powerset  = { $null, $null };
+
+    while (my ($key, $value) = each %$set) {
+
+      # Remap.
+
+      my @powerkeys   = keys   %{ $powerset };
+      my @powervalues = values %{ $powerset };
+      my $powern      = @powerkeys;
+      my $j;
+
+      for ( $j = 0; $j < $powern; $j++ ) {
+          my %subset = ( );
+
+          # Copy the old set to the subset.
+          @subset{keys   %{ $powerset->{ $powerkeys  [ $j ] } }} =
+                  values %{ $powerset->{ $powervalues[ $j ] } };
+
+          # Add the new member to the subset.
+          $subset{$key} = $value;
+
+          # Add the new subset to the powerset.
+          $powerset->{ \%subset } = \%subset;
+      }
+    }
+
+    return $powerset;
+}

perl/Examples/Chap5/powerset-4

@@ -0,0 +1,37 @@
+
+
+###
+### powerset_recurse4
+###
+
+## Chapter 5 section 4.1.1
+
+sub powerset_recurse ($) {
+    my ( $set ) = @_;
+    my $null = { };
+    my $powerset  = { $null, $null };
+
+    while (my ($key, $value) = each %$set) {
+
+      my @newitems;
+
+      while (my ($powerkey, $powervalue) = each %$powerset) {
+          my %subset = ( );
+
+          # Copy the old set to the subset.
+          @subset{keys   %{ $powerset->{$powerkey} } } =
+                  values %{ $powerset->{$powervalue} };
+
+          # Add the new member to the subset.
+          $subset{$key} = $value;
+
+          # Prepare to add the new subset to the powerset.
+          push @newitems, \%subset;
+      }
+
+      $powerset->{ $_ } = $_ for @newitems;
+
+    }
+
+    return $powerset;
+}

perl/Examples/Chap6/Newton.pm

@@ -0,0 +1,65 @@
+
+
+###
+### Newton.pm
+###
+
+## Chapter 6 section 6
+
+sub sqrt2 {
+  my $g = 2;   # Initial guess
+  until (close_enough($g*$g, 2)) {
+    $g = ($g*$g + 2) / (2*$g);
+  }
+  $g;
+}
+
+sub close_enough {
+  my ($a, $b) = @_;
+  return abs($a - $b) < 1e-12;
+}
+sub sqrtn {
+  my $n = shift;
+  my $g = $n;   # Initial guess
+  until (close_enough($g*$g, $n)) {
+    $g = ($g*$g + $n) / (2*$g);
+  }
+  $g;
+}
+
+
+## Chapter 6 section 6.1
+
+use Stream 'iterate_function';
+
+sub sqrt_stream {
+  my $n = shift;
+  iterate_function (sub { my $g = shift;
+                         ($g*$g + $n) / (2*$g);
+                        },
+                    $n);
+}
+
+1;
+
+
+## Chapter 6 section 6.2
+
+sub slope {
+  my ($f, $x) = @_;
+  my $e = 0.00000095367431640625;
+  ($f->($x+$e) - $f->($x-$e)) / (2*$e);
+}
+
+
+## Chapter 6 section 6.2
+
+# Return a stream of numbers $x that make $f->($x) close to 0
+sub solve {
+  my $f = shift;
+  my $guess = shift || 1;
+  iterate_function(sub { my $g = shift;
+                         $g - $f->($g)/slope($f, $g);
+                       },
+                   $guess);
+}

perl/Examples/Chap6/PowSeries.pm

@@ -0,0 +1,179 @@
+
+
+###
+### PowSeries.pm
+###
+
+## Chapter 6 section 7
+
+package PowSeries;
+use base 'Exporter';
+@EXPORT_OK = qw(add2 mul2 partial_sums powers_of term_values
+                evaluate derivative multiply recip divide
+                $sin $cos $exp $log_ $tan);
+use Stream ':all';
+
+sub tabulate {
+  my $f = shift;
+  &transform($f, upfrom(0));
+}
+my @fact = (1);
+sub factorial {
+  my $n = shift;
+  return $fact[$n] if defined $fact[$n];
+  $fact[$n] = $n * factorial($n-1);
+}
+
+
+$sin = tabulate(sub { my $N = shift;
+                      return 0 if $N % 2 == 0;
+                      my $sign = int($N/2) % 2 ? -1 : 1;
+                      $sign/factorial($N) 
+                    });
+
+
+$cos = tabulate(sub { my $N = shift;
+                      return 0 if $N % 2 != 0;
+                      my $sign = int($N/2) % 2 ? -1 : 1;
+                      $sign/factorial($N) 
+                   });
+
+
+## Chapter 6 section 7
+
+sub add2 {
+  my ($s, $t) = @_;
+  return unless $s && $t;
+  node(head($s) + head($t),
+       promise { add2(tail($s), tail($t)) });
+}
+sub mul2 {
+  my ($s, $t) = @_;
+  return unless $s && $t;
+  node(head($s) * head($t),
+       promise { mul2(tail($s), tail($t)) });
+}
+sub partial_sums {
+  my $s = shift;
+  my $r;
+  $r = node(head($s), promise { add2($r, tail($s)) });
+}
+sub powers_of {
+  my $x = shift;
+  iterate_function(sub {$_[0] * $x}, 1);
+}
+sub term_values {
+  my ($s, $x) = @_;
+  mul2($s, powers_of($x));
+}
+sub evaluate {
+  my ($s, $x) = @_;
+  partial_sums(term_values($s, $x));
+}
+
+
+## Chapter 6 section 7
+
+# Get the n'th term from a stream
+sub nth {
+  my $s = shift;
+  my $n = shift;
+  return $n == 0 ? head($s) : nth(tail($s), $n-1);
+}
+
+# Calculate the approximate cosine of x
+sub cosine {
+  my $x = shift;
+  nth(evaluate($cos, $x), 20);
+}
+sub is_zero_when_x_is_pi {
+  my $x = shift;
+  my $c = cosine($x/6);
+  $c * $c - 3/4;
+}
+
+
+## Chapter 6 section 7.1
+
+sub derivative {
+  my $s = shift;
+  mul2(upfrom(1), tail($s));
+}
+
+
+## Chapter 6 section 7.2
+
+$exp = tabulate(sub { my $N = shift; 1/factorial($N) });
+
+
+## Chapter 6 section 7.2
+
+$log_ = tabulate(sub { my $N = shift; 
+                       $N==0 ? 0 : (-1)**$N/-$N });
+
+
+## Chapter 6 section 7.3
+
+sub multiply {
+  my ($S, $T) = @_;
+  my ($s, $t) = (head($S), head($T));
+  node($s*$t,
+       promise { add2(scale(tail($T), $s),
+                 add2(scale(tail($S), $t),
+                      node(0,
+                       promise {multiply(tail($S), tail($T))}),
+                     ))
+               }
+       );
+}
+
+
+## Chapter 6 section 7.3
+
+sub scale {
+  my ($s, $c) = @_;
+  return    if $c == 0;
+  return $s if $c == 1;
+  transform { $_[0]*$c } $s;
+}
+
+
+## Chapter 6 section 7.3
+
+sub sum {
+  my @s = grep $_, @_;
+  my $total = 0;
+  $total += head($_) for @s;
+  node($total,
+       promise { sum(map tail($_), @s) }
+      );
+}
+sub multiply {
+  my ($S, $T) = @_;
+  my ($s, $t) = (head($S), head($T));
+  node($s*$t,
+       promise { sum(scale(tail($T), $s),
+                     scale(tail($S), $t),
+                     node(0,
+                       promise {multiply(tail($S), tail($T))}),
+                     )
+               }
+       );
+}
+
+
+## Chapter 6 section 7.3
+
+# Only works if head($s) = 1
+sub recip {
+  my ($s) = shift;
+  my $r;
+  $r = node(1, 
+            promise { scale(multiply($r, tail($s)), -1) });
+}
+sub divide {
+  my ($s, $t) = @_;
+  multiply($s, recip($t));
+}
+
+$tan = divide($sin, $cos);

perl/Examples/Chap6/Regex.pm

@@ -0,0 +1,164 @@
+
+
+###
+### Regex.pm
+###
+
+## Chapter 6 section 5
+
+package Regex;
+use Stream ':all';
+use base 'Exporter';
+@EXPORT_OK = qw(literal union concat star plus charclass show
+                matches);
+sub literal {
+  my $string = shift;
+  node($string, undef);
+}
+
+
+## Chapter 6 section 5
+
+sub mingle2 {
+  my ($s, $t) = @_;
+  return $t unless $s;
+  return $s unless $t;
+  node(head($s), 
+       node(head($t), 
+                promise { mingle2(tail($s), 
+                                  tail($t)) 
+                                }
+      ));
+}
+sub union {
+  my ($h, @s) = grep $_, @_;
+  return unless $h;
+  return $h unless @s;
+  node(head($h),
+       promise {
+         union(@s, tail($h));
+       });
+}
+
+
+## Chapter 6 section 5
+
+sub concat {
+  my ($S, $T) = @_;
+  return unless $S && $T;
+
+  my ($s, $t) = (head($S), head($T));
+
+  node("$s$t", promise {
+    union(postcat(tail($S), $t),
+           precat(tail($T), $s),
+          concat(tail($S), tail($T)),
+         )
+  });
+}
+
+
+## Chapter 6 section 5
+
+sub precat {
+  my ($s, $c) = @_;
+  transform {"$c$_[0]"} $s;
+}
+
+sub postcat {
+  my ($s, $c) = @_;
+  transform {"$_[0]$c"} $s;
+}
+
+
+## Chapter 6 section 5
+
+sub star {
+  my $s = shift;
+  my $r;
+  $r = node("", promise { concat($s, $r) });
+}
+
+
+## Chapter 6 section 5
+
+sub show {
+  my ($s, $n) = @_;
+  while ($s && (! defined $n || $n-- > 0)) {
+    print qq{"}, drop($s), qq{"\n};
+  }
+  print "\n";
+}
+
+
+## Chapter 6 section 5
+
+# charclass('abc') = /^[abc]$/
+sub charclass {
+  my ($s, $class) = @_;
+  union(map literal($_), split(//, $class));
+}
+
+# plus($s) = /^s+$/
+sub plus {
+  my $s = shift;
+  concat($s, star($s));
+}
+
+1;
+
+
+## Chapter 6 section 5.1
+
+sub union {
+  my (@s) = grep $_, @_;
+  return unless @s;
+  return $s[0] if @s == 1;
+  my $si = index_of_shortest(@s);
+  node(head($s[$si]),
+              promise {
+                union(map $_ == $si ? tail($s[$_]) : $s[$_], 
+                          0 .. $#s);
+              });
+}
+sub index_of_shortest {
+  my @s = @_;
+  my $minlen = length(head($s[0]));
+  my $si = 0;
+  for (1 .. $#s) {
+    my $h = head($s[$_]);
+    if (length($h) < $minlen) {
+      $minlen = length($h);
+      $si = $_;
+    }
+  }
+  $si;
+}
+
+
+## Chapter 6 section 5.2
+
+sub matches {
+  my ($string, $regex) = @_;
+  while ($regex) {
+    my $s = drop($regex);
+    return 1 if $s eq $string;
+    return 0 if length($s) > length($string);
+  }
+  return 0;
+}
+
+
+## Chapter 6 section 5.2
+
+sub bal {
+  my $contents = shift;
+  my $bal;
+  $bal = node("", promise {
+    concat($bal,
+           union($contents,
+                 transform {"($_[0])"} $bal,
+                )
+          )
+       });
+}

perl/Examples/Chap6/Stream.pm

@@ -0,0 +1,220 @@
+
+
+###
+### Stream.pm
+###
+
+## Chapter 6 section 2
+
+package Stream;
+use base Exporter;
+@EXPORT_OK = qw(node head tail drop upto upfrom show promise
+                filter transform merge list_to_stream cutsort
+                iterate_function cut_loops);
+
+%EXPORT_TAGS = ('all' => \@EXPORT_OK);
+
+sub node {
+  my ($h, $t) = @_;
+  [$h, $t];
+}
+
+sub head {
+  my ($s) = @_;
+  $s->[0];
+}
+
+sub tail {
+  my ($s) = @_;
+  if (is_promise($s->[1])) {
+    return $s->[1]->();
+  }
+  $s->[1];
+}
+
+sub is_promise {
+  UNIVERSAL::isa($_[0], 'CODE');
+}
+sub promise (&) { $_[0] }
+
+
+## Chapter 6 section 2.1
+
+sub upto {
+  my ($m, $n) = @_;
+  return if $m > $n;
+  node($m, promise { upto($m+1, $n) } );
+}
+sub upfrom {
+  my ($m) = @_;
+  node($m, promise { upfrom($m+1) } );
+}
+
+
+## Chapter 6 section 2.2
+
+sub show {
+  my ($s, $n) = @_;
+  while ($s && (! defined $n || $n-- > 0)) {
+    print head($s), $";
+    $s = tail($s);
+  }
+  print $/;
+}
+
+
+## Chapter 6 section 2.2
+
+sub drop {
+  my $h = head($_[0]);
+  $_[0] = tail($_[0]);
+  return $h;
+}
+
+
+## Chapter 6 section 2.2
+
+sub transform (&$) {
+  my $f = shift;
+  my $s = shift;
+  return unless $s;
+  node($f->(head($s)),
+       promise { transform($f, tail($s)) });
+}
+
+
+## Chapter 6 section 2.2
+
+sub filter (&$) {
+  my $f = shift;
+  my $s = shift;
+  until (! $s || $f->(head($s))) {
+    drop($s);
+  }
+  return if ! $s;
+  node(head($s),
+       promise { filter($f, tail($s)) });
+}
+
+
+## Chapter 6 section 3.1
+
+sub tail {
+  my ($s) = @_;
+  if (is_promise($s->[1])) {
+    $s->[1] = $s->[1]->();
+  }
+  $s->[1];
+}
+
+
+## Chapter 6 section 4
+
+sub merge {
+  my ($S, $T) = @_;
+  return $T unless $S;
+  return $S unless $T;
+  my ($s, $t) = (head($S), head($T));
+  if ($s > $t) {
+     node($t, promise {merge(     $S,  tail($T))});
+   } elsif ($s < $t) {
+     node($s, promise {merge(tail($S),      $T)});
+   } else {
+     node($s, promise {merge(tail($S), tail($T))});
+   }
+}
+
+
+## Chapter 6 section 5.3
+
+sub list_to_stream {
+  my $node = pop;
+  while (@_) {
+    $node = node(pop, $node);
+  }
+  $node;
+}
+sub insert (\@$$);
+
+sub cutsort {
+  my ($s, $cmp, $cut, @pending) = @_;
+  my @emit;
+
+  while ($s) {
+    while (@pending && $cut->($pending[0], head($s))) {
+      push @emit, shift @pending;
+    }
+
+    if (@emit) {
+      return list_to_stream(@emit, 
+                            promise { cutsort($s, $cmp, $cut, @pending) });
+    } else {
+      insert(@pending, head($s), $cmp);
+      $s = tail($s);
+    }
+  }
+
+  return list_to_stream(@pending, undef);
+}
+
+
+## Chapter 6 section 5.3
+
+sub insert (\@$$) {
+  my ($a, $e, $cmp) = @_;
+  my ($lo, $hi) = (0, scalar(@$a));
+  while ($lo < $hi) {
+    my $med = int(($lo + $hi) / 2);
+    my $d = $cmp->($a->[$med], $e);
+    if ($d <= 0) {
+      $lo = $med+1;
+    } else {
+      $hi = $med;
+    }
+  }
+  splice(@$a, $lo, 0, $e);
+}
+
+
+## Chapter 6 section 6.1
+
+sub iterate_function {
+  my ($f, $x) = @_;
+  my $s;         
+  $s = node($x, promise { &transform($f, $s) });
+}
+
+
+## Chapter 6 section 6.3
+
+sub cut_loops {
+  my ($tortoise, $hare) = @_;
+  return unless $tortoise;
+
+  # The hare and tortoise start at the same place
+  $hare = $tortoise unless defined $hare;
+
+  # The hare moves two steps every time the tortoise moves one
+  $hare = tail(tail($hare));
+
+  # If the hare and the tortoise are in the same place, cut the loop
+  return if head($tortoise) == head($hare);
+
+  return node(head($tortoise), 
+              promise { cut_loops(tail($tortoise), $hare) });
+}
+
+
+## Chapter 6 section 6.3
+
+sub cut_loops2 {
+  my ($tortoise, $hare, $n) = @_;
+  return unless $tortoise;
+  $hare = $tortoise unless defined $hare;
+
+  $hare = tail(tail($hare));
+  return if head($tortoise) == head($hare)
+            && $n++;
+  return node(head($tortoise), 
+              promise { cut_loops(tail($tortoise), $hare, $n) });
+}

perl/Examples/Chap6/hamming.pl

@@ -0,0 +1,26 @@
+
+
+###
+### hamming.pl
+###
+
+## Chapter 6 section 4
+
+use Stream qw(transform promise merge node show);
+
+sub scale {
+  my ($s, $c) = @_;
+  transform { $_[0]*$c } $s;
+}
+my $hamming;
+$hamming = node(1,
+                promise {
+                  merge(scale($hamming, 2),
+                  merge(scale($hamming, 3),
+                        scale($hamming, 5),
+                       ))
+                }
+               );
+
+
+show($hamming, 3000);

perl/Examples/Chap6/show-example-1

@@ -0,0 +1,11 @@
+
+
+###
+### show-example-1
+###
+
+## Chapter 6 section 2.2
+
+use Stream 'upfrom', 'show';
+
+show(upfrom(7), 10);

perl/Examples/Chap6/show-example-2

@@ -0,0 +1,11 @@
+
+
+###
+### show-example-2
+###
+
+## Chapter 6 section 2.2
+
+use Stream 'upto', 'show';
+
+show(upto(3,6));

perl/Examples/Chap6/sine

@@ -0,0 +1,23 @@
+
+
+###
+### sine
+###
+
+## Chapter 6 section 7
+
+# Approximate sin(x) using the first n terms of the power series
+sub approx_sin {
+  my $n = shift;
+  my $x = shift;
+  my ($denom, $c, $num, $total) = (1, 1, $x, 0);
+  while ($n--) {
+    $total += $num / $denom;
+    $num *= $x*$x * -1;
+    $denom *= ($c+1) * ($c+2);
+    $c += 2;
+  }
+  $total;
+}
+
+1;

perl/Examples/Chap7/Curry.pm

@@ -0,0 +1,47 @@
+
+
+###
+### Curry.pm
+###
+
+## Chapter 7 section 2.1
+
+package Curry;
+use base 'Exporter';
+@EXPORT = ('curry');
+@EXPORT_OK = qw(curry_listfunc curry_n);
+
+sub curry_listfunc {
+  my $f = shift;
+  return sub { 
+    my $first_arg = shift;
+    return sub { $f->($first_arg, @_) };
+  };
+}
+
+sub curry {
+  my $f = shift;
+  return sub { 
+    my $first_arg = shift;
+    my $r = sub { $f->($first_arg, @_) };
+    return @_ ? $r->(@_) : $r;
+  };
+}
+
+1;
+
+
+## Chapter 7 section 2.3
+
+sub curry_n {
+  my $N = shift;
+  my $f = shift;
+  my $c;
+  $c = sub {
+    if (@_ >= $N) { $f->(@_) }
+    else {
+      my @a = @_;
+      curry_n($N-@a, sub { $f->(@a, @_) });
+    }
+  };
+}