Expanding [optionals], groupings, and the | or operator in text - regex

Question

I am trying to expand sentences that incorporate [ ] to indicate optionals, ( ) to indicate grouping, and | to indicate the or operator and enumerate all possibilities. So for example:
"Hey [there] you [hood]." should return four sentences:
Hey there you hood.
Hey there you.
Hey you hood.
Hey you.
The end goal would look like:
Input: "(His|Her) dog was [very|extremely] confused."
Output: His dog was very confused.
His dog was extremely confused.
His dog was confused.
Her dog was very confused.
Her dog was extremely confused.
Her dog was confused.
I am doing it using regex matching and recursion. I have searched both CPAN and SO under the phrases:
Expanding text
expanding sentences
expanding conditionals
expanding optionals
expanding groupings
with no luck.
Thanks.
I have edited this question largely to better reflect its evolution and removed large portions which were made obsolete as the question evolved. The question above is the question that most of the answers below are attempting to address.
My current state is the following:
After wrestling with the problem above for a day I have two solutions very close to what I want. One is my own and the second is PLT's below. However, I have decided to try a fundamentally different approach.
Using regular expressions and manually parsing these sentences seems like a very ugly way of doing things. So I have decided to instead write a grammar for my "language" and use a parser-generator to parse it for me.
This gives me an additional layer of abstraction and avoids the following scenario described by Damian Conway in Perl Best Practices: [about regexps]
cut-and-paste-and-modify-slightly-and-oh-now-it-doesn't-work-at-all-so-let's-modify-it-some-more-and-see-if-that-helps-no-it-didn't-but-we're-commited-now-so-maybe-if-we-change-that-bit-instead-hmmmm-that's-closer-but-still-not-quite-right-maybe-if-I-made-that-third-repetition-non-greedy-instead-oops-now-it's-back-to-not-matching-at-all-perhaps-I-should-just-post-it-to-PerlMonks.org-and-see-if-they-know-what's-wrong
It also makes it much easier if the grammar of these expressions were to change and I needed to support other constructs later on.
Last update:
I solved my problem using an open source toolkit. This will transcribe a JSGF version of my input and generate a finite-state transducer. From there you can walk through the FST to generate all possible outcomes.

Answer 1

Ok, another complete revision of the answer. This will work as intended. :) It now also expands nested parens. Newline is still the delimeter, but I added a way to quickly change it to something more complicated if the need arises.
Basically, I started with replacing brackets with parens + pipe, since [word ] and (|word ) are equivalent.
I then extracted all the encapsulating parens, e.g. both (you |my friend) and (you |my (|friendly ) friend ). I then expanded the nested parens into regular parens, e.g. (you |my (|friendly ) friend ) was replaced with (you |my friendly friend |my friend ).
With that done, the words could be processed with the original subroutine.
Remains to be tested on more complicated expansions, but it works fine during my testing.
Here's the revised code:
use strict;
use warnings;
sub addwords {
my ($aref, #words) = #_;
my #total;
for my $start (#$aref) {
for my $add (#words) {
push #total, $start . $add;
}
}
return #total;
}
sub expand_words {
my $str = shift;
my #sentences = ('');
for my $word (word_split($str)) {
if ($word =~ /^([(])([^)]+)[)]$/) {
my #options = split /\|/, $2;
push #options, '' if ($1 eq '[');
#sentences = addwords(\#sentences, #options);
} else {
#sentences = addwords(\#sentences, $word);
}
}
return #sentences;
}
sub fix_parens {
my $str = shift;
$str =~ s/\[/(|/g;
$str =~ s/\]/)/g;
return $str;
}
sub fix_nested {
my #array = #_;
my #return;
for (my $i=0; $i <= $#array; ) {
my $inc = 1;
my ($co, $cc);
do {
$co = () = $array[$i] =~ /\(/g;
$cc = () = $array[$i] =~ /\)/g;
if ( $co > $cc ) {
$array[$i] .= $array[$i + $inc++];
}
} while ( $co > $cc );
push #return, expand_nest($array[$i]);
$i += $inc;
}
return #return;
}
sub expand_nest {
my $str = shift;
my $co = () = $str =~ /\(/g;
return $str unless ($co > 1);
while ($str =~ /([^|(]+\([^)]+\)[^|)]+)/) {
my $match = $1;
my #match = expand_words($match);
my $line = join '|', #match;
$match =~ s/([()|])/"\\" . $1/ge;
$str =~ s/$match/$line/ or die $!;
}
return $str;
}
sub word_split {
my $str = shift;
my $delimeter = "\n";
$str = fix_parens($str);
$str =~ s/([[(])/$delimeter$1/g;
$str =~ s/([])])/$1$delimeter/g;
my #tot = split /$delimeter/, $str;
#tot = fix_nested(#tot);
return #tot;
}
my $str = "Hey [there ](you|my [friendly ]friend) where's my [red|blue]berry?";
my #sentences = expand_words($str);
print "$_\n" for (#sentences);
print scalar #sentences . " sentences\n";
Will produce the output:
Hey you where's my berry?
Hey you where's my redberry?
Hey you where's my blueberry?
Hey my friend where's my berry?
Hey my friend where's my redberry?
Hey my friend where's my blueberry?
Hey my friendly friend where's my berry?
Hey my friendly friend where's my redberry?
Hey my friendly friend where's my blueberry?
Hey there you where's my berry?
Hey there you where's my redberry?
Hey there you where's my blueberry?
Hey there my friend where's my berry?
Hey there my friend where's my redberry?
Hey there my friend where's my blueberry?
Hey there my friendly friend where's my berry?
Hey there my friendly friend where's my redberry?
Hey there my friendly friend where's my blueberry?
18 sentences

Answer 2

Data::Generate. I found this while searching for combination which is the mathematical term of what you're doing with your sets of words there.

Answer 3

Here is a rather simple solution, if you get past some of the ugly regexps, due to collisions between your syntax and the regexp syntax. It allows for both the [] and the () syntax, which in fact are very similar, [foo] is the same as (foo| ).
The basis is to replace each alternation by a marker #0, #1, #2... while storing them in an array. then replace the last marker, generating several phrases, then replace the next-to last marker in each of those phrases... until all markers have been replaced. Attentive readers of Higher-order Perl will no doubt find a more elegant way to do this.
#!/usr/bin/perl
use strict;
use warnings;
while( my $phrase=<DATA>)
{ my $original= $phrase;
$phrase=~s{\[([^\]]*)\]}{($1| )}g; # replace [c|d] by (c|d| )
my $alts=[]; my $i=0;
while( $phrase=~ s{\(([^)]*)\)}{#$i}) # replace (a|b) ... (c|d| ) by #0 ... #1
{ push #$alts, [ split /\|/, $1 ]; $i++; # store [ ['a', 'b'], [ 'c', 'd', ' '] ]
}
my $expanded=[$phrase]; # seed the expanded list with the phrase
while( #$alts) { expand( $alts, $expanded); } # expand each alternation, until none left
print "$original - ", join( " - ", #$expanded), "\n\n";
}
exit;
# expand the last #i of the phrase in all the phrases in $expanded
sub expand
{ my( $alts, $expanded)=#_;
my #these_alts= #{pop(#$alts)}; # the last alternations
my $i= #$alts; # the corresponding index in the phrases
#$expanded= map { my $ph= $_;
map { my $ph_e= $ph;
$ph_e=~ s{#$i}{$_}; # replace the marker #i by one option
$ph_e=~ s{ +}{ }; # fix double spaces
$ph_e;
} #these_alts # for all options
} #$expanded # for all phrases stored so far
}
__DATA__
(His|Her) dog was [very|extremely