Re^4: How to replace greedy alternation?

This may or may not be an improvement, but it only takes one pass through the regex:

#!/usr/bin/perl

use strict;
use warnings;

# If all four chars are present, returns them in first-seen order.
# If any of the four are not present, returns an empty string.
sub four_or_nothing {
    my $str = shift;

    my @in_order = ($str =~ m{ 
        ([abcd]) 
        .*?
        (?!\1)([abcd]) 
        .*?
        (?!\1|\2)([abcd]) 
        .*? 
        (?!\1|\2|\3)([abcd])
    }x);

    return join("", @in_order);
}

foreach my $case (
    '1b22a7b3d3ccaacbcaccddeqcc11oabepd',
    '1b22w7b3d3ccsqcbc2ccddeqcc11o9bepd',
) {
    printf qq{%s: "%s"\n}, $case, four_or_nothing($case);
}

__DATA__
1b22a7b3d3ccaacbcaccddeqcc11oabepd: "badc"
1b22w7b3d3ccsqcbc2ccddeqcc11o9bepd: ""
[download]

Comment on Re^4: How to replace greedy alternation? Download Code

Replies are listed 'Best First'.
Re^5: How to replace greedy alternation? by gone2015 (Deacon) on Jan 29, 2009 at 13:26 UTC
How wonderful ! And another regex trick learned :-) Though it goes bloomin' berserk backtrackin' when all four of 'abcd' are not present ! The following tweak improves: `my @in_order = ($str =~ m{ ^(?> .? ([abcd]) ) (?> .? (?!\1) ([abcd]) ) (?> .? (?!\1\|\2) ([abcd]) ) (?> .? (?!\1\|\2\|\3) ([abcd]) ) }x);` [download] And, of course, YAW: `sub four_or_less { my ($s) = @_ ; $s =~ tr/abcd//cd ; my $c = '' ; $c .= $1 while ($s =~ m/([^ $c])/g) ; return $c ; }` [download]	[reply] [d/l] [select]

Replies are listed 'Best First'.

Re^5: How to replace greedy alternation?
by gone2015 (Deacon) on Jan 29, 2009 at 13:26 UTC

How wonderful ! And another regex trick learned :-)

Though it goes bloomin' berserk backtrackin' when all four of 'abcd' are not present ! The following tweak improves:

    my @in_order = ($str =~ m{ 
       ^(?> .*?              ([abcd]) )
        (?> .*? (?!\1)       ([abcd]) )
        (?> .*? (?!\1|\2)    ([abcd]) )
        (?> .*? (?!\1|\2|\3) ([abcd]) )
    }x);
[download]

  sub four_or_less {
    my ($s) = @_ ;

    $s =~ tr/abcd//cd ;

    my $c = '' ;
    $c .= $1 while ($s =~ m/([^ $c])/g)  ;

    return $c ;
  }
[download]

[reply]
[d/l]
[select]