;;;
;;; UVA CS200 Spring 2004
;;; Problem Set 2
;;; 21 January 2004
;;; Written by Andrew Connors, with help from David Evans,
;;; Katie Winstanley, and Sarah Bergkuist.
(load "graphics.ss") ;; Load the graphics code
(load "listprocs.ss") ;; Load the list processing code
;;; The max-position-move constant defines maximum distance a
;;; candidate may move without being dismissed as a flip-flopper.
(define max-position-move 0.1)
(define standard-move (* 0.5 max-position-move))
;;; The name window is hard coded into the drawing routines,
;;; so we don't need to remember to pass it. Everytime this
;;; code is loaded, a new window will be created.
(define window (make-window window-width window-height "CS 200 Election"))
;;;
;;; Electorates
;;;
(define electorate-steps 1000) ;; number of samples through the electorate
;;; electorate-voters evaluates to the number of voters in
;;; electorate between start-position and end-position
(define (electorate-voters electorate start-position end-position)
(electorate-voters-worker electorate start-position end-position (/ 1 electorate-steps)))
;;; You need to define electorate-voters-worker (question 3)
(define (electorate-curve electorate)
(lambda (t) (make-point t (electorate t))))
;;;
;;; Candidates
;;;
;;; The procedures defined below provide an abstraction for
;;; representing a candidate. You don't need to understand this
;;; code (but should be able to understand almost all of it).
(define (make-candidate name position reposition-procedure)
(list 'candidate name position reposition-procedure))
(define (candidate-name candidate)
(get-tagged-list candidate 'candidate 1))
(define (candidate-position candidate)
(get-tagged-list candidate 'candidate 2))
;;; Evaluates to a candidate with name and reposition-procedure
;;; identical to candidate, but position changed to position.
(define (candidate-set-position candidate position)
(printf "Candidate ~a moves from ~a to ~a~n"
(candidate-name candidate)
(candidate-position candidate) position)
(make-candidate (candidate-name candidate)
position
(candidate-reposition-procedure candidate)))
(define (candidate-reposition-procedure candidate)
(get-tagged-list candidate 'candidate 3))
;;;
;;; Some candidate repositioning procedures
;;;
;;; Principled (unmoving) candidate
(define (static-candidate candidate race poll) 0.0)
;;; Candidate moves towards whichever side has more voters
(define (move-towards-voters candidate race poll)
(let ((voters-to-left ;;; voters between 0.0 and my position
(electorate-voters (race-electorate race) 0.0
(candidate-position candidate)))
(voters-to-right ;;; voters between my position and 1.0
(electorate-voters (race-electorate race)
(candidate-position candidate) 1.0)))
(if (> voters-to-left voters-to-right)
(- standard-move) ; move left one unit
(if (= voters-to-left voters-to-right)
0 ; stay put
standard-move)))) ; move right one unit
;;;
;;; move-away-from-others strategy moves away from other
;;; candidates. If there are candidates to both sides of me,
;;; move away from closest candidate. Otherwise, move away
;;; from the edge.
;;;
(define (move-away-from-others candidate race poll)
(let ((my-position (candidate-position candidate)))
(let ((candidates-to-left
(filter (lambda (cand)
(< (candidate-position cand) my-position))
(race-other-candidates race candidate)))
(candidates-to-right
(filter (lambda (cand)
(> (candidate-position cand) my-position))
(race-other-candidates race candidate))))
(if (empty? candidates-to-left) ;; no one to my left, move right
(* 0.1 max-position-move)
(if (empty? candidates-to-right) ;; no one to my right, move left
(* -0.1 max-position-move)
(let ((closest-candidate
(find-closest-candidate
(race-other-candidates race candidate)
(candidate-position candidate))))
(if (< (candidate-position closest-candidate)
(candidate-position candidate))
;; left of me, I should move right
(* .05 max-position-move)
(* -.05 max-position-move)))))))) ; move left if equal
;;; Evaluates to the closest candidate to pos.
;;; (If two candidates are equally closes, evaluates to
;;; the first one.)
(define (find-closest-candidate candidates pos)
(define (helper candidates pos closest)
(if (null? candidates) closest
(if (< (abs (- pos (candidate-position (first candidates))))
(abs (- pos (candidate-position closest))))
(helper (rest candidates) pos (first candidates))
(helper (rest candidates) pos closest))))
(helper (rest candidates) pos (first candidates)))
;;;
;;; Races
;;;
;;; The procedures defined below provide an abstraction for
;;; representing a race. You don't need to understand this code
;;; (but should be able to understand almost all of it).
;;;
(define (make-race electorate candidates)
(list 'race electorate candidates))
(define (race-electorate race)
(get-tagged-list race 'race 1))
(define (race-candidates race)
(get-tagged-list race 'race 2))
(define (race-other-candidates race candidate)
(filter (lambda (el) (not (eq? el candidate))) (race-candidates race)))
(define (get-nth-candidate race n)
(get-nth (race-candidates race) n))
;;;
;;; Election
;;;
(define (display-poll-results race poll-results)
(map (lambda (cand result)
(printf "Candidate ~a at ~a: ~a~n"
(candidate-name cand)
(candidate-position cand) result))
(race-candidates race) poll-results))
(define (display-winner race poll-results)
(let ((winners (find-winner (race-candidates race)
poll-results 0.0 null)))
(if (= (length winners) 1)
(printf "The winner is: ~a" (candidate-name (car winners)))
(printf "The election is tied between: ~a"
(map (lambda (candidate) (candidate-name candidate))
winners)))))
(define (find-winner candidates results best winners)
(if (null? candidates) winners
(if (> (first results) best)
(find-winner (rest candidates) (rest results)
(first results) (list (first candidates)))
(if (= (first results) best)
(find-winner (rest candidates) (rest results)
best (cons (first candidates) winners))
(find-winner (rest candidates) (rest results)
best winners)))))
(define (run-one-day race)
(let ((poll-results (conduct-poll race)))
(display "Poll results...") (newline)
(display-poll-results race poll-results)
(display "Repositioning candidates...") (newline)
(graph-election race poll-results)
(make-race
(race-electorate race) ;; the electorate doesn't change
(map (lambda (candidate)
(let ((position-move
((candidate-reposition-procedure candidate)
candidate
race
poll-results)))
(if (> (abs position-move) max-position-move)
(begin
(printf
(string-append
"Candidate ~a has attempted to move too rapidly "
"(move ~a exceeds maximum move of ~a. "
"Candidate permanently loses all support.")
(candidate-name candidate)
position-move
max-position-move)
;; replace the candidate with a losing candidate
(make-candidate (candidate-name candidate)
-1.0 static-candidate))
(candidate-set-position
candidate
(+ (candidate-position candidate) position-move)))))
(race-candidates race)))))
(define (graph-election race poll)
(clear-window) ;; clear the window
;; show the electorate
(draw-colored-curve-connected (electorate-curve (race-electorate race))
1000 (make-rgb 0.0 0.0 1.0))
;; draw a line showing each candidate's polling data
(map
(lambda (candidate poll color)
(let ((position (candidate-position candidate)))
(window-draw-colored-line (make-point position 0.0)
(make-point position poll) color)))
(race-candidates race)
poll
(map (lambda (index) (make-rgb (/ index (length poll))
(/ index (length poll))
(- 1 (/ index (length poll)))))
(intsto (length poll))))
(sleep 1) ;; wait for 1 second - remove this if you want it to go faster
)
;;;
;;; The run-election procedure depends on you providing
;;; a correct definition of n-times.
;;;
(define (run-election race number-of-days)
(let ((final ((n-times run-one-day number-of-days) race)))
(let ((final-votes (conduct-poll final)))
(printf "======================~n")
(printf "Final Election Results~n")
(printf "======================~n")
(display-poll-results final final-votes)
(graph-election final final-votes)
(display-winner final final-votes))))
;;;
;;; Conducting polls
;;;
(define (conduct-poll race)
(let ((vote-counts
(poll-worker race 0.0 (/ 1 electorate-steps)
(map (lambda (cand) 0.0) (race-candidates race)))))
;; we need to normalize the vote counts to sum to 1.0
(let ((total-votes (sumlist vote-counts)))
(map (lambda (votes) (/ votes total-votes)) vote-counts))))
;;; positions must be betwen 0.0 and 1.0
(define (position-in-range pos)
(and (>= pos 0.0) (<= pos 1.0)))
;;; Evaluates to a list of the candidate numbers closest to
;;; position (could evaluate to a list of more than one candidates,
;;; if two candidates are equally close)
(define (race-closest-candidates-worker candidates candidate-no
position distance closest-so-far)
(if (null? candidates)
closest-so-far
(let ((first-candidate (first candidates)))
(if (position-in-range (candidate-position first-candidate))
(let ((first-distance
(abs (- (candidate-position first-candidate)
position))))
(if (and (position-in-range
(candidate-position first-candidate))
(< first-distance distance))
;; this candidate is the closest
(race-closest-candidates-worker
(cdr candidates)
(+ candidate-no 1)
position first-distance (list candidate-no))
(if (and (position-in-range
(candidate-position first-candidate))
(= first-distance distance))
(race-closest-candidates-worker
(cdr candidates)
(+ candidate-no 1) position distance
(cons candidate-no closest-so-far))
(race-closest-candidates-worker
(cdr candidates)
(+ candidate-no 1) position distance
closest-so-far))))))))
(define (race-closest-candidates race position)
;; Start by using the first candidate as the closest
(race-closest-candidates-worker
(cdr (race-candidates race))
2 ; count starts at 2 (first candidate already used)
position
(abs (- (candidate-position (car (race-candidates race))) position))
(list 1)))
(define (poll-worker race position step counts)
(let ((num-voters ((race-electorate race) position))
(closest-candidates (race-closest-candidates race position)))
;; the voters are divided equally among all the closest-candidates
(if (<= position 1.0)
(let ((num-votes-each (/ num-voters (length closest-candidates))))
(map
(lambda (candidate-no)
(set-nth! counts candidate-no
(+ (get-nth counts candidate-no) num-votes-each)))
closest-candidates)
(poll-worker race (+ position step) step counts))
counts)))
;;;
;;; Some fictional elections (any resemblance to real elections or
;;; real candidates is purely coincidental)
;;;
(define flat-electorate
(lambda (pos) 0.5))
(define iowa-electorate
(lambda (pos)
(- 1.0 (abs (- 0.5 pos)))))
(define iowa-caucus
(make-race
iowa-electorate
(list
(make-candidate "Kucinich" 0.05 static-candidate)
(make-candidate "Gephardt" 0.1 move-away-from-others)
(make-candidate "Dean" 0.2 move-away-from-others)
(make-candidate "Edwards" 0.6 move-towards-voters)
(make-candidate "Kerry" 0.8 move-away-from-others))))