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:

  1. Anonymous12:16 am

    #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;
    }

    ReplyDelete
  2. Anonymous4:23 pm

    #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
    }

    ReplyDelete
  3. Anonymous4:45 pm

    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} ]
    }

    ReplyDelete
  4. Anonymous7:06 pm

    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

    ReplyDelete
  5. Anonymous6:09 am

    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

    ReplyDelete
  6. Anonymous3:19 pm

    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")

    ReplyDelete