Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

Perlocracy

by QuillMeantTen (Friar)
on Apr 10, 2016 at 18:04 UTC ( #1160055=CUFP: print w/replies, xml ) Need Help??

As older and wiser monks mill around the courtyard, no one wonders about the lack of news from young Quill. Last time he was seen he got a well deserved beating for tempting those who lack in wisdom with tools beyond their understanding that could easily be made to wreck havoc on their home networks.

So, even if his arrival is of no surprise, his cries of
I REKT IT!
prove challenging to ignore and disturb many an elder from their own medidations.

Fast enough, one of those whose deep thoughts got interrupted ask him:
"you rekt what?"
"Exactly, EUREKA, that's it!" answers the feverish apprentice.

As more monks come to the courtyard he begins to expose his latest idea...


After spending long hours reflecting on the foolishness of my misdeeds and how providing script kiddies with weapons is the most desecrating act one could perpetrate inside those holy walls, I found something even more subversive and potentially destructive.

Some of you, if interested in voting methods might have heard about condorcet methods. I for one think that those are way better than the currently used one. And I have my favorite. Mam or Maximize Affirmed Majorities, aka MTM (minimize thwarted minorities) can be considered a variant of the Tideman method. Once I started reading about it I wanted to use it and tell others about it.

As many of you know by now when I get my eyes and mind on an algorithm I can not rest until I have implemented it myself to try and understand it as completely as possible.


Today I give you a small script that implements the MAM voting procedure, you can use it to simulate elections with as many ballots as you want or to run it on ballots you may have collected, just put votes in text files with a .bt extension.


Say you have 6 candidates, a possible ballot could be:

1 3 2,4
Meaning, you wish one to win, if not one then three, if three does not win you dont care whether 2 or 4 win. Any candidates left out of a ballot are considered equally ranked at the bottom. Hence this ballot is equivalent to:
1 3 2,4 5,6


Update:Patched the code for eventualities that did not happen during testing:
  1. no one ranks two candidates strictly, then complete the tiebreak from a randomly generated strict ballot
  2. Make tiebreaking rules conform so if the two majorities concern the same winner then the loser will be compared using the tiebreak
  3. Make majorities calculation output two different majorities in case of 1 vs 2 has same votes as 2 vs 1 and let the tiebreak mechanism do its work
  4. patch bug in majorities calculation where < and = would be treated the same way
  5. Now allows for any number of candidate (regex \d limited it to 9)
  6. To allow result comparison I added the schulze voting method, now accessible with the -s option
  7. Fixed a typo causing a miscalculation when in shulze mode
So here is the code, I hope you'll have as much fun using it as I had writing it! Cheers :-)

#!/usr/bin/perl use strict; use warnings; use autodie; use Data::Dumper; use List::Util qw(shuffle); use List::MoreUtils qw(firstidx); use Getopt::Long; sub del_ballots{ for my $f(glob("*.bt")){ unlink $f; } } sub make_ballots{ my ($nb,$nbc) = @_; my @candidates; my $same_rank = ""; my $j = 0; for my $i (1..$nbc){ $candidates[$j] = $i; $j++; } my $more_to_come = 0; for my $i (0 .. $nb){ my @ballot = shuffle(@candidates); open(my $fh, '>',$i.".bt"); foreach my $i ( 0..$#ballot){ my $c = $ballot[$i]; my $line_end = "\n"; if(int(rand(6)) == 0 && !$more_to_come){#leave all other c +andidates out last; } elsif(int(rand(2)) == 0 && $i < $#ballot){#put one or more + candidate on this row $line_end = ","; $more_to_come = 1; print $fh $c.$line_end; } else{ $more_to_come = 0; print $fh $c.$line_end; } } close($fh); } } sub rand_tiebreak_set{ our @tiebreak; my ($cand_ref,$votes) = @_; my @ballot = shuffle(@{$cand_ref}); update_tiebreak(\@ballot,$votes); } sub enumerate{ my $candidates = shift; my $votehash = {}; foreach my $c(@$candidates){ foreach my $d(@$candidates){ if($c != $d){ $votehash->{$c}->{$d} = 0; } } } return $votehash; } sub vote_against_below{ my ($startidx,$cv,$votes,$candidate) = @_; my $c = $candidate; my @curvote = @{$cv}; for my $j($startidx .. $#curvote){ #if on the lines below I encounter multiple candidates #I count a vote against all of them if($curvote[$j] =~ /^\d+\s?,\s?\d+/){ my @losers = split /,/,$curvote[$j]; foreach my $l (@losers){ $votes->{$c}->{$l}++; } } #if it is a normal case then I deal with it else{ $votes->{$c}->{$curvote[$j]}++; } } } sub readfile{ my ($votes,$fh) = @_; my $i = 0; my @curvote; #prepare a hash to check for left out candidates my %seen; my @keys = keys %{$votes}; foreach my $k (@keys){ $seen{$k} = 0; } while(<$fh>){ chomp $_; $curvote[$i] = $_; if($curvote[$i] =~ /\A\d+\s?,\s?/){ my @votes = split /\s?,\s?/, $curvote[$i]; foreach my $v(@votes){ $seen{$v} = 1; } } else{ $seen{$curvote[$i]} = 1; } $i++; } #all candidates left out of the ballot are accounted for as if the +y #were added together at the lowest possible position my $leftovers = ""; foreach my $k (@keys){ if(!$seen{$k}){ if($leftovers =~ /\d+\z/){ $leftovers = $leftovers . ",$k"; } else{#leftovers is empty $leftovers = $k; } } } if($leftovers ne ""){ $curvote[$i] = $leftovers; } for my $i (0 .. $#curvote){ my @candidates; if($curvote[$i] =~ /^\d+\s?,\s?\d+/){#more than one candidate +on this line #I split the candidate list into an array @candidates = split /\s?,\s?/,$curvote[$i]; #foreach candidate in the list I count one vote for him #against everyone below him foreach my $c (@candidates){ vote_against_below($i+1,\@curvote,$votes,$c); } } else{ vote_against_below($i+1,\@curvote,$votes,$curvote[$i]); } our $tiebreak_ready; if(!$tiebreak_ready){ update_tiebreak(\@curvote,$votes); } } } sub update_tiebreak{ my ($cv,$votes)= @_; my @curvote = @{$cv}; our( @tiebreak,$tiebreak_ready); if(!@tiebreak){#empty tiebreak foreach my $v (@curvote){ push @tiebreak,$v; } } elsif(!$tiebreak_ready){ foreach my $v (@curvote){ if($v =~ /\d+\s?,\s?\d+/){ next; #curvote alreay has a tie } else{ foreach my $t (@tiebreak){ if($t =~ /\d+\s?,\s?\d+/){ my @candidates = split /\s?,\s?/, $t; my $chosen_idx = firstidx {$_ == $v} @candidat +es; if($chosen_idx == -1){ #can not solve, untied vote no in tie next; } my $curpos = firstidx {$_ =~ /$t/} @tiebreak; #current position of the tie inside the tiebre +ak #I get the index of the one not in the tie my $split_candidate = $candidates[$chosen_idx] +; my $idx = firstidx {$_ =~ /$split_candidate/} +@curvote; #remove split candidate splice @candidates, $chosen_idx,1; my $new_tie = join(',',@candidates); if(is_updown($split_candidate,\@candidates,\@c +urvote,0,1)){ #our split is before every other tied cand +idate in #curvote tiebreak_replace(\@tiebreak,$split_candida +te,$new_tie,$curpos); } elsif(is_updown($split_candidate,\@candidates, +\@curvote,0,0)){ tiebreak_replace(\@tiebreak,$new_tie,$spli +t_candidate,$curpos); } } } } } } my @cdt = keys %{$votes}; $tiebreak_ready = $#tiebreak == $#cdt;#ready when we have #one candidate per line } sub is_updown{ my ($split_candidate,$candidates,$curvote,$idx,$dir) = @_; if($idx > $#$candidates){ return 1; } my $split_idx = firstidx {$_ =~ /$split_candidate/} @$curvote; my $nextidx = firstidx {$_ =~ /$candidates->[$idx]/} @$curvote; if($dir == 1){#check above in the order if($split_idx < $nextidx){ return is_updown($split_candidate,$candidates,$curvote,$idx+1,$di +r); } else{ return 0; } } else{#check below if($split_idx < $nextidx){ return is_updown($split_candidate,$candidates,$curvote,$idx+1,$di +r); } else{ return 0; } } } sub tiebreak_replace{ my ($tiebreak, $cd1,$cd2,$curpos) = @_; splice @{$tiebreak},$curpos,1,($cd1,$cd2); } sub calculate_majorities{ my $votes = shift; my @candidates = keys %$votes; my @majorities; my %done; my $n = 0; for my $i (0 .. $#candidates){ for my $j (0 .. $#candidates){ my $c1 = $candidates[$i]; my $c2 = $candidates[$j]; if($c1 != $c2 && !exists($done{$c1}{$c2}) && !exists($done +{$c2}{$c1})){ $done{$c1}{$c2} = 1; my $fori = $votes->{$c1}->{$c2}; my $forj = $votes->{$c2}->{$c1}; if($fori > $forj){ $majorities[$n] = {$c1=>{$c2 => $fori,'min'=>$forj +}}; } elsif($fori < $forj){ $majorities[$n] = {$c2=>{$c1 => $forj,'min'=>$fori +}}; } else{#record both and let the tiebreak + do his #job $majorities[$n] = {$c2=>{$c1 => $forj,'min'=>$fori +}}; $n++; $majorities[$n] = {$c1=>{$c2 => $fori,'min'=>$forj +}}; } $n++; } } } return \@majorities; } sub get_loser{ my $hash = shift; foreach my $k (keys %$hash){ if ($k ne 'min'){ return $k; } } } sub affirm{ my($winner,$loser,$finishOver) = @_; $finishOver->{$winner}->{$loser} = 1; my @candidates = keys %$finishOver; foreach my $c (@candidates){ if($c == $winner || $c == $loser){ next; } if($finishOver->{$c}->{$winner} == 1 && $finishOver->{$c}->{$l +oser} == 0){ affirm($c,$loser,$finishOver); } if($finishOver->{$loser}->{$c} == 1 && $finishOver->{$winner}- +>{$c} == 0){ affirm($winner,$c,$finishOver); } } } sub win_order{ my ($majorities,$candidates) = @_; my @maj = @{$majorities}; my $k = 0; my $finishOver = enumerate($candidates); foreach my $m (@$majorities){ my $winner = (keys %$m)[0]; my $loser = get_loser($m->{$winner});; if($finishOver->{$winner}->{$loser} == 0 && $finishOver->{$los +er}->{$winner} == 0){ affirm($winner,$loser,$finishOver); } } return $finishOver; } sub getsubkeys{ my($a,$b) = @_;#get one keyed/subkeyed hashs my ($a_key,$a_subkey,$b_key,$b_subkey); if(defined($a)){ my @keys = keys %{$a}; $a_key = $keys[firstidx {$_ ne 'min'} @keys]; @keys = keys %{$a->{$a_key}}; $a_subkey = $keys[firstidx {$_ ne 'min'} @keys]; if(defined($b)){ @keys = keys %{$b}; $b_key = $keys[firstidx {$_ ne 'min'} @keys]; @keys = keys %{$b->{$b_key}}; $b_subkey = $keys[firstidx {$_ ne 'min'} @keys]; return ($a_key,$a_subkey,$b_key,$b_subkey); } return ($a_key,$a_subkey); } elsif(!defined($a) && !defined($b)){ die("get subkeys takes at least one arg\n"); } } sub majsort{ my ($a_key,$a_subkey,$b_key,$b_subkey) = getsubkeys($a,$b); my $aval = $a->{$a_key}->{$a_subkey}; my $bval = $b->{$b_key}->{$b_subkey}; if($aval < $bval){ return 1; } elsif($aval == $bval){ my $amin = $a->{$a_key}->{min}; my $bmin = $b->{$b_key}->{min}; #here check for the minority size rule in case of equality #the majority opposed by the smallest minority has precedence print STDERR "solving $a_key -> $a_subkey vs $b_key -> + $b_subkey using minority rules\n"; if($amin > $bmin) { return 1; } elsif($amin < $bmin){ return -1; } else{ #use tiebreak our @tiebreak; my $indb = firstidx {$_ == $a_key} @tiebreak; my $inda =firstidx {$_ == $b_key} @tiebreak; print STDERR "solving using tiebreak for $a_key vs $a_subk +ey and $b_key vs $b_subkey\n"; if($inda < $indb){ return 1; } elsif($inda == $indb){ my $indb = firstidx {$_ == $a_subkey} @tiebreak; my $inda =firstidx {$_ == $b_subkey} @tiebreak; if($inda < $indb){ return 1; } else{ return -1; } } else{ return -1; } } } else{ return -1; } } sub scoresort{ my $a_score = (keys %$a)[0]; my $b_score = (keys %$b)[0]; if( $b->{$b_score}->{score} < $a->{$a_score}->{score}){ return -1; } elsif($b->{$b_score}->{score} == $a->{$a_score}->{score}){ our @tiebreak; my $idx_a = firstidx {$_ == $a->{$a_score}->{self}} @tiebr +eak; my $idx_b = firstidx {$_ == $b->{$b_score}->{self}} @tiebr +eak; if($idx_a < $idx_b){ return -1; } else{ return 1; } } else{ return 1; } } sub relook{ my $finishOrder = shift; my @candidates = keys %$finishOrder; my @tmp_results; foreach my $c (@candidates){ my $score = 0; foreach my $adv (keys %{$finishOrder->{$c}}){ $score += $finishOrder->{$c}->{$adv}; } push @tmp_results, {$c => {score=>$score,self=>$c}}; } @tmp_results = sort scoresort @tmp_results; my @results; foreach my $r (@tmp_results){ my $candidate = (keys %$r)[0]; push @results, $candidate; } return \@results; } sub getdistance{ my $votes = shift; my @candidates = keys %$votes; my @distances; foreach my $c (@candidates){ foreach my $a(@candidates){ if($a != $c){ $distances[$c][$a] = $votes->{$c}->{$a}; $distances[$a][$c] = $votes->{$a}->{$c}; } } } return \@distances; } sub max{ my($x,$y) = @_; if($x > $y){ return $x; } else{ return $y; } } sub min{ my($x,$y) = @_; if($x < $y){ return $x; } else{ return $y; } } sub compute_path{ my $distances = shift; print STDERR "I have $#$distances candidates\n"; my @path; for my $i (1 .. $#$distances){ for my $j (1 .. $#$distances){ if($i != $j){ print STDERR "distance for $i and $j = $distances->[$i +][$j]\n reverse $j $i = $distances->[$j][$i]\n"; if($distances->[$i][$j] > $distances->[$j][$i]){ $path[$i][$j]= $distances->[$i][$j]; } else{ $path[$i][$j]=0; } } } } print STDERR "paths state before compute:\n".Dumper(\@path); for my $i (1..$#$distances){ for my $j (1..$#$distances){ for my $k (1..$#$distances){ if($i != $j){ if($i != $k && $j != $k){ $path[$j][$k] = max($path[$j][$k],min($path[$j][$i],$path[$i][ +$k])); } } } } } return \@path; } sub shulze_winner{ my $path = shift; my %results; for my $i(1 .. $#$path){ for my $j (1 .. $#$path){ if($i != $j){ $results{$i}->{$j} = $path->[$i][$j]; } } } print STDERR "schulze winner hash = \n".Dumper(\%results); return \%results; } sub main{ my ($nbc,$schulze) = @_; my @candidates; my $j = 0; my $finish_table; for my $i (1..$nbc){ $candidates[$j] = $i; $j++; print "adding candidate $i\n"; } my $hash = enumerate(\@candidates); my @files = shuffle(glob("*.bt")); foreach my $f (@files){ open(my $fh,'<',$f); readfile($hash,$fh); close($fh); } our $tiebreak_ready; if(!$tiebreak_ready){ print STDERR "autocompleting tiebreaker with strict random + ballot\n"; rand_tiebreak_set(\@candidates,$hash); } if(!defined($schulze)){ my @maj = @{calculate_majorities($hash)}; @maj = sort majsort @maj; print STDERR "majorities list:\n".Dumper(\@maj); my $finish_order = win_order(\@maj,\@candidates); $finish_table = relook($finish_order); print STDERR "Finish order:\n".Dumper($finish_order); } else{ my $distances = getdistance($hash); print STDERR "distances:\n\n".Dumper($distances); my $strongest_path = compute_path($distances); print STDERR "paths:\n".Dumper($strongest_path); $finish_table = relook(shulze_winner($strongest_path)); } our @tiebreak; print STDERR "Tiebreak:\n"; foreach my $t (@tiebreak){ print STDERR "$t\n"; } print "Here is the win order:\n"; for my $i (0 .. $#$finish_table){ print "$finish_table->[$i]\n"; } } Getopt::Long::Configure ("bundling"); our @tiebreak; our $tiebreak_ready = 0; my($autogen,$delete,$schulze,$candidates,$help); GetOptions("autogen|a=i" => \$autogen, "delete|d" => \$delete, "candidates|c=i" =>\$candidates, "help|h" =>\$help, "schulze|s"=>\$schulze) or exit; if(defined($help)||!defined($candidates)){ print "to run a voting simulation with randomly generated ballots: +\n"; print "./mam.pl --(autogen|a) number_of_generated_ballots --(candi +dates|c) number_of_candidates\n\n"; print "--delete option will remove all .bt files in the same direc +tory after computation\n"; print "--schulze|s will use the schulze method to compute the +winning order\n\n\n"; print "candidate option is obligatory\n"; exit; } if(defined($autogen)){ make_ballots($autogen,$candidates); } main($candidates,$schulze); if(defined($delete)){ del_ballots; }

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://1160055]
Approved by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (3)
As of 2022-05-25 04:48 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Do you prefer to work remotely?



    Results (84 votes). Check out past polls.

    Notices?