It's easy, except for I/O, to write in a purely-functional style in scheme
Nick Keighley
purely-functional style in scheme".
I'm a newbie and when I write scheme I try not to write C-With-Funny-
Syntax. And when I see an interesting problem I attempt to write a
"nice" scheme program to implement it. Recently (well recently-ish!)
Europe held elections. They use a form aof proportional representation
known as the D'Hondt method. Check it out in Wikipedia (or read the
code!). So I thought I'd write a function to allocate votes via the
D'Hondt method. Given the number of votes cast for each party and the
number of seats it returns a list of the party getting a vote in each
round. I initially coded it using a list as an internal data structure
holding the number of votes a party has gained so far. And in a
functional manner. But I seemed to be writing code that wanted to
update an item in the list. So I rewrote it using a mutating vector as
the internal structure. So, was I wrong to do that? Is there a better
way to functionally solve it? Or can the specification be re-cast to
make it more tractable to functional programming?
;;; dhondt.scm
;;; Allocate seats in an election using the d'Hondt method of
proportional representation.
;;; Wikipedia explains the d'Hondt method
;;;
;;; utility stuff
(define (vector-inc! vec ref)
(vector-set! vec ref (+ (vector-ref vec ref) 1)))
(define (make-list n)
(if (zero? n)
'()
(cons '0 (make-list (- n 1)))))
;; display multiple items
(define (m-display first . rest)
(display first)
(if (not (null? rest))
(map display rest)))
(define (display-line first . rest)
(m-display first rest)
(newline))
;; return the position of the largest item in a list
(define (index-of-largest lst)
(if (null? lst) (error "index-of-largest: empty list"))
(let loop ((lst lst) (largest (car lst)) (ref 0))
(if (null? lst)
ref
(if (> (car lst) largest)
(loop (cdr lst) (car lst) (+ ref 1))
(loop (cdr lst) largest ref)))))
;;;
;;; d'Hondt application functions
;; calculate how many votes each party has left
;; a party's remaining votes are its initial votes divided by the the
number of seats allocated to it +1
(define (calc-votes-left total-votes seats-allocated-to-party)
(map (lambda (old-votes seats) (/ old-votes (+ seats 1))) total-
votes seats-allocated-to-party))
;; create a new list that increments the winning party's votes
(define (calc-new-party-total party-total party-with-seat)
(let loop ((party-total party-total) (curr-party-ref 0))
(if (null? party-total)
'()
(begin
(let* ((total-seats (car party-total))
(new-total-seats (if (= party-with-seat curr-
party-ref) (+ total-seats 1) total-seats)))
(cons new-total-seats (loop (cdr party-total) (+
curr-party-ref 1))))))))
;; recalculate the seat allocation
(define (calc-seat-party-allocation seat-party-allocation party-with-
seat)
(append seat-party-allocation (list party-with-seat)))
;;;
;;; external interface
;; given a list of votes cast for each party and the number of seats
to allocate
;; returns a list of the party allocated a seat in each round
;; D'Hondt list based version
(define (d-hondt-l total-votes seats-to-allocate)
(let ((party-total (make-list (length total-votes)))) ; total
number of seats for each party
(let voting-round ((seats-to-allocate seats-to-allocate)
(votes-left total-votes) ; votes not
yet used in earlier rounds
(party-allocation '()) ; the party
winning a seat in each round
(party-total party-total)) ; total number
of seats for each party
;(display-line "D'Hondt round: party-total " party-total "
party-allocation " party-allocation)
(if (not (zero? seats-to-allocate))
(begin
(let* ((win-party (index-of-largest votes-
left)) ; the party that won this round
(new-party-total (calc-new-party-total
party-total win-party))
(new-party-allocation (calc-seat-party-
allocation party-allocation win-party)))
(voting-round
(- seats-to-allocate 1)
(calc-votes-left total-votes new-party-
total)
new-party-allocation
new-party-total)))
party-allocation))))
;; D'Hondt vector based version
(define (d-hondt-v total-votes seats-to-allocate)
(let ((party-total (make-vector (length total-votes) 0))) ;
total number of seats for each party
(let voting-round ((seats-to-allocate seats-to-allocate)
(votes-left total-votes) ; votes not yet
used in previous rounds
(party-allocation '())) ; the party
winning a seat in each round
;(display-line "D'Hondt round: party-total " party-total "
party-allocation " party-allocation)
(if (not (zero? seats-to-allocate))
(begin
(let* ((win-party (index-of-largest votes-
left)) ; the party that won this round
(new-party-allocation (calc-seat-party-
allocation party-allocation win-party)))
(vector-inc! party-total win-party)
(voting-round
(- seats-to-allocate 1)
(calc-votes-left total-votes (vector->list
party-total))
new-party-allocation)))
party-allocation))))
;;;
;;; Test harness
;; a simple unit-test function
(define (test-fun fun args match? expected)
(if (not (match? (apply fun args) expected))
(begin
(display "function applied to ") (display args) (display "
expected ") (display expected)
(display " actually ") (display (apply fun args)) (display
" ")
(error " TEST FAILED"))))
(define (test)
; this example is from the Wikipedia entry on the d'Hondt method
(test-fun d-hondt-v '((340000 280000 160000 60000 40000) 7) equal?
'(0 1 0 2 1 0 1))
(test-fun d-hondt-l '((340000 280000 160000 60000 40000) 7) equal?
'(0 1 0 2 1 0 1))
'all-tests-ok)
Pascal J. Bourguignon
> A poster recently wrote that "It's easy, except for I/O, to write in a
> purely-functional style in scheme".
>
> I'm a newbie and when I write scheme I try not to write C-With-Funny-
> Syntax. And when I see an interesting problem I attempt to write a
> "nice" scheme program to implement it. Recently (well recently-ish!)
> Europe held elections. They use a form aof proportional representation
> known as the D'Hondt method. Check it out in Wikipedia (or read the
> code!). So I thought I'd write a function to allocate votes via the
> D'Hondt method. Given the number of votes cast for each party and the
> number of seats it returns a list of the party getting a vote in each
> round. I initially coded it using a list as an internal data structure
> holding the number of votes a party has gained so far. And in a
> functional manner. But I seemed to be writing code that wanted to
> update an item in the list. So I rewrote it using a mutating vector as
> the internal structure. So, was I wrong to do that? Is there a better
> way to functionally solve it? Or can the specification be re-cast to
> make it more tractable to functional programming?
Since you want to collect the parties allocated to each seat, you
don't need to preallocate the seats, but you can accumulate the
parties in a resulting list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities:
(define first car)
(define second cadr)
(define third caddr)
(define rest cdr)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; D'Hondt algorithm
;;;
;;; We keep a list of parties sorted by decreasing V/(s+1) ratio.
;;;
(define (make-cell party-name votes seats) (list party-name votes seats))
(define cell-name first)
(define cell-votes second)
(define cell-seats third)
(define (cell-value cell) (/ (cell-votes cell) (+ 1 (cell-seats cell))))
;; (the cell-value could also be cached in the cell).
(define (insert-cell-in-order new-cell cells)
(cond
((null? cells)
(list new-cell))
((<= (cell-value (first cells)) (cell-value new-cell))
(cons new-cell cells))
(else
(cons (first cells) (insert-cell-in-order new-cell (rest cells))))))
;; If there are a big number of parties, then a balanced tree could be
;; used instead of a list.
(define (dhondt-allocate-seats seats cells allocated-seats)
;; Since we want eventually the party allocated to each seat,
;; we accumulate them here, in addition to the resulting cells.
(if (zero? seats)
(list cells (reverse allocated-seats))
(let ((major (first cells)))
(dhondt-allocate-seats (- seats 1)
(insert-cell-in-order (make-cell (cell-name major)
(cell-votes major)
(+ (cell-seats major) 1))
(rest cells))
(cons (cell-name major) allocated-seats)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compatibility function for the test driver
(define (d-hondt-f total-votes seats-to-allocate)
(define (name-parties i votes results)
(if (null? votes)
(reverse results)
(name-parties (+ 1 i)
(rest votes)
(cons (make-cell i (first votes) 0) results))))
(second (dhondt-allocate-seats seats-to-allocate (name-parties 0 total-votes '()) '())))
--
__Pascal Bourguignon__