Add initial code for instant-runoff voting (irv).
parent
b255aceca0
commit
116130d93b
@ -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)))
|
@ -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")
|
Loading…
Reference in New Issue