cloneproof-ssd

Cloneproof Schwartz Sequential Dropping

This script is designed to calculate the winner of a Debian vote, using the Cloneproof Schwartz Sequential Dropping method. This is described in wikipedia as the Schulze method, and basically takes a list of preferences from voters, works out which options are preferred by a majority of the voters to which other options, and then resolves any cycles.

Anyway: boilerplate, first.

#!/usr/bin/perl -w

# Copyright (c) 2001, 2002 Anthony Towns <ajt@debian.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use strict;

Parse input

On stdin, we expect the processed votes, of the form:

V: -324-1

which is interpreted as rating the 6th option as your 1st preference, etc, and ranking the 1st and 5th options as equal last. Equal rankings are allowed and treated as expected, as is skipping a ranking.

Note that SPI's vote tabulation has in the past treated those as "unranked", and not expressing any preference between unranked options and ranked options. This code doesn't support that behaviour.

my %beats;   # number of votes preferring A to B == $beats{"$a $b"}
my $candidates = 0;

while(my $line = <>) {
    chomp $line;
    next unless ($line =~ m/^V: (\S+)\s*$/);
    my $vote = $1;
    $candidates = length($vote) unless ($candidates >= length($vote));
    for my $l (1..($candidates-1)) {
        for my $r (($l+1)..$candidates) {
            unless (defined $beats{"$l $r"}) {
                $beats{"$l $r"} = 0;
                $beats{"$r $l"} = 0;
            }

            my $L = substr($vote, $l-1, 1); $L=hex($L) unless $L eq "-";
            my $R = substr($vote, $r-1, 1); $R=hex($R) unless $R eq "-";

            $L = $candidates + 1 if ($L eq "-");
            $R = $candidates + 1 if ($R eq "-");

            if ($L < $R) {
                $beats{"$l $r"}++;
            } elsif ($R < $L) {
                $beats{"$r $l"}++;
            } else {
                # equally ranked, tsk tsk
            }
        }
    }
}

Determine defeats

We determine "defeats" based on how many votes ranked some candidate above another candidate. This is both to abbreviate some of the code later, and more importantly to allow us to easily drop defeats as part of the "sequential dropping".

my %defeat = ();

print "Calculating defeats\n";
for my $l (1..$candidates) {
    for my $r (1..$candidates) {
        next if ($l == $r);

        my $LR = $beats{"$l $r"};
        my $RL = $beats{"$r $l"};
        if ($LR > $RL) {
            $defeat{"$l $r"} = "$LR $RL";
        } elsif ($l < $r && $LR == $RL) {
            print "Exact tie between $l and $r : $LR $RL\n";
        }
    }
}
print "\n";

Cloneproof SSD Calculation

Finally we determine the winner according to Cloneproof SSD. The process is as follows:

  1. Calculate Schwartz set according to uneliminated defeats.
  2. If there are defeats amongst the Schwartz set, then eliminate the weakest defeat(s), and go back to 1.
  3. Otherwise, there are no defeats left amongst the Schwartz set!
  4. If there is only one member in the Schwartz set, it wins.
  5. Otherwise, there is a tie amongst the Schwatz set.

We do pretty verbose output, since this is meant for double-checking the vote results, not just figuring it out.

my $phase = 0;
while(1) {
    $phase++;
    print "Defeats at beginning of phase $phase:\n";
    for my $d (sort keys %defeat) {
        my ($l, $r) = split /\s+/, $d;
        print "    $l beats $r: $defeat{$d}\n";
    }

    my @schwartz = calculate_schwartz();
    print "Schwartz set: " . join(",", @schwartz) . "\n";

    my @schwartzdefeats = 
        grep { defined $defeat{$_} } crossproduct(@schwartz);

    if (!@schwartzdefeats) {
        print "No defeats left in Schwartz set!\n";
        if (@schwartz == 1) {
            print "Winner is: $schwartz[0]\n";
        } else {
            print "Tie amongst: " . join(", ", @schwartz) . "\n";
        }
        last;
    }

    my $weakest = (sort { defeatcmp($defeat{$a},$defeat{$b}) }
         @schwartzdefeats)[0];

    my $weakstrength = $defeat{$weakest};
    print "Weakest defeat amongst schwartz set is $weakstrength\n";

    for my $d (@schwartzdefeats) {
        die "Defeat weaker than weakest! $d, $weakstrength, $defeat{$d}" 
            if (defeatcmp($defeat{$d}, $weakstrength) < 0);
        if (defeatcmp($defeat{$d}, $weakstrength) == 0) {
            print "Removing defeat $d, $defeat{$d}\n";
            delete $defeat{$d};
        }
    }
    print "\n";
}

Subs

Okay, we cheated a bit there, just using crossproduct defeatcmp and calculateschwartz. Here's their definitions: 

sub crossproduct {
    my @l = @_;
    return map { my $k = $_; map { "$k $_" } @l } @l;
}

sub defeatcmp {
    my ($Awin, $Alose) = split /\s+/, shift;
    my ($Bwin, $Blose) = split /\s+/, shift;

    return 1 if ($Awin > $Bwin);
    return -1 if ($Awin < $Bwin);
    return 1 if ($Alose < $Blose);
    return -1 if ($Alose > $Blose);

    return 0;
}

Calculate Schwartz set

This is a bit complicated. Here's the theory.

We note that given two unbeaten subsets, S and T, either, then S^T (the intersection of sets S and T -- ie, the elements in both) is also unbeaten, so either S^T is empty, or S^T is a smaller unbeaten subset.

We can thus find a unique, smallest unbeaten set containing each candidate by a simple iterative method. This is findunbeatensuperset.

So given the smallest supersets for each candidate, we have all the smallest unbeaten subsets (since each one will be the smallest superset of any of its members). So, each set is either a proper superset of another set (and can thus be discarded), or it's a smallest unbeaten subset.

We eliminate the sets and then union the remainder (which are either equal or disjoint), and we've thus found the Schwartz set. This is done in calculate_schwartz.

sub find_unbeaten_superset {
    my @l = @_;
    for my $r (1..$candidates) {
        my $add = 1;
        for my $l (@l) {
            if ($l == $r) {
                $add = 0;
                next;
            }
        }
        next unless ($add);
        $add = 0;
        for my $l (@l) {
            if (defined $defeat{"$r $l"}) {
                $add = 1;
            }
        }
        if ($add) {
            return find_unbeaten_superset(@l, $r);
        }
    }
    return sort(@l);
}


sub is_subset {
    my @l = @{$_[0]};
    my @r = @{$_[1]};

    for my $x (@r) {
        last if (!@l);
        shift @l if ($l[0] == $x);
    }

    return !@l;
}


sub calculate_schwartz {
    my @schwartz = ();
    for my $k (1..$candidates) {
        my @us = find_unbeaten_superset($k);
        my $new = 1;
        for my $x (@schwartz) {
            if (is_subset($x, \@us)) {
                $new = 0;
            } elsif (is_subset(\@us, $x)) {
                $x = \@us;
                $new = 0;
            }
        }
        if ($new) {
            push @schwartz, \@us;
        }
        #print "$k : " . join(",", @us) . "\n";
        #print "schwartz : " . join(":", map { join(",", @{$_}) } @schwartz) . "\n";
    }
    my @result = ();
    for my $x (@schwartz) {
        if (!is_subset($x, \@result)) {
            @result = sort(@result, @{$x});
        }
    }
    return @result;
}
Powered by Sputnik | XHTML 1.1