Add initial code for instant-runoff voting (irv).

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)))

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")