[SPOILER] Re: Perl 'Easy' Quiz #2005-2 (Perl and PostScript)

On Wed, Feb 02, 2005 at 07:54:19PM +0200, Shlomi Fish wrote:

>I've been on FreeNode's #perl channel one day when someone asked how to remove 
>all periods from a string except the last one. So for example 
>"this.is.a.file.txt" will become "thisisafile.txt".
>
>Your mission is to write as many different solutions as possible to this 
>problem. You should write functions which will accept a single scalar 
>argument containing the string, and return a single scalar containing the 
>modified string.

I wrote test harnesses first. Test strings are in the file "in", and
the expected output is in "out", both one per line. My test cases were:

foo
foo.bar
foo.bar.baz
foo.bar.baz.qux
foo.
.foo
foo.bar.
.foo.bar
foo..bar
foo...bar
foo..bar.baz
foo.bar..baz

expecting the output:

foo
foo.bar
foobar.baz
foobarbaz.qux
foo.
.foo
foobar.
foo.bar
foo.bar
foo.bar
foobar.baz
foobar.baz

The Perl test harness is simple (stolen from one of MJD's a while ago;
it takes the file as a parameter, and expects it to contain a
"dot_remove" function and return true):

#! /usr/bin/perl -w

use strict;

my $prog = shift or die "Usage: $0 libfile.pl\n";
do $prog;
die "Couldn't find 'dot_remove()'\n"
  unless defined(&dot_remove);

open I,'<in';
open O,'<out';
my $fails=0;
while (<I>) {
  chomp;
  my $o=&dot_remove($_);
  chomp (my $o2=<O>);
  unless ($o eq $o2) {
    print "$_: expected $o2, got $o\n";
    $fails++;
  }
}
unless ($fails) {
  print "OK\n";
}

My first Perl solution is straight out of the perlop manpage:

# while_re.pl

sub dot_remove {
  my ($a)=@_;
  1 while $a =~ s/([^.]*)\.([^.]*)\./$1$2./g;
  return $a;
}

The second is slightly odder:

# reverse_re.pl

sub dot_remove {
  my ($a)=@_;
  my $d=reverse $a;
  if (my ($b,$c) = ($d =~ /^([^.]*)\.(.*)/)) {
    $c =~ s/\.//g;
    $a=reverse("$b.$c");
  }
  return $a;
}

The third was an effort to avoid using the regex engine at all (though
I'm not sure whether split '' counts):

# hash.pl

sub dot_remove {
  my ($a)=@_;
  my @a=split '',$a;
  my %h;
  map {$h{$_}++} @a;
  foreach (2..($h{'.'} || 0)) {
    my $p=index $a,'.';
    splice @a,$p,1;
    $a=join('',@a);
  }
  return $a;
}

Going even further:

# index.pl

sub dot_remove {
  my ($a)=@_;
  my $p=index($a,'.');
  while ($p>-1 &&
         index($a,'.',$p+1) > -1) {
    substr($a,$p,1)='';
    $p=index($a,'.');
  }
  return $a;
}


Then I started using PostScript (because I enjoy it and for some reason
there's no PostScript QOTW). Again, the first stage is the test
harness. I haven't yet found a way to pass a command-line parameter to
a PostScript program running under GhostScript, so you'll have to
change the included filename manually:

%!

(counter.ps) run

/INPUT (in) (r) file def
/VERIFY (out) (r) file def

/Helvetica findfont
12 scalefont
setfont

0.5 72 mul 10 72 mul translate

{
INPUT 800 string readline
  {
  } {
    exit
  } ifelse
  dup
  remove_dots
  dup
  2.5 72 mul 0 moveto
  show
  5 72 mul 0 moveto
  VERIFY 800 string readline pop
  eq {
    (OK)
  } {
    (failed)
  } ifelse
  show
  0 0 moveto
  show
  0 0.5 neg 72 mul translate
} loop
INPUT closefile
VERIFY closefile

(I submit that my unthinking renaming of what in Perl was the
"dot_remove" function to "remove_dots" shows that I was starting to get
into the PostScript mindset. Or something.)

First pass at the postscript function, still quite traditionally
programmed:

%! counter.ps

%% string1 remove_dots string2
% Function: removes all but last . in a string
/remove_dots {
  dup
  /COUNT 0 def
  {
    46 eq {
      /COUNT COUNT 1 add def
    } if
  } forall
  COUNT 1 gt {
    dup
    length COUNT sub 1 add string
    /OUT exch def
    /POS 0 def
    {
      dup
      46 eq {
        COUNT 1 gt {
          pop
          -1
          /COUNT COUNT 1 sub def
        } if
      } if
      dup
      -1 ne {
        OUT exch POS exch put
        /POS POS 1 add def
      } {
        pop
      } ifelse
    } forall
    OUT
  } if
} bind def

Second attempt, a little neater - and thanks to the PostScript FAQ's
string appender, done entirely without named variables:

%! search.ps

%% string1 remove_dots string2
% Function: removes all but last . in a string
/remove_dots {
  mark exch
  {
    (.) search { % post match pre
      exch pop exch % pre post
    } {
      exit
    } ifelse
  } loop
  counttomark 1 gt {
    (.) exch
  } if
  counttomark 1 sub {
    append
  } repeat
  exch pop
} bind def

%% string1 string2 append string
% Function: Concatenates two strings together.
% from http://www.postscript.org/FAQs/language/node68.html
/append {
         2 copy length exch length add  % find the length of the new.
         string dup     % string1 string2 string string
         4 2 roll       % string string string1 string2
         2 index 0 3 index
         % string string string1 string2 string 0 string1
         putinterval    % stuff the first string in.
         % string string string1 string2
         exch length exch putinterval
} bind def

Roger