first commit

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