first commit

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;