;;; ;;; 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))))