first commit

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