[SOLUTION] Perl 'Easy' Quiz #2005-2

Hi,

I hope I'm not too early now, but

  Wed, 2 Feb 2005 19:54:19 +0200

should be more than 60 hours ago...


So here is my solution.
It contains a testing framework that is very easily extensible in testcases
and functions. It uses Test::More to check if the functions master the text
cases and Benchmark to benchmark them.

My solution contains 8 different functions using regular expressions,
substr, hashes, split and join, splices and so on. The first function was
the first one that comes to my mind and it is the fastest among my
solutions.

I'm curious to see what other ideas might be postet here.

Greetings to all,
Christian.


----------------(snip)--------------




#!/usr/bin/perl
use strict;
use warnings;

use Benchmark  qw//;
use Test::More qw/no_plan/;


=head1 QOTW

    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.

    So for example if the function is called "myfunc", the following code:

    <<<
    print myfunc("this.is.a.file.txt");
    >>>

    Will print:

    thisisafile.txt

=cut


#
# prototypes:
#
sub delpoint1 ($);
sub delpoint2 ($);
sub delpoint3 ($);
sub delpoint4 ($);
sub delpoint5 ($);
sub delpoint6 ($);
sub delpoint7 ($);
sub delpoint8 ($);
sub benchmark ($$$);
sub do_the_test ($$$$);


#
# main program
# 
{
    my @cases = (
        ['this.is.a.file.txt',   'thisisafile.txt'     ],
        ['stupid',               'stupid'              ],
        ['test.only-one-point',  'test.only-one-point' ],
        ['this.is.another.test', 'thisisanother.test'  ],
        ['.a.',                  'a.'                  ],
        ['.a.b.',                'ab.'                 ],
        ['...',                  '.'                   ],
        ['..',                   '.'                   ],
        [' .',                   ' .'                  ],
        ['',                     ''                    ],
        [' . ',                  ' . '                 ],
        [' . . ',                '  . '                ],
        ['12.345,67',            '12.345,67'           ],
    );

    my @subs = (
        [\&delpoint1, 'delpoint1 (RE1)           ' ],
        [\&delpoint2, 'delpoint2 (RE2)           ' ],
        [\&delpoint3, 'delpoint3 (RE3)           ' ],
        [\&delpoint4, 'delpoint4 (RE4)           ' ],
        [\&delpoint5, 'delpoint5 (substr)        ' ],
        [\&delpoint6, 'delpoint6 (split and join)' ],
        [\&delpoint7, 'delpoint7 (ugly splices)  ' ],
        [\&delpoint8, 'delpoint8 (crazy hashes)  ' ],
    );

    for my $case (@cases) {
        my ($text, $solution) = @$case;

        #
        # print the results
        #
        print "[$text]\n";
        printf "    %s: [%s]\n", $_->[1], $_->[0]->($text) for @subs;
        print "\n";

        #
        # run the tests
        #
        print "    Testing ...\n";
        do_the_test($text, $_->[0], $_->[1], $solution) for @subs;
        print "\n", '-'x80, "\n\n";
    }

    #
    # benchmark
    #
    print "\nBenchmarking ...\n";
    benchmark([ map {$_->[0]} @cases ], 100_000, \@subs);
}

exit;


#
-----------------------------------------------------------------------------
#
-----------------------------------------------------------------------------


sub delpoint1 ($) {
    local $_ = shift;

    my $old = $_;
    while (/\./) {
        $old = $_;
        s~\.~~;
    }

    return $old;
}

#
-----------------------------------------------------------------------------

sub delpoint2 ($) {
    local $_ = shift;

    while (s~\.(.*\.)~$1~) {}

    return $_;
}

#
-----------------------------------------------------------------------------

sub delpoint3 ($) {
    local $_ = shift;

    while (s~\.([^.]*\.[^.]*$)~$1~) {}

    return $_;
}

#
-----------------------------------------------------------------------------

sub delpoint4 ($) {
    local $_ = shift;

    $_ = reverse;

    while (s~^([^.]*\.[^.]*)\.~$1~) {};

    $_ = reverse;

    return $_;
}

#
-----------------------------------------------------------------------------

sub delpoint5 ($) {
    local $_ = shift;

    my @pointpos;
    for my $i (0 .. length $_) {
        push @pointpos, $i if substr($_, $i, 1) eq '.';
    }

    my $ergebnis = '';
    if (@pointpos > 1) {
        my $from = 0;
        for my $pos (@pointpos[0..$#pointpos-1]) {
            my $delta = $pos-1 - ($from-1);
            $ergebnis .= substr($_, $from, $delta);
            $from = $pos+1;
        }
        my $delta = (length) - ($from-1);
        $ergebnis .= substr($_, $from, $delta);
    }
    else {
        $ergebnis = $_;
    }
    

    return $ergebnis;
}

#
-----------------------------------------------------------------------------

sub delpoint6 ($) {
    local $_ = shift;

    my @pos;
    my @string = split //;

    for my $i (0 .. $#string) {
        if ($string[$i] eq '.') {
            push @pos, $i;
        }
    }

    for my $i (reverse @pos[0..$#pos-1]) {
        splice @string, $i, 1;
    }

    $_ = join '', @string;

    return $_;
}

#
-----------------------------------------------------------------------------

sub delpoint7 ($) {
    local $_ = shift;

    my @parts = split /(\.)/;
    for my $i (reverse 0 .. $#parts) {
        splice @parts, $i, 1 if length $parts[$i] == 0;
    }
    for my $i (reverse 1 .. $#parts) {
        splice @parts, $i, 1 if $parts[$i] eq '.' and $parts[$i-1] eq '.';
    }
    my $last = -1;
    for my $i (0..$#parts) {
        $last = $i if $parts[$i] eq '.';
    }
    for my $i (reverse 0 .. $#parts) {
        splice @parts, $i, 1 if $parts[$i] eq '.' and $i != $last;
    }
    $_ = join '', @parts;

    return $_;
}

#
-----------------------------------------------------------------------------

sub delpoint8 ($) {
    local $_ = shift;

    my @parts = split /(\.)/;
    my %hash;
    for my $i (0..$#parts) {
        push @{ $hash{$parts[$i]} }, $i;
    }

    if (exists $hash{'.'}) {
        $hash{'.'} = [ @{ $hash{'.'} }[-1] ];
    }

    my %sort;
    for my $key (%hash) {
        for my $number (@{$hash{$key}}) {
            $sort{$number} = $key;
        }
    }

    $_ = '';
    for my $number (sort {$a <=> $b} keys %sort) {
        $_ .= $sort{$number};
    }


    return $_;
}

#
-----------------------------------------------------------------------------

sub benchmark ($$$) {
    my ($ref, $number, $subs) = @_;

    my %bench;
    for my $sub (@$subs) {
        $bench{$sub->[1]} = sub { $sub->[0]->($_) for @$ref };
    }

    Benchmark::timethese($number, \%bench);
}

#
-----------------------------------------------------------------------------

sub do_the_test ($$$$) {
    my ($text, $sub, $subname, $okvalue) = @_;

    print ' 'x4;
    Test::More::ok($sub->($text) eq $okvalue, "Test [$text] in sub
$subname");
}