; Gregory method single transferable vote proportional representation
;
; Copyright © 2008  Alan Bawden
;
; $Id: pr.scm 17 2008-12-05 10:06:04Z alan $

; ===== About the algorithm =====
;
; For background on the algorithms used here, you might visit the following
; Wikipedia pages:
;
;	http://en.wikipedia.org/wiki/Single_transferable_vote
;	http://en.wikipedia.org/wiki/Gregory_method
;
; At least in October 2008 these articles were a passable explanation of what
; is going on here.  (Although there -were- mistakes on those pages...)
;
; The advantage of Gregory's method (in my opinion) is that it is the simplest
; redistribution algorithm that is entirely deterministic.  Using a random
; number generator to decide which ballots to redistribute may be fine for a
; large municipal election (e.g., Cambridge Massachusetts), but as the number
; of ballots decreases, the probability -increases- that re-running an
; election with the exact same ballots will produce different results.
; Gregory's method eliminates that danger, and makes it plausible to use STV
; PR for an election with a small number of ballots.
;
; I won't guarantee that I've implemented Gregory's method exactly as it is
; used in the Irish Senate (its most famous application), or anywhere else in
; the world, since I have only read it described in prose -- I've never read
; anybody else's implementation.  I definitely use a slightly different method
; of computing the quota.  But in any case, this is a reasonable version of
; Gregory's idea, and it should function as a decent STV PR system for any
; purpose.
;
; I have tested this code using the ballots from the Cambridge Massachusetts
; city council election of 1999.  It chooses exactly the same winners as the
; Cambridge random redistribution algorithm did.

; ===== About the code =====
;
; This code is totally functional and it is written in the most basic possible
; Scheme.  It does perform some output so that you can watch the execution of
; the algorithm should you so desire, but you can just comment that out if you
; only care about the results.
;
; You might expect this code to carry a large amount of state from one round
; to the next -- maintaining a complete record of where each ballot had been
; and what fractional votes had been left behind along the way -- but that
; isn't needed.  Given just the record of what decisions have been made on
; each round (candidates elected or eliminated) it is possible to recompute
; the current state of each ballot.  This is what the function `distribute'
; does.  It costs us some extra time to do things this way, but the code is
; much simpler.
;
; This code is written so that in a Scheme with exact rational numbers, all
; arithmetic will be exact.  I have not thought through the consequences of
; having the `/' function returns an inexact result.  I suspect it works just
; fine.  (Floating point roundoff should make ties even more unlikely...)
;
; The complexity of the rational arithmetic required here grows as the number
; of seats to be filled grows.  In later rounds, the rational numbers involved
; can get quite large (in storage size not in numeric magnitude).  In
; practice, it is feasible to use this code to run elections for less than
; around a dozen seats, even using a very slow machine, although you may have
; to wait a bit for the answer, and it will certainly give your rational
; arithmetic a pretty good workout!  For larger numbers of seats, switch to
; floating point.

; ===== Ballots =====
;
; Each ballot should be an ordered list of candidate names.  Candidate names
; will be compared using EQ?.  (So they should probably be symbols, but that
; is up to the caller.)  #F may not be used as a candidate name.

; ===== Terminology =====
;
; A candidate can be in one of three states: Elected, Eliminated or Hopeful.
; Hopeful candidates become elected or eliminated candidates as the algorithm
; progresses.  No other state transitions happen.

; ===== State =====
;
; The current state of the election is a record of which candidates have been
; elected or eliminated so far.  It is a list of entries (each describing one
; candidate) of the form:
;
;	Eliminated:	(<name> <round> #F)
;	Elected:	(<name> <round> <yield>)
;
; Where <round> is the number of the round where the candidate was elected or
; eliminated, and <yield> is the fraction of his vote an elected candidate can
; afford to yield and still achieve quota.
;
; Note that the state forms an a-list for easy searching by candidate name.

(define c-name car)
(define c-round cadr)
(define c-yield caddr)
(define c-elected? caddr)

; ===== Vote-lists =====
;
; A vote-list is an alist with entries of the form (<name> <vote>).  This also
; forms an a-list for easy searching by candidate name.

(define v-name car)
(define v-vote cadr)

; ===== The main entry point =====
;
; Given a list of ballots and the number of seats to be filled, runs a single
; transferable vote election using the Gregory method to redistribute votes.
; This can return one of four possible results:
;
;	(TRIVIAL <winners>)
;	(BY-ELECTION <winners> <final-state>)
;	(BY-ELIMINATION <winners> <final-state>)
;	(TIE <winners> <tied> <final-state>)
;
; The caller probably does not care about the differences between these
; results, except for the last one.  In the first three cases, <winners> is a
; list of the elected candidates.  In the last case, <winners> will be shorter
; than desired, and <tied> will be a list of candidates who are tied for the
; remaining seats.  The caller will have to make his own arrangements to
; select from among the tied candidates.  (Random selection perhaps.)

(define (main ballots nseats)

  ;; Quota can be any number such that it is impossible to divide the
  ;; number of votes into (+ 1 nseats) piles each containing quota or more
  ;; votes.  In other words, we require:
  ;;
  ;;	(> quota (/ (length ballots) (+ 1 nseats)))
  ;;
  ;; But we don't want it too much larger, because the smaller the quota, the
  ;; more representative the result.  Assuming that there are more ballots
  ;; than seats to be filled, the following will do:
  (define quota
    (/ (+ 1 (length ballots))
       (+ 1 nseats)))

  ;; The list of all candidate names can be computed by examining all of the
  ;; ballots:
  (define candidates (all-names ballots))

  ;; The main loop.  There are two possible ways that the algorithm can
  ;; terminate.  In the first case, all candidates are elected by achieving
  ;; the quota.  `To-elect' counts down so that we can detect when that
  ;; happens.  In the second case, a sufficient number of candidates have been
  ;; eliminated so that the desired number of candidates remain.
  ;; `To-eliminate' counts down so that we can detect when that happens.
  ;; `State' is the state of the election, as described above.  `Round' is an
  ;; integer incremented each time around the loop.
  (define (loop to-elect to-eliminate state round)
    ;; In each round we compute a vote list for the still hopeful candidates.
    ;; Then we check to see if any of them have achieved the quota:
    (let* ((vlist (do-round ballots state (hopeful-names candidates state)))
	   (winners (find-winners vlist quota round)))
      (report "Votes" vlist)
      (cond ((not (null? winners))
	     (report "Winners" winners)
	     ;; Some new candidates achieved quota.  See how many:
	     (let ((n (length winners))
		   (state (append winners state)))
	       (cond ((< n to-elect)
		      ;; We still have seats to fill.  Do another round:
		      (loop (- to-elect n)
			    to-eliminate
			    state
			    (+ 1 round)))
		     ((> n to-elect)
		      ;; We picked the quota to be just large enough that this
		      ;; should be impossible!
		      (error "This can't happen."))
		     (else
		      ;; We are done.  All candidates were elected by
		      ;; achieving the quota:
		      (list 'BY-ELECTION
			    (elected-names state)
			    state)))))
	    (else
	     ;; No new candidates achieved quota.  So find the candidates with
	     ;; the least amount of support:
	     (let ((hindmost (find-hindmost vlist round)))
	       (report "Hindmost" hindmost)
	       (let ((n (length hindmost))
		     (state (append hindmost state)))
		 (cond ((> n to-eliminate)
			;; If we eliminate the hindmost, we will have
			;; eliminated too many candidates, so we are done, but
			;; we have a tie for the remaining seats.
			(list 'TIE
			      (uneliminated-names candidates state)
			      (map c-name hindmost)
			      state))
		       ((= n to-eliminate)
			;; After eliminating the hindmost, the number of
			;; remaining candidates is exactly right.  Some of
			;; them failed to achieve quota, but that is OK.
			(list 'BY-ELIMINATION
			      (uneliminated-names candidates state)
			      state))
		       (else
			;; Otherwise, do another round:
			(loop to-elect
			      (- to-eliminate n)
			      state
			      (+ 1 round))))))))))
  
  (let ((ncandidates (length candidates)))
    (cond ((<= (length ballots) nseats)
	   (error "Too few ballots for this to work."))
	  ((< ncandidates nseats)
	   (error "Too few candidates for this to work: " candidates))
	  ((= ncandidates nseats)
	   (list 'TRIVIAL candidates))
	  (else
	   (report "Quota" quota)
	   (loop nseats
		 (- ncandidates nseats)
		 '()
		 0)))))

; Given one voter's ballot, and given the current state of the election,
; distribute that voter's vote.  Returns (<name> <vote>), where <name> is the
; hopeful candidate that currently claims this voter's final fractional vote
; <vote>.  <name> is #F if the ballot is exhausted.
(define (distribute ballot state)
  (let loop ((ballot ballot)
	     (previous-round -1)	; rounds are numbered starting from 0
	     (v 1))
    (if (null? ballot)			; exhausted: remainder of vote is lost
	(list #F v)
	(let* ((name (car ballot))
	       (entry (assq name state)))
	  (cond ((not entry)
		 ;; This candidate is still hopeful, so all of our remaining
		 ;; vote goes to her:
		 (list name v))
		(else
		 (let ((round (c-round entry))
		       (yield (c-yield entry)))
		   (cond ((<= round previous-round)
			  ;; This candidate was elected or eliminated before
			  ;; we got to her, so keep looking:
			  (loop (cdr ballot) previous-round v))
			 (yield
			  ;; In round ROUND, we were voting for this
			  ;; candidate, and she was elected, so she keeps some
			  ;; fraction of our vote, and the remainder moves on:
			  (loop (cdr ballot) round (* v yield)))
			 (else
			  ;; In round ROUND, we were voting for this
			  ;; candidate, but she was eliminated, so our vote
			  ;; moves on:
			  (loop (cdr ballot) round v))))))))))

; Given all the ballots, and given the current state of the election,
; distribute all the ballots, and then sum up the total votes for the hopeful
; candidates.  Returns a vote-list.
(define (do-round ballots state hopeful-names)
  (let ((l (map (lambda (ballot)
		  (distribute ballot state))
		ballots)))
    (map (lambda (name)
	   (let loop ((l l)
		      (sum 0))
	     (cond ((null? l)
		    (list name sum))
		   ((eq? name (caar l))
		    (loop (cdr l) (+ sum (cadar l))))
		   (else
		    (loop (cdr l) sum)))))
	 hopeful-names)))

; Given a vote-list, and given the quota, find all the candidates that have
; achieved quota, and compute the fraction of their vote that they can afford
; to yield in order to retain exactly the quota.  Returns a list of additions
; to the current state.
(define (find-winners vlist quota round)
  (let loop ((vlist vlist)
	     (winners '()))
    (if (null? vlist)
	winners
	(loop (cdr vlist)
	      (if (>= (v-vote (car vlist)) quota)
		  (cons (list (v-name (car vlist))
			      round
			      (- 1 (/ quota (v-vote (car vlist)))))
			winners)
		  winners)))))

; Given a vote-list, find all the candidates that are tied for last place and
; prepare to eliminate them.  Returns a list of additions to the current
; state.
(define (find-hindmost vlist round)
  (let loop ((vlist vlist)
	     (smallest #F)
	     (hindmost '()))
    (if (null? vlist)
	hindmost
	(let ((v (v-vote (car vlist))))
	  (cond ((or (not smallest) (< v smallest))
		 (loop (cdr vlist)
		       v
		       (list (list (v-name (car vlist)) round #F))))
		((> v smallest)
		 (loop (cdr vlist) smallest hindmost))
		(else
		 (loop (cdr vlist)
		       smallest
		       (cons (list (v-name (car vlist)) round #F)
			     hindmost))))))))

; Nothing but boring list manipulation below this point.

; Given all the ballots, find all the candidates.  While we are at it, we
; check that all the ballots are duplicate free.
(define (all-names ballots)
  (let outer ((ballots ballots)
	      (names '()))
    (if (null? ballots)
	names
	(let inner ((ballot (car ballots))
		    (names names))
	  (cond ((null? ballot)
		 (outer (cdr ballots) names))
		((memq (car ballot) (cdr ballot))
		 (error "Ballot contains duplicate: " (car ballots)))
		(else
		 (inner (cdr ballot) 
			(if (memq (car ballot) names)
			    names
			    (cons (car ballot) names)))))))))

; Given a list of candidates, and given the current state, find the candidates
; that are still hopeful.
(define (hopeful-names names state)
  (let loop ((names names)
	     (rv '()))
    (if (null? names)
	rv
	(loop (cdr names)
	      (if (not (assq (car names) state))
		  (cons (car names) rv)
		  rv)))))

; Given the current state, find the candidates that are elected.
(define (elected-names state)
  (let loop ((state state)
	     (rv '()))
    (if (null? state)
	rv
	(loop (cdr state)
	      (if (c-elected? (car state))
		  (cons (c-name (car state)) rv)
		  rv)))))

; Given a list of candidates, and given the current state, find the candidates
; that are uneliminated (hopeful or elected).
(define (uneliminated-names names state)
  (let loop ((names names)
	     (rv '()))
    (if (null? names)
	rv
	(loop (cdr names)
	      (let ((entry (assq (car names) state)))
		(if (or (not entry) (c-elected? entry))
		    (cons (car names) rv)
		    rv))))))

; Report on what's going on:
(define (report label x)
  (display label)
  (cond ((list? x)
	 (display ":")
	 (for-each (lambda (x)
		     (newline)
		     (display "    ")
		     (write x))
		   x))
	(else
	 (display ": ")
	 (write x)))
  (newline))

; Local Variables:
; mode: Scheme
; End: