Created
April 15, 2022 15:44
-
-
Save Gro-Tsen/4c5c6eda84a7d7e503bc119a188c9d63 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
A>B>C>D: 00.00% | |
A>B>D>C: 05.60% | |
A>C>B>D: 06.80% | |
A>C>D>B: 07.00% | |
A>D>B>C: 01.50% | |
A>D>C>B: 06.30% | |
B>A>C>D: 04.40% | |
B>A>D>C: 06.70% | |
B>C>A>D: 02.30% | |
B>C>D>A: 06.60% | |
B>D>A>C: 00.00% | |
B>D>C>A: 05.50% | |
C>A>B>D: 01.10% | |
C>A>D>B: 00.00% | |
C>B>A>D: 07.10% | |
C>B>D>A: 04.30% | |
C>D>A>B: 03.90% | |
C>D>B>A: 05.00% | |
D>A>B>C: 05.00% | |
D>A>C>B: 00.00% | |
D>B>A>C: 06.30% | |
D>B>C>A: 04.10% | |
D>C>A>B: 03.70% | |
D>C>B>A: 06.80% |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
A>B>C>D: 00.00% | |
A>B>D>C: 07.70% | |
A>C>B>D: 03.70% | |
A>C>D>B: 04.60% | |
A>D>B>C: 04.00% | |
A>D>C>B: 08.70% | |
B>A>C>D: 01.50% | |
B>A>D>C: 03.50% | |
B>C>A>D: 05.90% | |
B>C>D>A: 01.70% | |
B>D>A>C: 03.30% | |
B>D>C>A: 06.70% | |
C>A>B>D: 03.50% | |
C>A>D>B: 00.00% | |
C>B>A>D: 09.00% | |
C>B>D>A: 01.30% | |
C>D>A>B: 07.00% | |
C>D>B>A: 06.00% | |
D>A>B>C: 03.50% | |
D>A>C>B: 03.10% | |
D>B>A>C: 04.20% | |
D>B>C>A: 06.00% | |
D>C>A>B: 01.50% | |
D>C>B>A: 03.60% |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#! /usr/local/bin/perl -w | |
## See <URL: https://mathoverflow.net/questions/420356/recursive-runoff-voting-schemes > | |
## and <URL: https://twitter.com/gro_tsen/status/1514593018552143876 > | |
## This script draws a random distribution of orders of preferences | |
## among N candidates, and then elects a candidate using the voting | |
## schemes defined above for various runoff depths k from 0 (which is | |
## just fptp voting) to 7. | |
use strict; | |
use warnings; | |
use Getopt::Std; | |
## Options are: | |
## -c <list>: use this comma-separated list of candidate names (mandatory) | |
## -r <file>: read votes from this file (format the same as produced by -w) | |
## (otherwise, will be randomly-generated) | |
## -w <file>: write votes to this file | |
my %opts; | |
getopts("c:r:w:", \%opts); | |
unless ( defined($opts{c}) ) { | |
die "please pass -c option with comma-separated list of candidate names"; | |
} | |
my @candnames = split /\,/, $opts{c}; | |
my $nbcandidates = scalar(@candnames); | |
## Generate a table of all permutations of 0..$nbcandidates-1: | |
my @permtab; | |
my @ordernames; | |
my %revorderhash; | |
sub genperms { | |
my @t = (); | |
my $i = 0; | |
genloop: | |
while ( 1 ) { | |
if ( $i >= $nbcandidates ) { | |
if ( scalar(@t) == 0 ) { | |
last genloop; | |
} | |
$i = pop @t; | |
$i++; | |
next genloop; | |
} | |
for ( my $j=0 ; $j<scalar(@t) ; $j++ ) { | |
if ( $i == $t[$j] ) { | |
$i++; | |
next genloop; | |
} | |
} | |
push @t, $i; | |
if ( scalar(@t) >= $nbcandidates ) { | |
my $order = join(">",map {$candnames[$_]} @t); | |
$ordernames[scalar(@permtab)] = $order; | |
die "the universe has collapsed" if defined($revorderhash{$order}); | |
$revorderhash{$order} = scalar(@permtab); | |
push @permtab, [ @t ]; # Copy! | |
pop @t; | |
$i++; | |
} else { | |
$i = 0; | |
} | |
} | |
} | |
genperms; | |
my @votetab; # Shared global variable with voting results | |
## Generate random distribution of preferences and store it in @votetab. | |
sub randomvote { | |
@votetab = (); | |
my $sum = 0; | |
for ( my $p=0 ; $p<scalar(@permtab) ; $p++ ) { | |
my $val = rand(); | |
push @votetab, $val; | |
$sum += $val; | |
} | |
# Normalize: | |
for ( my $p=0 ; $p<scalar(@permtab) ; $p++ ) { | |
$votetab[$p] /= $sum; | |
} | |
} | |
## Read distribution from a file. | |
sub readvote { | |
my $inf = shift; | |
@votetab = (); | |
my $sum = 0; | |
while (<$inf>) { | |
die "bad input format" unless m/^([^\s\:]+)\:\s*([0-9]*(?:\.[0-9]+)?|[0-9]+(?:\.[0-9]*)?)\%?/; | |
my $order = $1; | |
my $val = $2 + 0; | |
die "bad permutation $order" unless defined($revorderhash{$order}); | |
my $p = $revorderhash{$order}; | |
die "duplicate line $order" if defined($votetab[$p]); | |
$votetab[$p] = $val; | |
$sum += $val; | |
} | |
die "no votes" if $sum <= 0; | |
# Normalize: | |
for ( my $p=0 ; $p<scalar(@permtab) ; $p++ ) { | |
$votetab[$p] = 0 unless defined($votetab[$p]); | |
$votetab[$p] /= $sum; | |
} | |
} | |
## Write distribution to a file. | |
sub writevote { | |
my $outf = shift; | |
for ( my $p=0 ; $p<scalar(@permtab) ; $p++ ) { | |
printf $outf "%s: %05.2f%%\n", $ordernames[$p], $votetab[$p]*100; | |
} | |
} | |
my $warned_equality; | |
## The lowest recursion step (perform a simple fptp vote), possibly | |
## excluding some candidates, and possibly inverted in one or two ways: | |
## - simplevote(0,0) returns the candidate having the MOST TOP votes, | |
## i.e., the "best" (most liked) candidate | |
## - simplevote(1,0) returns the candidate having the LEAST BOTTOM votes | |
## i.e., the "dual best" (least disliked) candidate | |
## - simplevote(0,1) returns the candidate having the LEAST TOP votes, | |
## i.e., the "worst" (least liked) candidate | |
## - simplevote(1,1) returns the candidate having the MOST BOTTOM votes | |
## i.e., the "dual worst" (most disliked) candidate | |
sub simplevote { | |
my $revorder = !!shift; # Whether to reverse individual preferences | |
my $worst = !!shift; # Whether to find worst candidate | |
my $minimize = $revorder^$worst; # Whether to minimize votes | |
my $excl = shift || {}; # Ignore these candidates when sorting | |
# First, tally the number of (top or bottom) votes for each candidate: | |
my @stats = (); | |
for ( my $p=0 ; $p<scalar(@permtab) ; $p++ ) { | |
candloop: | |
for ( my $j=0 ; $j<$nbcandidates ; $j++ ) { | |
# Loop through candidates in appropriate order | |
my $i = $revorder ? $permtab[$p][$nbcandidates-1-$j] : $permtab[$p][$j]; | |
# Stop at first non-excluded | |
if ( ! $excl->{$i} ) { | |
$stats[$i] += $votetab[$p]; | |
last candloop; | |
} | |
} | |
} | |
# Now find the candidate with the best (or worst) tally: | |
my $besti = -1; | |
my $also_besti = -1; | |
my $bests = $minimize ? 2 : -1; | |
for ( my $i=0 ; $i<$nbcandidates ; $i++ ) { | |
if ( ( ! $excl->{$i} ) && ( $minimize ? $stats[$i] <= $bests : $stats[$i] >= $bests ) ) { | |
$besti = $i unless $stats[$i] == $bests; | |
$also_besti = $i; | |
$bests = $stats[$i]; | |
} | |
} | |
if ( $besti != $also_besti && ! $warned_equality ) { | |
my $excllist = join(",",map {$candnames[$_]} (keys(%{$excl}))); | |
$excllist = "<nobody>" if $excllist eq ""; | |
printf STDERR "warning: exact equality between candidates %s and %s at %05.2f%% when excluding %s\n", $candnames[$besti], $candnames[$also_besti], $bests*100, $excllist; | |
$warned_equality = 1; | |
} | |
return $worst ? $also_besti : $besti; | |
} | |
## The general recursive voting scheme: at level 0 this simply calls | |
## simplevote above (with the same parameters). At higher level k, | |
## this excludes candidates using the same function at level k-1 but | |
## with the "worst" parameter flipped, eliminating them one by one | |
## until only one is left standing, and return that one. | |
sub recursive_vote { | |
my $level = shift; | |
my $revorder = !!shift; # Whether to reverse individual preferences | |
my $worst = !!shift; # Whether to find worst candidate | |
my $excl = shift || {}; # Ignore these candidates when sorting | |
if ( $level <= 0 ) { | |
return simplevote($revorder, $worst, $excl); | |
} | |
my $lastexcl = -1; | |
my @excltab; | |
while ( 1 ) { | |
my $newexcl = recursive_vote($level-1, $revorder, !$worst, $excl); | |
if ( $newexcl == -1 ) { | |
foreach my $i ( @excltab ) { | |
$excl->{$i} = undef; | |
} | |
return $lastexcl; | |
} else { | |
die "this is impossible" if $excl->{$newexcl}; | |
push @excltab, $newexcl; | |
$lastexcl = $newexcl; | |
$excl->{$newexcl} = 1; | |
} | |
} | |
} | |
# mainloop: | |
# while ( 1 ) { | |
if ( defined($opts{"r"}) ) { | |
my $fname = $opts{"r"} // "-"; | |
if ( $fname eq "-" ) { | |
readvote \*STDIN; | |
} else { | |
open my $inf, "<", $fname or die "can't open $fname for reading: $!"; | |
readvote $inf; | |
close $inf; | |
} | |
} else { | |
randomvote; | |
} | |
if ( defined($opts{"w"}) ) { | |
my $fname = $opts{"w"} // "-"; | |
if ( $fname eq "-" ) { | |
writevote \*STDOUT; | |
} else { | |
open my $outf, ">", $fname or die "can't open $fname for writing: $!"; | |
writevote $outf; | |
close $outf; | |
} | |
} | |
for ( my $level=0 ; $level<8 ; $level++ ) { | |
printf "best level %d candidate: %s; dual: %s\n", $level, $candnames[recursive_vote($level,0,0)], $candnames[recursive_vote($level,1,0)]; | |
} | |
# my %elected = (); | |
# my @elected = (); | |
# for ( my $level=0 ; $level<6 ; $level++ ) { | |
# my $elected = recursive_vote($level,0,0); | |
# push @elected, $elected; | |
# $elected{$elected} = $level; | |
# } | |
# if ( scalar(%elected) >= 4 && $elected[5]==$elected[4] ) { | |
# for ( my $level=0 ; $level<6 ; $level++ ) { | |
# printf "best level %d candidate: %d; dual: %d\n", $level, $elected[$level], recursive_vote($level,1,0); | |
# } | |
# last mainloop; | |
# } | |
# } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
See https://mathoverflow.net/questions/420356/recursive-runoff-voting-schemes and https://twitter.com/gro_tsen/status/1514593018552143876 and https://twitter.com/gro_tsen/status/1514998645581619208 for explanations as to what this is all about.