Re: Bag uniform distribution algorithms

by hdb (Monsignor)
 on Apr 26, 2013 at 09:16 UTC ( #1030796=note: print w/replies, xml ) Need Help??

in reply to Bag uniform distribution algorithms

Evaluation is key for this question. In addition to kennethk's score function I think the cumulative variance of positions is an appropriate measure. For the variance, a large value is good.

```use strict;
use warnings;
use Math::Round;
use Statistics::Basic qw(:all);
use List::Util 'sum';

sub dispersion {
my %p;
my \$pos = 0;
push @{\$p{\$_}}, \$pos++ while \$_ = shift;
my \$var = 0;
\$var += variance( \$p{\$_} ) for ( keys %p );
return \$var;
}

sub measure {
my @series = @_;
my %count;
\$count{\$_}++ for @series;
my \$norm = sum values %count;
\$_ /= \$norm for values %count;
my %score = %count;

my \$metric = 0;
for my \$elem (@series) {
\$score{\$elem} -= 1;
for (keys %score) {
\$metric += \$score{\$_}**2;
\$score{\$_} += \$count{\$_};
}
}

return \$metric/@series;
}

```sub mix {
my \$bag = shift;
my @str = sort { \$bag->{\$a} <=> \$bag->{\$b} } keys %\$bag;
my \$list = "";
while( @str ) {
my \$tbi = shift @str;
my \$count = \$bag->{\$tbi};
\$tbi .= shift @str    while( @str and \$bag->{\$str[0]}
+== \$count );
my \$l = length \$list;
if( !\$l ) {
\$list = \$tbi x \$count;
} else {
for my \$pos ( reverse 0..\$count-1 ) {
substr( \$list, round(\$pos / (\$count-1)
+ * \$l), 0 ) = \$tbi ;
}
}
}
my @series = split '', \$list;
return \@series;
}

sub gen { # kennethk
my \$href = shift;
my %score = %\$href;
my \$norm = sum values %score;
my @series;

for (1 .. \$norm) {
my (\$max, \$elem) = 0;
for (keys %score) {
(\$max, \$elem) = (\$score{\$_}, \$_) if \$score{\$_} >= \$max;
\$score{\$_} += \$href->{\$_};
}
push @series, \$elem;
\$score{\$elem} -= \$norm;
}

return \@series;
}

sub genUK { # BrowserUK
my \$href = shift;
my @kByV = sort{ \$href->{ \$b } <=> \$href->{ \$a } } keys %\$href;
my @dist = ( \$kByV[0] ) x \$href->{ \$kByV[0] };
shift @kByV;
while( @kByV ) {
my \$k = shift @kByV;
my \$v = \$href->{ \$k };
my \$n = int( @dist / ( \$v+1 ) );
my \$p = \$n * \$v;
splice( @dist, \$p, 0, \$k ), \$p -= \$n for reverse 1 .. \$v;
}
return \@dist;
}

sub kcott {
my \$bagref = shift;
my %bag = %\$bagref;
my @distribution;

for my \$key (sort { \$bag{\$b} <=> \$bag{\$a} } keys %bag) {
my \$base_offset = int(@distribution / (\$bag{\$key} + 1) + 0.5);
+
my \$offset = \$base_offset;

for (1 .. \$bag{\$key}) {
next unless \$_ % 2;
splice @distribution, \$offset, 0, \$key;

if (\$_ < \$bag{\$key}) {
splice @distribution, -\$offset, 0, \$key;
}

\$offset += \$base_offset + 1;
}
}

return \@distribution;
}

```sub evaluate {
my \$cand   = shift;
my \$bags   = shift;
printf "\n%20s %15s %15s %s\n", "Monk", "Better:higher", "Bett
+er:lower", "Result";
print "-------------------------------------------------------
+-----\n\n";
for my \$bag (@\$bags) {
print "bag: ";
print join ", ", map { +"\$_ => ".\$bag->{\$_} } sort key
+s %\$bag ;
print "\n\n";
for my \$monk ( sort keys %\$cand ) {
my \$result = \$cand->{\$monk}->(\$bag);
my \$disp   = dispersion( @\$result );
my \$score  = measure( @\$result );
printf "%20s %15.2f %15.2f %s\n", \$monk, \$disp
+, \$score, join "", @\$result;
}
print "\n";
}
}

my \$bags = [
{ A => 4, B => 2, C => 3, D => 1, },
{ A => 4, B => 2, C => 3, D => 1, F => 2, G => 4, H=> 2, I=>30
+ },
{ A => 10, B=> 10, C => 10, },
];

my \$candidates = { # sub expects hash ref and returns array ref
kennethk  => \&gen,
BrowserUK => \&genUK,
kcott     => \&kcott,
hdb       => \&mix,
};

evaluate( \$candidates, \$bags );

which gives the following output

```                Monk   Better:higher    Better:lower Result
------------------------------------------------------------

bag: A => 4, B => 2, C => 3, D => 1

kcott           25.72            0.37 ACBACDABCA

bag: A => 4, B => 2, C => 3, D => 1, F => 2, G => 4, H => 2, I => 30

BrowserUK          866.39            2.67 IIIIIIGAICIIIFBHI
+GIAIICDIIGIIAFBHIIICGIIIAIIIIII
hdb         1178.43            0.94 IAIIGIICIFIIBIAII
+GIIHIDIICIFIIAIIGIBIIHICIIAIIGI
kcott          893.56            2.31 IIIIIIAGIICIIIBHF
+IAGIIIIDCIIGAIFHBIIICIIGAIIIIII
kennethk         1283.68            0.78 IIGIAICIIHIIBIFII
+GIAIIDIICIIGIAIIHIIBIFIICIGIAII

bag: A => 10, B => 10, C => 10

BrowserUK           74.25           22.44 CBCBCBCBCBCBCBCBC
+BCBAAAAAAAAAA
hdb          222.75            0.44 ACBACBACBACBACBAC
+BACBACBACBACB
kcott          224.75            0.44 ABCABCABCABCABCCB
+ACBACBACBACBA
kennethk          222.75            0.44 CBACBACBACBACBACB
+ACBACBACBACBA

Create A New User
Node Status?
node history
Node Type: note [id://1030796]
help
Chatterbox?
NodeReaper puts the hammer down

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (11)
As of 2018-03-20 14:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
When I think of a mole I think of:

Results (253 votes). Check out past polls.

Notices?