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", "Better:lower", "Result"; print "------------------------------------------------------------\n\n"; for my \$bag (@\$bags) { print "bag: "; print join ", ", map { +"\$_ => ".\$bag->{\$_} } sort keys %\$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 ); #### Monk Better:higher Better:lower Result ------------------------------------------------------------ bag: A => 4, B => 2, C => 3, D => 1 BrowserUK 24.41 0.45 ACBADCBACA hdb 25.72 0.37 ACBADCABCA kcott 25.72 0.37 ACBACDABCA kennethk 25.72 0.37 ACBADCABCA bag: A => 4, B => 2, C => 3, D => 1, F => 2, G => 4, H => 2, I => 30 BrowserUK 866.39 2.67 IIIIIIGAICIIIFBHIGIAIICDIIGIIAFBHIIICGIIIAIIIIII hdb 1178.43 0.94 IAIIGIICIFIIBIAIIGIIHIDIICIFIIAIIGIBIIHICIIAIIGI kcott 893.56 2.31 IIIIIIAGIICIIIBHFIAGIIIIDCIIGAIFHBIIICIIGAIIIIII kennethk 1283.68 0.78 IIGIAICIIHIIBIFIIGIAIIDIICIIGIAIIHIIBIFIICIGIAII bag: A => 10, B => 10, C => 10 BrowserUK 74.25 22.44 CBCBCBCBCBCBCBCBCBCBAAAAAAAAAA hdb 222.75 0.44 ACBACBACBACBACBACBACBACBACBACB kcott 224.75 0.44 ABCABCABCABCABCCBACBACBACBACBA kennethk 222.75 0.44 CBACBACBACBACBACBACBACBACBACBA