Re: REgular expression to check the string that allows "a","b" and "c" to occur only once in any order.

Note: Please ignore the code listed here as it is buggy inside the while loop. Sorry for the noise.

First thing I thought of after reading OP was Algorithm::Permute module. (That led me to search for other permutations related modules. Now, I am more in favor of Math::Combinatorics and Algorithm::Combinatorics.)

I did not spend much time on thinking of a regex as that would have been hairy, though I liked BrowserUk's regex (which could get unwieldy if needs to be modified).

Below is the version which checks for overlapping strings ("abcXa" is ok, "abca" not). As it is, the program below uses &A::C::permutations. Feel free to exercise any of the other two modules. Basically, the big idea is ...

sub find_once
{
  my ( $str , ... ) = @_ ;
  ...
  my ( $pos , $once ) = ( 0 ) x2;
  while ( my $p = get_permutation_string() )
  {
    last if $once > 1;
    ( $pos = index $str , $p , $pos ) >= 0 and $once++ ;
  }
  return $once == 1;
}
[download]

Update: I just noticed that "once" specification is in the title, but missing from the body.

#!/usr/local/bin/perl

use warnings; use strict;

use Algorithm::Permute;
use Algorithm::Combinatorics qw/ permutations /;
use Math::Combinatorics;

my @in =
  qw(
   abc
   cab
   bac
   acba
   acbac
   acbacb
   acbXa
   acbXac
   acbXacb
   acbaXc
   acbaXcb
   acbacXb
   acbacbX
  ) ;

my @need = qw( a b c );

printf "%10s ok? %s\n"
  , "'$_'"
  #  Feel free to switch to any other function.
  , !!find_once_AC( $_ , @need )  ? 'yes' : 'no'
    for @in ;

exit;

#  Using Algorithm::Permute.
sub find_once_AP
{
  my ( $str , @char ) = @_;

  my $permute = Algorithm::Permute->new( [ @char ] );

  my ( $pos , $once ) = ( 0 ) x 2;
  while ( my $p = join '' , $permute->next )
  {
    last if $once > 1;
    ( $pos = index $str , $p , $pos ) >= 0 and $once++ ;
  }
  return $once == 1;
}

#  Using Math::Combinatorics.
sub find_once_MC
{
  my ( $str , @char ) = @_;

  my $permute = Math::Combinatorics->new( 'data' => [ @char ] );

  my ( $pos , $once ) = ( 0 ) x 2;
  while ( my $p = join '' , $permute->next_permutation )
  {
    last if $once > 1;
    ( $pos = index $str , $p , $pos ) >= 0 and $once++ ;
  }
  return $once == 1;
}

#  Using Algorithm::Combinatorics.
sub find_once_AC
{
  my ( $str , @char ) = @_;

  my $permute = permutations( [ @char ] );

  my ( $pos , $once ) = ( 0 ) x 2;
  while ( my $p = $permute->next )
  {
    $p = join '' , @{ $p };
    last if $once > 1;
    ( $pos = index $str , $p , $pos ) >= 0 and $once++ ;
  }
  return $once == 1;
}
[download]

Comment on Re: REgular expression to check the string that allows "a","b" and "c" to occur only once in any order. Select or Download Code

Replies are listed 'Best First'.
Re^2: REgular expression to check the string that allows "a","b" and "c" to occur only once in any order. by parv (Parson) on Dec 11, 2007 at 11:06 UTC
The assignment of `$pos` has a bug in ... `( $pos = index $str , $p , $pos ) >= 0 and $once++ ;` [download] ... which caused index() to some times start from -1, not ot mention `$pos` was not being reset to 0. Please ignore my previous reply.	[reply] [d/l] [select]


We don't bite newbies here... much
	PerlMonks