Tuesday, March 11, 2008

[Perl] How to do it better

There are some really helpful people in the Perl community. I advertised the original posting on comp.lang.perl.misc and received some very useful responses from John W. Krahn and Michele Dondi, as below.

With respect to the rules, John wrote:



John> Why [were] you converting the '|' character and the 'e' character to 'e'?



John> The . character class matches a lot more than just letters, or did you really mean "replace any first character except newline with 'n'".



John> The . character class matches a lot more than just letters.



Then, with respect to the string eval() of each rule, John said, "Ouch! Use a dispatch table instead of string eval()."



At this point Michele Dondi chipped in with, ">my %rule = (
>  1 => sub {
>    ( my $arg = shift ) =~ tr/s//d;
>    return $arg;
>    },
>  2 => sub {
>    return join '', sort split //, shift;
>    },

Since the keys are numbers, an array may be appropriate."

So there you have it, better rules, anonymous subroutines, and hashes. Powerful stuff.

I wonder how Tcl and the other languages would have done it. Or Protium, for that matter. Any takers?

© Copyright Bruce M. Axtens, 2008

6 comments:

rms said...

#awk
{
# Rule 1. remove all 's'
gsub("s","");
# Rule 2. sort word alphabetically
# crufted together workaround
#for missing 'join'
split($0,arr,"");
x = asort(arr,sarr);
t = ""
for(i=1;i<=x;i++){
t = t sprintf("%c",sarr[i]);
}
$0 = t
# Rule 3. convert all vowels to 'e'
gsub(/[aeiou]/,"e");
# Rule 4. replace 1st char with 'n'
sub(/^./,"n");
# Rule 5. drop the last letter
sub(/.$/,"");
# Rule 6. replace letter pairs
# with 'ow'
for(i=1;i<=length;i++){
q = substr($0,i,1) substr($0,i,1)
gsub(q,"ow");
}
print;
}

rms said...

#tcl
while { [gets stdin l] != -1 } {
# Rule 1. remove all 's'
set l [string map {s {} } $l]
# Rule 2. sort word alphabetically
set l [join [lsort \
[split $l {}]] {} ]
# Rule 3. convert all vowels to 'e'
set l [regsub -all {[aeoui]} $l e]
# Rule 4. repl. 1st letter with 'n'
set l [regsub -- {^.} $l {n}]
# Rule 5. drop the last letter
set l [regsub -- {.$} $l {}]
# Rule 6. repl.char pairs with 'ow'
set l [regsub -all \
{(.)\1} $l {ow}]
puts $l
}

rms said...

Almost one-liner
#tcl - compact version
while {[gets stdin line] != -1} {
puts [regsub -all {(.)\1} \
[regsub -- {.$} [regsub -- \
{^.} [regsub -all {[aeoui]} \
[join [lsort [split [string \
map {s {} } $line] {} ]] {} \
] e] {n} ] {} ] {ow} ]
}

rms said...

bash (well, mostly sed) version:

#! /bin/bash
while read A ; do
#Rule 1. remove all 's'
A=$(tr -d "s" <<<"$A")
#Rule 2. sort word alphabetically
A=$(sed -e 's!.!\n&!g' <<<"$A"|sort|tr -d "\n")
#Rule 3. convert all vowels to 'e'
A=$(tr "aiou" "e" <<<"$A")
#Rule 4. replace first letter with 'n'
A=$(sed -e 's!^.!n!' <<<"$A")
#Rule 5. drop the last letter
A=$(sed -e 's!.$!!' <<<"$A")
#Rule 6. replace letter pairs with 'ow'
A=$(sed -e 's!\([aeiou]\)\1!ow!g' <<<"$A")
echo $A
done

rms said...

Snobol4 - I'm almost sure there's a smarter way to sort a string.

Remove all XX before starting

#! /usr/local/bin/snobol4 -b
XX define("ssrt(l)") :(ssrt_end)
ssrt lc = &lcase
XX ident(l) :s(freturn)
f lc notany(l) = :s(f)
n lc len(1) . match = :f(return)
a l match . x = :f(n)
XX ssrt = ssrt x :(a)
ssrt_end

rdln l = trim(input) :f(end)
* Rule 1. remove all 's'
r1 l "s" = :s(r1)
* Rule 2. sort word alphabetically
r2 l = ssrt(l)
* Rule 3. convert all vowels to 'e'
r3 l any("aiou") = "e" :s(r3)
* Rule 4. replace first letter with 'n'
r4 l pos(0) len(1) = "n"
* Rule 5. drop the last letter
r5 l (len(1) rpos(0)) =
* Rule 6. replace letter pairs with 'ow'
r6 l (any(l) $ x *x ) = "ow" :s(r6)
XX output = l :(rdln)
end

rms said...

Comment on comment (bash):

Sorry, that's actually "replace pairs of vowels with "ow":

A=$(sed -e 's!\([aeiou]\)\1!ow!g' <<<"$A")

corrected version:

A=$(sed -e 's!\([a-z]\)\1!ow!g' <<<"$A")