XP is just a number PerlMonks

### Comment on

 Need Help??

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 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 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

In reply to Re: Bag uniform distribution algorithms by hdb
in thread Bag uniform distribution algorithms by davido

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":

• Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
• Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
• Read Where should I post X? if you're not absolutely sure you're posting in the right place.
• Posts may use any of the Perl Monks Approved HTML tags:
a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
• You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
 For: Use: & & < < > > [ [ ] ]
• Link using PerlMonks shortcuts! What shortcuts can I use for linking?

Create A New User
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (7)
As of 2018-06-22 17:30 GMT
Sections?
Information?
Find Nodes?
Leftovers?
Voting Booth?
Should cpanminus be part of the standard Perl release?

Results (124 votes). Check out past polls.

Notices?