From 116130d93ba17f69f6f4360e1778bd5d560c868b Mon Sep 17 00:00:00 2001 From: "Edward L. Platt" Date: Tue, 25 Oct 2022 17:47:35 -0400 Subject: [PATCH] Add initial code for instant-runoff voting (irv). --- deliberate/irv.scm | 99 +++++++++++++++++++++++++++++++++++ tests/test-irv.scm | 126 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 225 insertions(+) create mode 100644 deliberate/irv.scm create mode 100644 tests/test-irv.scm diff --git a/deliberate/irv.scm b/deliberate/irv.scm new file mode 100644 index 0000000..e7d5b94 --- /dev/null +++ b/deliberate/irv.scm @@ -0,0 +1,99 @@ +(define-module (deliberate irv) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-1) + #:use-module (deliberate preference) + #:use-module (deliberate utils) + #:export (irv-counts->first-counts irv-first-counts->scores social-choice-irv social-preference-irv) + #:export (delete-lowest irv-round lowest-count) + ) + +;; Extract first-place alternatives from preference counts +(define (irv-counts->first-counts counts) + (map + (lambda (count-ranked) + (cons (pref-count count-ranked) + (car (pref-ranked count-ranked)))) + counts)) + +(define (irv-first-counts->scores first-counts) + (let ((groups (group-by cdr first-counts))) + (map (lambda (group) + (cons + (reduce + 0 (map car (cdr group))) + (car group))) + groups))) + +(define (lowest-count scores) + (apply min (map car scores))) + +(define (delete-lowest scores) + (let ((lowest (lowest-count scores))) + (receive (to-delete to-keep) + (partition + (lambda (elt) (= lowest (car elt))) + scores) + (cons + (map cdr to-keep) + (map cdr to-delete)) + ))) + +(define (irv-round counts) + (let* ((scores + (irv-first-counts->scores + (irv-counts->first-counts counts))) + (keep-delete (delete-lowest scores)) + (keep-alts (car keep-delete)) + (delete-alts (cdr keep-delete))) + (cons + delete-alts + (filter-empty + (map (lambda (count-elt) + (cons (car count-elt) + (filter (lambda (alt) + (memv alt keep-alts)) + (cdr count-elt)) + )) + counts))) + )) + +(define (filter-empty counts) + (filter (lambda (count-elt) + (not (nil? (cdr count-elt)))) + counts)) + +;; Find the social prefrence ranking using the Borda count method. +;; +;; TODO - handle ties +;; +;; Parameters: +;; alternatives: List of all alternatives +;; counts: List of cells of the form (`count` . `ranking`) +;; +;; Returns: +;; A list of lists. The outer list represents the social ranking from +;; most to least preferred. The inner lists represent sets of alternatives +;; tied for the same place. +;; +(define (social-preference-irv counts) + (reverse (social-preference-irv-rev counts))) + +(define (social-preference-irv-rev counts) + (if (nil? counts) + '() + (let* ((delete-counts (irv-round counts)) + (delete-alts (car delete-counts)) + (next-counts (cdr delete-counts))) + (cons delete-alts (social-preference-irv-rev next-counts)) + ))) + +;; Find the winner of a vote using the Borda count method. +;; +;; Parameters: +;; alternatives: List of all alternatives +;; counts: List of cells of the form (`count` . `ranking`) +;; +;; Returns: +;; A list contianing alternatives tied for first place. +;; +(define (social-choice-irv counts) + (car (social-preference-irv counts))) diff --git a/tests/test-irv.scm b/tests/test-irv.scm new file mode 100644 index 0000000..fd540f0 --- /dev/null +++ b/tests/test-irv.scm @@ -0,0 +1,126 @@ +;;; Copyright 2022 Edward L. Platt +;;; +;;; Licensed under the Apache License, Version 2.0 (the "License"); +;;; you may not use this file except in compliance with the License. +;;; You may obtain a copy of the License at +;;; +;;; http://www.apache.org/licenses/LICENSE-2.0 +;;; +;;; Unless required by applicable law or agreed to in writing, software +;;; distributed under the License is distributed on an "AS IS" BASIS, +;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;;; See the License for the specific language governing permissions and +;;; limitations under the License. + +(define-module (tests test-irv) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-64) + #:use-module (deliberate irv) + #:use-module (deliberate utils)) + +(use-modules (deliberate irv) (deliberate utils)) + +(test-begin "test-deliberate-irv") + +(define test-counts + '((1 . ("brown" "red")) + (1 . ("red" "brown")) + (1 . ("red")) + (1 . ("pink" "red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("pink" "blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + )) + +(define test-counts-2 + '((1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("pink" "red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("pink" "blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + )) + +(define test-counts-3 + '((1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("green" "red")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + (1 . ("blue")) + )) + +(define test-counts-5 + '((1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ("red")) + (1 . ()) + (1 . ()) + (1 . ()) + (1 . ()) + (1 . ()) + (1 . ()) + )) + +(define test-scores-1 + '((5 . "blue") (1 . "brown") (3 . "green") (2 . "pink") (2 . "red"))) + +(define test-keep-delete-1 + (cons + '("blue" "green" "pink" "red") + '("brown"))) + +(define test-keep-delete-2 + (cons + '("blue" "green" "red") + '("pink"))) + +(define test-preference + '(("red") ("blue") ("green") ("pink") ("brown"))) + +(define test-choice '("red")) + +(test-equal test-scores-1 + (irv-first-counts->scores + (irv-counts->first-counts test-counts))) + +(test-equal test-keep-delete-1 + (delete-lowest test-scores-1)) + +(test-equal (cons (cdr test-keep-delete-1) test-counts-2) + (irv-round test-counts)) + +(test-equal (cons (cdr test-keep-delete-2) test-counts-3) + (irv-round test-counts-2)) + +(test-equal test-preference + (social-preference-irv test-counts)) + +(test-equal test-choice + (social-choice-irv test-counts)) + +(test-end "test-deliberate-irv")