(ql:quickload :vecto) (defparameter *colors* (make-hash-table :test 'equal)) (defparameter *rcv-tabulation* `(:rounds ,(loop :for i :from 1 :to 33 :collect (format nil "~D" i)) :exhausted (0 37 43 48 59 69 86 98 115 148 177 210 247 269 310 362 393 419 491 546 602 702 827 1101 1243 1365 1879 2249 2709 3012 3750 5733 15573) :candidates (("Alicia K. Bennett" 354 355 355 355 356 356 359 360 363 367 370 376 381 382 382 393 395 396 416 425 431 434 437 443) ("Mike Gould" 204 207 207 207 207 207 209 210 210 214 217 218 220 221 227 235 236 238) ("Troy Benjegerdes" 149 149 150 150 150 150 152 156 157 158 158 164 167) ("Ole Savior" 700 701 702 702 702 705 705 705 711 715 715 720 722 724 734 735 753 757 759 760 760 798 810 814 817 817) ("Kurtis W. Hanna" 200 200 200 201 202 202 202 202 204 204 206 207 207 214 214 216 222) ("Abdul M Rahaman \"The Rock\"" 355 356 356 356 357 358 360 360 360 365 369 372 377 382 382 386 388 391 396 398 398 399 415) ("Bill Kahn" 102 103 104 105 106 106 108 108 110) ("Stephanie Woodruff" 1014 1016 1017 1018 1019 1020 1020 1024 1025 1029 1029 1033 1039 1047 1054 1060 1060 1063 1078 1085 1089 1090 1098 1115 1186 1198 1202 1239 1259) ("John Leslie Hartwig" 97 97 99 99 100 101 101 101) ("Dan Cohen" 1808 1811 1813 1815 1815 1816 1819 1820 1826 1832 1837 1845 1852 1855 1859 1865 1870 1879 1887 1897 1900 1916 1939 1944 1954 1963 2016 2049 2102 2143) ("Bob \"Again\" Carney, Jr." 56 56 56 57) ("James Everett" 349 350 351 352 355 358 358 359 365 368 370 371 371 380 383 384 388 400 403 413 428 431 440 444 452) ("Don Samuels" 8350 8354 8355 8357 8365 8370 8373 8378 8381 8382 8385 8392 8397 8405 8414 8423 8428 8439 8455 8461 8478 8483 8494 8501 8530 8556 8580 8623 8699 8844 9097 10301) ("Betsy Hodges" 28962 28983 28984 28988 28994 28999 29003 29015 29023 29027 29031 29036 29043 29071 29103 29117 29123 29172 29185 29259 29316 29324 29382 29417 29490 29592 29606 30045 30289 30672 30963 32581 38870) ("Rahn V. Workcuff" 66 66 66 66 66) ("Bob Fine" 2101 2103 2105 2106 2108 2112 2115 2117 2118 2121 2122 2125 2135 2137 2141 2147 2147 2155 2168 2172 2176 2182 2198 2204 2223 2236 2255 2286 2343 2417 2559) ("Mark V Anderson" 984 985 986 989 990 995 996 997 1002 1007 1010 1018 1020 1025 1028 1029 1045 1049 1049 1053 1056 1074 1078 1086 1097 1106 1153 1163) ("Gregg A. Iverson" 146 146 147 149 149 149 149 149 152 153 155 156) ("Edmund Bernard Bruyere" 72 72 72 72 72 73 73) ("Captain Jack Sparrow" 265 270 271 271 277 278 279 279 280 284 288 293 295 299 304 307 309 325 329 333 341 352) ("Jackie Cherryhomes" 3548 3551 3551 3551 3551 3556 3560 3566 3568 3571 3580 3586 3609 3613 3617 3628 3636 3638 3654 3662 3669 3671 3682 3690 3711 3741 3751 3769 3869 3961 4070) ("Christopher Robin Zimmerman" 172 172 172 173 173 177 178 179 182 185 186 188 190 192 194 194) ("Cyd Gorman" 39 39 39) ("Joshua Rea" 110 110 110 113 113 114 115 115 116 119) ("Merrill Anderson" 109 109 109 112 113 113 118 121 122 123 139) ("Doug Mann" 779 782 787 791 794 796 796 800 801 802 809 813 816 831 836 841 846 863 867 899 961 971 993 996 1002 1089 1106) ("James \"Jimmy\" L. Stroud, Jr." 65 66 66 66 68 68) ("Tony Lane" 220 221 224 224 224 225 226 227 228 230 231 236 238 244 246 250 251 256 263 276) ("Jeffrey Alan Wagner" 167 167 167 167 167 168 171 171 172 174 176 179 186 188 189) ("Christopher Clark" 192 194 196 196 196 197 197 197 200 202 202 203 205 206 212 212 266 280 283 283 287) ("Mark Andrew" 19648 19664 19668 19669 19676 19677 19683 19688 19690 19693 19698 19708 19725 19738 19754 19796 19803 19813 19843 19851 19876 19884 19907 19942 19987 20022 20044 20151 20209 20336 20527 21831 24972) ("Cam Winton" 7533 7540 7542 7544 7544 7547 7548 7556 7562 7564 7567 7570 7571 7576 7591 7593 7613 7634 7637 7642 7647 7704 7715 7718 7723 7730 7823 7841 7936 8030 8449 8969) ("John Charles Wilson" 37 38) ("Neal Baxter" 147 147 147 148 148 153 153 153 168 172 173 176 178 180) ("Jaymie Kelly" 197 198 198 198 199 200 203 204 204 206 215 220 224 236 241 242 243 248 252) ("Write-ins" 118)))) #+not (defparameter *rcv-tabulation* '(:rounds ("32" "33") :exhausted (5733 15573) :candidates (("Cam Winton" 8969) ("Mark Andrew" 21831 24972) ("Betsy Hodges" 32581 38870) ("Don Samuels" 10301)))) (defun rounds-list () (getf *rcv-tabulation* :rounds)) (defun exhausted-list () (getf *rcv-tabulation* :exhausted)) (defun exhausted-candidate () (list* "-exhausted-" (exhausted-list))) (defun candidates-list () (getf *rcv-tabulation* :candidates)) (defun candidate-name (c) (first c)) (defun candidate-votes (c) (rest c)) (defun candidate-rounds (c) (length (candidate-votes c))) (defun candidate-round-votes (c &optional round) (or (if round (nth round (candidate-votes c)) (first (last (candidate-votes c)))) 0)) (defun count-total-votes (&optional (round 0)) (flet ((votes-for (c) (candidate-round-votes c round))) (reduce #'+ (candidates-list) :key #'votes-for :initial-value (nth round (exhausted-list))))) (defmacro tiered-comparison ((aval bval) &body fns) (let ((a (gensym "A-")) (b (gensym "B-"))) (labels ((make-comparisons (a b fns) (destructuring-bind (fn &rest fns) fns (cond ((null fns) `(,fn ,a ,b)) (t `(or (,fn ,a ,b) (unless (,fn ,b ,a) ,(make-comparisons a b fns)))))))) `(let ((,a ,aval) (,b ,bval)) ,(make-comparisons a b fns))))) (defun sort-candidates () (let ((candidates (copy-seq (candidates-list)))) (labels ((more-rounds (a b) (< (candidate-rounds b) (candidate-rounds a))) (more-final-votes (a b) (< (candidate-round-votes b) (candidate-round-votes a))) (name-comes-first-alphabetically (a b) (string< (candidate-name a) (candidate-name b))) (candidate-less-than (a b) (tiered-comparison (a b) more-rounds more-final-votes name-comes-first-alphabetically))) (sort candidates #'candidate-less-than)))) (defun sort-to-display-order () (let ((raw (sort-candidates))) (flet ((every-other (list) (loop :for item :in list :by #'cddr :collect item))) (append (every-other raw) (list (exhausted-candidate)) (reverse (every-other (rest raw))))))) (defun create-round-percentages () (let ((candidates (sort-to-display-order))) (flet ((percentages-for-round (round total) (loop :for c :in candidates :for votes := (candidate-round-votes c round) :when (or (plusp votes) (zerop round)) :collect (list (candidate-name c) (/ votes total 1.0))))) (loop :for label :in (rounds-list) :for round :from 0 :below (length (rounds-list)) :for total := (count-total-votes round) :collect (list* label (percentages-for-round round total)))))) (defun find-candidate (name round-row) (find name (rest round-row) :key #'first :test #'string=)) (defun make-transition (cur next) (labels ((find-raw-increases (cur next) (list* :increases (loop :for (name old) :in (rest cur) :for (found new) := (find-candidate name next) :collect (list name (if found (- new old) 0))))) (normalize-increases (increases) (let ((total (reduce #'+ (rest increases) :key #'second))) (list* :proportions (mapcar (lambda (c) (list (first c) (/ (second c) total))) (rest increases))))) (redistribute (name percent proportions next-round-row) (if (find-candidate name next-round-row) (list (list name percent)) (loop :for (other-name other-percent) :in (rest proportions) :unless (zerop other-percent) :collect (list other-name (* percent other-percent)))))) (let* ((raw-increases (find-raw-increases cur next)) (proportions (normalize-increases raw-increases))) (list* :transition (loop :for (name percent) :in (rest cur) :collect (list* name (redistribute name percent proportions next))))))) (defun create-round-ranges-and-transitions () (let ((rounds (create-round-percentages)) (cumulative)) (declare (special cumulative)) (labels ((round-to-ranges (row) (list* (first row) (loop :for start := 0 :then (+ start percent) :for (name percent) :in (rest row) :collect (list name start (+ start percent))))) (make-srcs (name dists cur) (let ((self (find-candidate name cur))) (loop :for whom :in dists :for start := (second self) :then (+ start amount) :for amount := (second whom) :collect (list start (+ start amount))))) (make-dsts (name dists next) (declare (ignorable name next)) (loop :for (whom amount) :in dists :for candidate := (find-candidate whom next) :for default := (second candidate) :for start := (gethash whom cumulative default) :for end := (setf (gethash whom cumulative) (+ start amount)) :collect (list start end))) (transition-to-ranges (trans cur next) (let ((cumulative (make-hash-table :test 'equal))) (declare (special cumulative)) (list* :transition-ranges (loop :for (name . dists) :in (rest trans) :for names := (mapcar #'first dists) :for srcs := (make-srcs name dists cur) :for dsts := (make-dsts name dists next) :collect (list* name (mapcar #'list names srcs dsts))))))) (loop :for first-pass := t :then nil :for cur :in rounds :for next :in (rest rounds) :for cur-range := (round-to-ranges cur) :then next-range :for next-range := (round-to-ranges next) :for trans := (make-transition cur next) :when first-pass :collect cur-range :collect (transition-to-ranges trans cur-range next-range) :collect next-range)))) (defun add-gaps (&optional initial-gap) (let* ((rows (create-round-ranges-and-transitions)) (candidates (length (rest (first rows)))) (initial-gap (or initial-gap (/ 35/500 candidates ))) (total-gap (* initial-gap (1- candidates))) (scale (/ (1+ total-gap)))) (labels ((scale-it (p) (* p scale)) (gapify-round (row) (let ((gap (/ total-gap (1- (length (rest row)))))) (list* (first row) (loop :for offset := 0 :then (+ offset gap) :for (name low high) :in (rest row) :collect (list name (scale-it (+ low offset)) (scale-it (+ high offset)) (scale-it offset)))))) (gapify-out-transitions (row round cur) (declare (ignorable row round cur)) (let ((gap (/ total-gap (1- (length (rest cur)))))) (loop :for offset := 0 :then (+ offset gap) :for (name . dists) :in (rest row) :collect (list* name (loop :for (name out in) :in dists :for (low high) := out :for new := (list (scale-it (+ low offset)) (scale-it (+ high offset))) :collecting (list name new in)))))) (gapify-in-transitions (row round next) (declare (ignorable row round next)) (loop :for (name . dists) :in row :collect (list* name (loop :for (name out in) :in dists :for (low high) := in :for other := (find-candidate name next) :for ooff := (fourth other) :for new := (list (+ (scale-it low) ooff) (+ (scale-it high) ooff)) :collecting (list name out new))))) (gapify-transitions (row round cur next) (declare (ignorable row round cur next)) (gapify-in-transitions (gapify-out-transitions row round cur) round next))) (loop :for first-pass := t :then nil :for round :from 0 :for cur :in rows :by #'cddr :for trans :in (rest rows) :by #'cddr :for next :in (rest (rest rows)) :by #'cddr :for gap-next := (gapify-round next) :when first-pass :collect (gapify-round cur) :collect (gapify-transitions trans (1+ round) cur gap-next) :collect gap-next)))) (defun hsv-to-rgb (h s v &optional (a 1)) (multiple-value-bind (hi f) (floor (* h 6)) (let* ((p (* v (- 1 s))) (q (* v (- 1 (* f s)))) (r (* v (- 1 (* (- 1 f) s))))) (case hi (0 (values v r p a)) (1 (values q v p a)) (2 (values p v r a)) (3 (values p q v a)) (4 (values r p v a)) (otherwise (values v p q a)))))) (defun make-color (&optional (h (random 0.6667)) (s 0.8) (v 0.8)) (multiple-value-bind (r g b a) (hsv-to-rgb h s v) (declare (ignore a)) (list r g b))) (defun round-index (n) (* (1- n) 2)) (defun make-image (filename &key (dpi 100) (round-width 3/4) (transition-width 3/2) (candidate-height 1) (border 1) (starting-round 1) (ending-round)) (let* ((data (add-gaps)) (rounds (/ (1+ (length data)) 2)) (ending-round (max (or ending-round rounds) starting-round)) (data (subseq data (round-index starting-round) (1+ (round-index ending-round)))) (rounds (/ (1+ (length data)) 2)) (candidates (length (rest (first data)))) (candidate-height (* candidates candidate-height)) (width (floor (* dpi (+ border (* round-width rounds) (* transition-width (1- rounds)) border)))) (height (floor (* dpi (+ border candidate-height border)))) (font-size (/ candidate-height candidates 8))) (labels ((make-y (p) (* candidate-height (- 1 p))) (make-color-for (name) (let ((color (if (string= name "-exhausted-") (list 1 1 1) (make-color)))) (setf (gethash name *colors*) color))) (get-color (name) (let ((color (gethash name *colors*))) (if (null color) (make-color-for name) color))) (path-round-rect (count low high) (let* ((x (* (+ round-width transition-width) count)) (y (make-y high)) (w round-width) (h (- (make-y low) y))) (vecto:rectangle x y w h))) (path-round-shadows (round count) (vecto:set-line-join :round) (vecto:set-line-width 1/32) (loop :for candidate :in (rest round) :for low := (second candidate) :for high := (third candidate) :do (path-round-rect count low high))) (path-transition-shape (round low0 high0 low1 high1 &optional from to fill) (let* ((x0 (+ (* (+ round-width transition-width) round) round-width)) (x1 (+ x0 transition-width)) (dx (* transition-width 1/2)) (y00 (make-y low0)) (y01 (make-y high0)) (y10 (make-y low1)) (y11 (make-y high1))) (when (and from to) (let ((c0 (append (get-color from) (list 1))) (c1 (append (get-color to) (list 1)))) (apply #'vecto:set-gradient-fill (append (list* x0 y00 c0) (list* x1 y00 c1))))) (vecto:move-to x0 y00) (vecto:curve-to (+ x0 dx) y00 (- x1 dx) y10 x1 y10) (vecto:line-to x1 y11) (vecto:curve-to (- x1 dx) y11 (+ x0 dx) y01 x0 y01) (vecto:line-to x0 y00) (when fill (vecto:fill-path) (vecto:set-line-width 1/144) (vecto:move-to x0 y00) (vecto:curve-to (+ x0 dx) y00 (- x1 dx) y10 x1 y10) (vecto:move-to x1 y11) (vecto:curve-to (- x1 dx) y11 (+ x0 dx) y01 x0 y01) (vecto:stroke)))) (path-transition-shadow (round dists) (loop :for (name (low0 high0) (low1 high1)) :in dists :when name :do (path-transition-shape round low0 high0 low1 high1))) (path-live-transition-shadows (round trans next) (loop :for (name . dists) :in trans :when (find-candidate name next) :do (path-transition-shadow round dists))) (path-dead-transition-shadows (round trans next) (loop :for (name . dists) :in trans :unless (find-candidate name next) :do (path-transition-shadow round dists))) (path-transition (round from dists) (loop :for (to (low0 high0) (low1 high1)) :in dists :do (path-transition-shape round low0 high0 low1 high1 from to t))) (path-live-transition (round trans next) (loop :for (name . dists) :in trans :when (find-candidate name next) :do (path-transition round name dists))) (path-dead-transition (round trans next) (loop :for (name . dists) :in trans :unless (find-candidate name next) :do (path-transition round name dists))) (candidate-label (y name) (vecto:draw-string (+ (* round-width 1/64) (* font-size 1/8)) (- y font-size) name)) (candidate-labels (round) (vecto:set-rgb-fill 0 0 0) (loop :for (name low) :in (rest round) :unless (string= name "-exhausted-") :do (candidate-label (make-y low) name))) (path-round (round count) (declare (ignorable round count)) (loop :for (name low high) :in (rest round) :for color := (get-color name) :do (path-round-rect count low high) :do (apply #'vecto:set-rgb-fill color) :do (vecto:fill-path)))) (vecto:with-canvas (:width width :height height) (vecto:set-rgb-fill 1 1 1) (vecto:clear-canvas) (vecto:scale dpi dpi) (vecto:translate border border) (vecto:set-font (vecto:get-font "font.ttf") font-size) (loop :for cur :in data :by #'cddr :for round :from 0 :do (path-round-shadows cur round)) (loop :for transition :in (rest data) :by #'cddr :for next :in (rest (rest data)) :by #'cddr :for round :from 0 :do (path-live-transition-shadows round transition next) :do (path-dead-transition-shadows round transition next)) (vecto:set-rgb-fill 0.2 0.2 0.2) (vecto:set-rgb-stroke 0.2 0.2 0.2) (vecto:fill-and-stroke) (loop :for transition :in (rest data) :by #'cddr :for next :in (rest (rest data)) :by #'cddr :for round :from 0 :do (path-live-transition round transition next) :do (path-dead-transition round transition next)) (loop :for cur :in data :by #'cddr :for round :from 0 :do (path-round cur round)) (candidate-labels (first data)) (vecto:save-png filename))))) ;;; For a cubic spline that starts at f(0) = p0 and ends at f(1) = p1 ;;; and is horizontal at both end-points, the equation is: ;;; ;;; f(t) = -2/9(p1 - p0)t^3 + 1/3(p1 - p0) t^2 + p0 ;;; f(t) = 1/3 * (p1 - p0) * t^2 * (1 - 2/3 * t) + p0