diff --git a/deliberate/borda.scm b/deliberate/borda.scm index 9887b88..9e8b5af 100644 --- a/deliberate/borda.scm +++ b/deliberate/borda.scm @@ -1,47 +1,110 @@ (define-module (deliberate borda) + #:use-module (srfi srfi-1) + #:use-module (deliberate preference) #:use-module (deliberate utils) - #:export (borda-score social-choice-borda social-preference-borda)) + #:export (borda-score social-choice-borda social-preference-borda) + #:export (profile->scores groups->totals profile-borda-totals)) +;; Calculate the borda score of each alternative in `ranked`. +;; +;; Parameters: +;; alternatives: Complete list of alternatives. +;; ranked: List of alternatives ranked from most to least preferred. +;; This list need not include all possible alternatives. Any not included +;; will be treated as tied for last place. +;; (define (borda-score alternatives ranked) ;; Check whether all alternatives have been scored (if (nil? alternatives) '() ;; Check whether all ranked alternatives have been scored (if (nil? ranked) + ;; Assign average remaining score to all unranked alternatives (let* ((n (length alternatives)) (score (/ (- n 1) 2))) - ;; Assign average remaining score to all unranked alternatives (map cons alternatives (const-list n score))) ;; Just use next rank (let* ((alt (car ranked)) (remaining (delete alt alternatives))) - (cons (cons alt (length remaining)) + (cons + ;; Score of an alternative is the number of + ;; lesser-ranked alternatives + (cons alt (length remaining)) (borda-score remaining (cdr ranked)))) ))) -(define (profile->scores alternatives profile) +;; Produce a list of borda scores for multiple rankings. +;; +;; Parameters: +;; alternatives: List of alternatives. +;; counts: list of pairs of the form (`count` . `ranking`). +;; +;; Returns: +;; A list of cells of the form (`alternative` . `score`). Alternatives +;; may appear in multiple cells, one for each ranking. +;; +(define (counts->scores alternatives counts) (apply append (map (lambda (pair) (borda-score alternatives (cdr pair))) - profile))) + counts))) +;; Combine grouped borda scores into one total for each alternative. +;; +;; Parameters: +;; groups: A list of the form: +;; ((`alt-1` (`alt-1` . `alt-1-score-1`) (`alt-1` . `alt-1-score-2`) ...) +;; (`alt-2` (`alt-2` . `alt-2-score-1`) (`alt-2` . `alt-2-score-2`) ...) +;; ...) +;; (define (groups->totals groups) (map (lambda (elt) (cons (car elt) (reduce + 0 (map cdr (cdr elt))))) groups)) -(define (profile-borda-totals alternatives profile) - (let* ((scores (profile->scores alternatives profile)) +;; Calculate total borda counts for each alternative in `counts`. +;; +;; Parameters: +;; alternatives: List of all alternatives +;; counts: List of cells of the form (`count` . `ranking`) +;; +;; Returns: +;; A list of the form ((`alt-1` . `total-1`) (`alt-2` . `total-2`) ...) +;; +(define (profile-borda-totals alternatives counts) + (let* ((scores (counts->scores alternatives counts)) (groups (group-by car scores)) (totals (groups->totals groups))) totals)) +;; Find the social prefrence ranking using the Borda count method. +;; ;; TODO - handle ties -(define (social-preference-borda alternatives profile) - (let ((totals (profile-borda-totals alternatives profile))) +;; +;; 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-borda alternatives counts) + (let ((totals (profile-borda-totals alternatives counts))) ;; We use > instead of < for to rank in decreasing score order - (map (compose list car) (sort totals (lambda (x y) (> (cdr x) (cdr y))))))) + (map (compose list car) + (sort totals (lambda (x y) (> (cdr x) (cdr y))))))) -(define (social-choice-borda alternatives profile) - (car (social-preference-borda alternatives profile))) +;; 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-borda alternatives counts) + (car (social-preference-borda alternatives counts))) diff --git a/tests/test-borda.scm b/tests/test-borda.scm index 4adb696..297ce64 100644 --- a/tests/test-borda.scm +++ b/tests/test-borda.scm @@ -1,5 +1,23 @@ -(use-modules (srfi srfi-1) - (deliberate borda)) +;;; 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-borda) + #:use-module (srfi srfi-64) + #:use-module (deliberate borda) + #:use-module (deliberate utils)) + +(test-begin "test-deliberate-borda") (define test-alts '("red" "green" "blue")) @@ -11,8 +29,35 @@ (1 . ("green")) )) -(borda-score test-alts test-pref) +(define test-scores + '(("red" . 2) ("green" . 1) ("blue" . 0) + ("green" . 2) ("red" . 1) ("blue" . 0) + ("green" . 2) ("red" . 1/2) ("blue" . 1/2))) + +(define test-groups + '(("blue" ("blue" . 0) ("blue" . 0) ("blue" . 1/2)) + ("green" ("green" . 1) ("green" . 2) ("green" . 2)) + ("red" ("red" . 2) ("red" . 1) ("red" . 1/2)))) + +(define test-totals + '(("blue" . 1/2) ("green" . 5) ("red" . 7/2))) + +(test-equal '(("blue" . 2) ("red" . 1/2) ("green" . 1/2)) + (borda-score test-alts test-pref)) + +(test-equal test-scores + (profile->scores test-alts test-profile)) + +(test-equal test-groups + (group-by car test-scores)) + +(test-equal test-totals + (groups->totals test-groups)) + +(test-equal '(("green") ("red") ("blue")) + (social-preference-borda test-alts test-profile)) -(social-preference-borda test-alts test-profile) +(test-equal '("green") + (social-choice-borda test-alts test-profile)) -(social-choice-borda test-alts test-profile) +(test-end "test-deliberate-borda")