You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
111 lines
3.6 KiB
Scheme
111 lines
3.6 KiB
Scheme
(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 (counts->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)))
|
|
(map cons alternatives (const-list n score)))
|
|
;; Just use next rank
|
|
(let* ((alt (car ranked))
|
|
(remaining (delete alt alternatives)))
|
|
(cons
|
|
;; Score of an alternative is the number of
|
|
;; lesser-ranked alternatives
|
|
(cons alt (length remaining))
|
|
(borda-score remaining (cdr ranked))))
|
|
)))
|
|
|
|
;; 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)))
|
|
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))
|
|
|
|
;; 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
|
|
;;
|
|
;; 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)))))))
|
|
|
|
;; 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)))
|