I have taken the liberty to develop a SDK to explore this interesting problem. I am submitting three programs. The first implements a dynamic programming algorithm that computes minimal expressions for all strings/bitfields of a given width at once. This gives the best results but it can only be used on strings of width maximum four. (The algorithm used here is essentially what we use in the search for pandigital formulas or representations of integers by some number of repeated digits and some set of arithmetic operations.) The second program uses a greedy algorithm that produces good but not perfect results. On sets of bitfields of width 3 it is as good as the other one in 247 out of 255 cases. This greedy algorithm picks the pattern that minimizes the number of extra bitfields that must be processed if a given pattern is selected. (These are the bitfields matched by the pattern but not included in the current set for which an expression is to be found and those bitfields from the current set that the pattern does not match.) And the third program is a script that compares the dynamic programming algorithm to the greedy one, signaling when the greedy one is not as good as the dynamic programming one. Finally there is a script that generates random inputs for use in the study of the greedy algorithm.
This is the dynamic programming algorithm.
#! /usr/bin/perl -w
MAIN: {
my $width = shift || 3;
die "field width is a positive integer"
if $width < 1;
my $allels = 2 ** $width;
my $allsets = 2 ** $allels;
my %expr = ();
my @layer = ();
my $baseels = 3 ** $width;
for(my $base = 0; $base < $baseels; $base++){
my $pat = ""; my $ind = $base;
for(my $pos = 0; $pos < $width; $pos++){
my $digit = $ind % 3;
if($digit == 0 || $digit == 1){
$pat .= $digit;
}
else{
$pat .= ".";
}
$ind = ($ind - $digit) / 3;
}
my $subs = 0;
for(my $pos = 0; $pos < $allels; $pos++){
my $el = unpack("b$width", pack("L", $pos));
$subs += 1 << $pos if $el =~ /^$pat$/;
}
$pat =~ s/\./\*/g;
$expr{$subs} = $pat;
$layer[0]->{$subs} = $pat;
}
my $curlay = 1;
while(scalar(keys %expr) < $allsets){
foreach my $rset_str (keys %{$layer[$curlay-1]}){
foreach my $tok_str (keys %{$layer[0]}){
my ($rset, $tok) =
(int($rset_str), int($tok_str));
if(($rset & $tok) == 0){
my $res = $rset + $tok;
my $what =
$layer[$curlay-1]->{$rset} . "+" .
$layer[0]->{$tok};
if(not(exists($expr{$res})) ||
length($expr{$res}) > length($what)){
$expr{$res} = $what;
$layer[$curlay]->{$res} = $what;
}
}
elsif(($rset & $tok) == $tok){
my $res = $rset - $tok;
my $what =
$layer[$curlay-1]->{$rset} . "-" .
$layer[0]->{$tok};
if(not(exists($expr{$res})) ||
length($expr{$res}) > length($what)){
$expr{$res} = $what;
$layer[$curlay]->{$res} = $what;
}
}
}
}
$curlay++;
}
foreach my $subs (sort {$a <=> $b} keys %expr){
my @list; my $ind = $subs;
for(my $pos = 0; $pos < $allels; $pos++){
my $digit = $ind % 2;
if($digit == 1){
my $el = unpack("b$width", pack("L", $pos));
push @list, $el;
}
$ind = ($ind - $digit) / 2;
}
print "{" . join(', ', sort(@list)) . "} ";
print $expr{$subs} . "\n";
}
print STDERR "max size was $curlay\n";
exit 0;
}
The output from this algorithm looks like this.
{001, 010, 011, 100, 101, 111} ***-110-000
{000, 001, 010, 011, 100, 101, 111} ***-110
{001, 011, 101, 110, 111} **1+110
{000, 001, 011, 101, 110, 111} 000+**1+110
{001, 011, 100, 101, 110, 111} 1**+0*1
{000, 001, 011, 100, 101, 110, 111} ***-010
{001, 010, 011, 101, 110, 111} *1*+*01
{000, 001, 010, 011, 101, 110, 111} ***-100
{001, 010, 011, 100, 101, 110, 111} ***-000
{000, 001, 010, 011, 100, 101, 110, 111} ***
The greedy algorithm goes like this. (Command line arguments are bitfields of one length not necessarily in sorted order.)
#! /usr/bin/perl -w
my @allstrings;
my %allmatches;
my %seen;
sub compute {
my ($fref, $tref) = @_;
my $n = scalar(@$fref);
return [ 'leaf', $fref->[0] ] if $n == 1;
my $frx = join('|', @$fref);
my @stats;
foreach my $pat (@$tref){
next if exists($seen{$pat});
my $matchcount = grep(/$pat/, @$fref);
my $extra = grep(!/$frx/, @{$allmatches{$pat}});
push @stats, [$pat, $extra + $n - $matchcount];
}
my @stats2 = sort {
$a->[1] <=> $b->[1]
} @stats;
my $best = $stats2[0]; $seen{$best->[0]} = 1;
return [ 'leaf', $best->[0] ] if $best->[1] == 0;
my @mismatch =
grep(!/$frx/, @{$allmatches{$best->[0]}});
my @rest = grep(!/$best->[0]/, @$fref);
my $addnode;
if(scalar(@rest)>0){
$addnode = ['add', $best->[0], compute(\@rest, $tref)];
}
else{
$addnode = ['leaf', $best->[0]];
}
if(scalar(@mismatch) == 0){
return $addnode;
}
return ['sub', $addnode, compute(\@mismatch, $tref)];
}
sub tostring {
my ($tree, $sign) = @_;
my $pat = ($sign==1 ? "+" : "-") . $tree->[1];
return $pat if $tree->[0] eq 'leaf';
if($tree->[0] eq 'add'){
return $pat . tostring($tree->[2], $sign);
}
return
tostring($tree->[1], $sign) .
tostring($tree->[2], -$sign);
}
MAIN: {
my @fields = ();
my $width = undef; my %seen;
foreach my $field (@ARGV){
my $len = length($field);
die "bit strings please"
if $field !~ /^{0,1}+$/;
die "same size please"
if defined($width) && $len != $width;
die "no duplicates please"
if exists $seen{$field};
push @fields, $field;
$seen{$field} = 1;
$width = $len;
}
die "no input received" if scalar(@fields) == 0;
my $allels = 2 ** $width;
my $allsets = 2 ** $allels;
my @terms = ();
my $baseels = 3 ** $width;
for(my $base = 0; $base < $baseels; $base++){
my $pat = ""; my $ind = $base;
for(my $pos = 0; $pos < $width; $pos++){
my $digit = $ind % 3;
if($digit == 0 || $digit == 1){
$pat .= $digit;
}
else{
$pat .= ".";
}
$ind = ($ind - $digit) / 3;
}
push @terms, $pat;
push @allstrings, $pat if $pat !~ /\./;
$allmatches{$pat} = [grep(/$pat/, @allstrings)];
}
my $expr = compute(\@fields, \@terms);
my $stringres = tostring($expr, 1);
my $formatted = substr($stringres, 1);
$formatted =~ s/\./\*/g;
print "$formatted ";
my %verify = ();
my $pos = 0; my $len = length($stringres);
while($pos < $len){
my $sign = substr($stringres, $pos, 1);
my $pat = substr($stringres, $pos+1, $width);
if($sign eq '+'){
foreach my $term (@allstrings){
$verify{$term} = 1 if $term =~ /$pat/;
}
}
else{
foreach my $term (@allstrings){
delete $verify{$term} if $term =~ /$pat/;
}
}
$pos += 1 + $width;
}
print "["; print($len/($width+1)); print "] ";
print(join(' ', sort(keys %verify)));
print("\n");
exit 0;
}
Use the following script to invoke it with random arguments and study its behavior.
#! /usr/bin/perl -w
#
MAIN: {
my $width = shift || 3;
my $count = shift || 10;
die "max exceeded" if $count>(2 ** $width);
my @strings = (); my @allstrings;
for(my $ind=0; $ind<(2**$width); $ind++){
push @allstrings,
unpack("b$width", pack("L", $ind));
}
for(my $pos=0; $pos<$count; $pos++){
my $nxt = int(rand(scalar(@allstrings)));
push @strings, $allstrings[$nxt];
splice @allstrings, $nxt, 1;
}
my @sorted = sort(@strings);
my @output = `./bf-greedy.pl @sorted`;
die "bitfield mismatch"
if $output[0] !~ /@sorted$/;
print $output[0];
}
This produces the following type of output.
***1+*000+1010+0110-0101-1011 [6] 0000 0001 0011 0110 0111 1000 1001 1010 1101 1111
**11+*110+1000+0100+0001+1101 [6] 0001 0011 0100 0110 0111 1000 1011 1101 1110 1111
Finally, compare the greedy algorithm to the dynamic programming one with this script. (This presupposes that you have saved the DP algorithm as bf.pl and the greedy one as bf-greedy.pl)
#! /usr/bin/perl -w
#
my $width = shift || 3;
open ALL, "./bf.pl $width|";
while(my $line = <ALL>){
chomp $line;
if($line =~ /\{(.+)\}/){
my @args = split(/,\s+/, $1);
print $line . " ";
my @output = `./bf-greedy.pl @args`;
$line =~ /(\S+)$/; my $rx1 = $1;
$output[0] =~ /^(\S+)/; my $rx2 = $1;
chomp $output[0];
die "computation error"
if $output[0] !~ /@args$/;
print $output[0] . " " .
(length($rx1)>=length($rx2) ?
"SUCC" : "FAIL") . " " .
((length($rx1)+1)/(1+$width)) . " " .
((length($rx2)+1)/(1+$width)) . " " .
"\n";
}
}
close ALL;
