[SPOILER] Solution to Perl 'Easy' Quiz #2005-2

#!perl
use strict;

# These are sorted in the order I wrote them, not in order of
# complexity or in speed order.
#
# Incidentally, the speed of each algorithm to do 500 random
# conversions works out to this on my (slow, behind the times)
# machine:
#
#                      Rate
# wwhd              0.921/s
# nestySub           2.88/s
# reverseMapReverse  8.86/s
# redoAppend         9.90/s
# regexIt            12.6/s
# rindexMapPos       12.7/s
# splitJoin          16.7/s
# twoRegex           19.1/s
# rindexRegex        26.5/s
# rindexTr           47.1/s
#
# I admit that I'm not at all surprised that wwhd and nestySub are
# at the bottom of the heap; they're certainly the most complex.
# However, I was a bit surprised by some of the other rankings,
# and by how truly abyssmal wwhd was.

# regexIt
# The canonical perl solution, a single regex.  I have to use
# zero-width look-ahead to do it in one fell swoop; a variant
# would be:
#    while ($a =~ s/\.([^.]*\.)/$1/g) {1;}
# But that's not as clean as being able to do it in one pass.

sub regexIt {
  my $a = shift;
  $a =~ s/\.([^.]*)(?=\.)/$1/g;
  $a;
}

# twoRegex
# I suspect solutions like this one will be common.  Basically,
# a regex is used to separate the input into
# (everything before the last dot) (last dot and trailer)
# then, the obvious regex substitution is made to strip dots in
# the first half.

sub twoRegex {
  return $_[0] unless $_[0] =~ /^(.*)(\.[^.]*)$/;
  my ($a, $b) = ($1, $2);
  $a =~ s/\.//g;
  $a . $b;
}

# nestySub
# So I was pondering how to be more exotic, and thought: "What would
# Haskell do?" (or rather, "What would a Haskel programmer do to
# solve this in Haskell?"), and after throwing out some ideas as not
# being sufficiently obscure, came up with this.  (Though I admit it
# has much more of a scheme flavor than a Haskell flavor)
#
# Basically, by counting the number of dots, I define a function that
# can then be applied to each character of the input, and the
# function changes itself each time it hits a '.' until it becomes
# the identity function for the trailing portion of the input.

sub nestySub {
  my $f = 0;
  while ($_[0] =~ m/\./g) {
    my $prevf = $f;
    $f = sub {
      if ($prevf and $_[0] eq '.') {$f=$prevf;'';}
      else {$_[0];}
    };
  }
  $f ||= sub {return $_[0];};
  join('', map {$_=&$f($_);} split(//,$_[0]));
}

# rindexMapPos
# Looking for other ways to approach it, I looked through perlfunc
# and, sure enough, there was rindex ready to find the last 
# occurrence of '.' for me.  So I used it, and then in the last line
# I say: "Give me a string that has the same letters as $a, except
# that in positions less than $b, has nothing if $a had a period
# there."

sub rindexMapPos {
  my $a = shift;
  my $b = rindex($a,'.');
  join('', map {my $q=substr($a,$_,1); ($q eq '.' and $_<$b)?'':$q;}
           (0..length($a)-1));
}

# reverseMapReverse
# Well that was sufficiently overcomplicated - what if I just built
# the string backwards, and used a flag variable ($x) to tell me if
# I'd already hit the one allowed dot?

sub reverseMapReverse {
  my $x=0;
  join('', reverse map {if ($_ eq '.') {$_ = $x?'':'.'; $x=1;} $_;} 
                   reverse split(//,$_[0]));
}

# splitJoin
# I suspect solutions like this one will be common.
#
# Basically, use split to separate the input into '.'-delimited fields
# and then use join to put the fields back together, gluing all but
# the last one together with ''.

sub splitJoin {
  my @a = split(/\./,$_[0],-1);
  return $a[0] unless defined($a[1]);
  join('.', join('', @a[0..$#a-1]),$a[-1]);
}

# redoAppend
# What if we built up the output one field at a time, and just
# constantly corrected ourself for putting the trailing '.' on the
# output variable?
#
# Note the regex option /gc - very handy for something that scans a
# string by repeated passes with a regular expression.

sub redoAppend {
  my $a = shift;
  return $a unless $a =~ /^([^.]*\.)/g;
  my $b = $1;
  while ($a =~ /\G([^.]*\.)/gc) {substr($b,-1,1)=''; $b .= $1;}
  $b .= $1 if $a =~ /\G([^.]*)$/g;
  $b;
}

# rindexRegex
# This was written after I'd written my timing comparison program and
# noticed that twoRegex was so far the fastest.  This is an attempt
# to spead up twoRegex on the assumption that although a regex may be
# the fastest way to remove periods, rindex is the fastest way to
# find the last one.

sub rindexRegex {
  my $a = shift;
  my $b = rindex($a,'.');
  substr($a,0,$b) =~ s/\.//g unless $b < 1;
  $a;
}

# wwhd
# This was written after I started these comments and decided what a
# Haskell programmer would really do.
#
# And no, I hadn't seen the posted Haskell solutions yet, but this
# bears a strong resemblance to Shlomi Fish's first Haskell solution.

sub wwhd {
  my $wwhd_sub = sub {};
  $wwhd_sub = sub {
    return ($_[0],0) unless length($_[0]);
    my $x = substr($_[0],0,1);
    my ($xs, $founddot) = $wwhd_sub->(substr($_[0],1));
    if ($x eq '.') {if ($founddot) {return ($xs, $founddot);}
                    else           {return ($x . $xs, 1);}   }
    else {return ($x . $xs, $founddot);}
  };
  my ($retval, $ignore) = $wwhd_sub->($_[0]);
  return $retval;
}

# rindexTr
# This is a speedup of rindexRegexp made after I saw Shlomi Fish's
# post and realized that a tr is faster at wiping single characters
# than a regexp.

sub rindexTr {
  my $a = shift;
  my $b = rindex($a,'.');
  substr($a,0,$b) =~ y/.//d unless $b < 1;
  $a;
}