Artifact
0387534663ad80b210c459c729c8621cc76c954d:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 37 2d 32 30 30 38 2c 20 4d 61 74 74 68 65 77 20 7-2008, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 20 4b 69 61 74 6f 61 2e Welland. Kiatoa.
0030: 63 6f 6d 20 41 6c 6c 20 72 69 67 68 74 73 20 72 com All rights r
0040: 65 73 65 72 76 65 64 2e 0a 3b 3b 20 0a 3b 3b 20 eserved..;; .;;
0050: 74 68 69 73 20 67 65 74 73 20 72 65 61 64 20 66 this gets read f
0060: 6f 72 20 41 4c 4c 20 70 61 67 65 73 2e 20 44 6f or ALL pages. Do
0070: 6e 27 74 20 77 65 69 67 68 20 69 74 20 64 6f 77 n't weigh it dow
0080: 6e 20 65 78 63 65 73 73 69 76 65 6c 79 21 0a 3b n excessively!.;
0090: 3b 0a 3b 3b 20 75 73 70 72 65 73 69 64 65 6e 74 ;.;; uspresident
00a0: 2f 63 6f 6e 74 72 6f 6c 2e 73 63 6d 0a 0a 28 73 /control.scm..(s
00b0: 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 22 63 61 6e :load-model "can
00c0: 64 69 64 61 74 65 22 29 0a 28 73 3a 6c 6f 61 64 didate").(s:load
00d0: 2d 6d 6f 64 65 6c 20 22 76 6f 74 69 6e 67 22 29 -model "voting")
00e0: 0a 28 73 3a 6c 6f 61 64 2d 6d 6f 64 65 6c 20 22 .(s:load-model "
00f0: 70 65 72 73 6f 6e 22 29 0a 0a 28 64 65 66 69 6e person")..(defin
0100: 65 20 63 61 6e 64 69 64 61 74 65 73 20 28 63 61 e candidates (ca
0110: 6e 64 69 64 61 74 65 3a 67 65 74 2d 74 6f 70 20 ndidate:get-top
0120: 31 30 29 29 0a 28 64 65 66 69 6e 65 20 63 61 6e 10)).(define can
0130: 64 69 64 61 74 65 73 3a 76 6f 74 65 2d 73 75 6d didates:vote-sum
0140: 2d 61 70 70 72 6f 76 61 6c 20 20 28 61 70 70 6c -approval (appl
0150: 79 20 2b 20 28 6d 61 70 20 63 61 6e 64 69 64 61 y + (map candida
0160: 74 65 3a 67 65 74 2d 73 63 6f 72 65 20 63 61 6e te:get-score can
0170: 64 69 64 61 74 65 73 29 29 29 0a 28 64 65 66 69 didates))).(defi
0180: 6e 65 20 63 61 6e 64 69 64 61 74 65 73 3a 76 6f ne candidates:vo
0190: 74 65 2d 73 75 6d 2d 70 6c 75 72 61 6c 69 74 79 te-sum-plurality
01a0: 20 28 61 70 70 6c 79 20 2b 20 28 6d 61 70 20 63 (apply + (map c
01b0: 61 6e 64 69 64 61 74 65 3a 67 65 74 2d 70 73 63 andidate:get-psc
01c0: 6f 72 65 20 63 61 6e 64 69 64 61 74 65 73 29 29 ore candidates))
01d0: 29 0a 28 64 65 66 69 6e 65 20 63 61 6e 64 69 64 ).(define candid
01e0: 61 74 65 73 3a 74 6f 70 2d 70 6c 75 72 61 6c 69 ates:top-plurali
01f0: 74 79 2d 69 64 20 20 20 28 6c 65 74 20 28 28 69 ty-id (let ((i
0200: 64 20 20 20 20 20 20 20 23 66 29 0a 09 09 09 09 d #f).....
0210: 09 20 20 20 20 28 74 6f 70 73 63 6f 72 65 20 30 . (topscore 0
0220: 29 29 0a 09 09 09 09 09 28 66 6f 72 2d 65 61 63 ))......(for-eac
0230: 68 20 28 6c 61 6d 62 64 61 20 28 63 61 6e 64 29 h (lambda (cand)
0240: 0a 09 09 09 09 09 09 20 20 20 20 28 69 66 20 28 ....... (if (
0250: 3e 20 28 63 61 6e 64 69 64 61 74 65 3a 67 65 74 > (candidate:get
0260: 2d 70 73 63 6f 72 65 20 63 61 6e 64 29 20 74 6f -pscore cand) to
0270: 70 73 63 6f 72 65 29 0a 09 09 09 09 09 09 09 28 pscore)........(
0280: 62 65 67 69 6e 20 0a 09 09 09 09 09 09 09 20 20 begin ........
0290: 28 73 65 74 21 20 74 6f 70 73 63 6f 72 65 20 28 (set! topscore (
02a0: 63 61 6e 64 69 64 61 74 65 3a 67 65 74 2d 70 73 candidate:get-ps
02b0: 63 6f 72 65 20 63 61 6e 64 29 29 0a 09 09 09 09 core cand)).....
02c0: 09 09 09 20 20 28 73 65 74 21 20 69 64 20 20 20 ... (set! id
02d0: 20 20 20 20 28 63 61 6e 64 69 64 61 74 65 3a 67 (candidate:g
02e0: 65 74 2d 69 64 20 63 61 6e 64 29 29 29 29 29 0a et-id cand))))).
02f0: 09 09 09 09 09 09 20 20 63 61 6e 64 69 64 61 74 ...... candidat
0300: 65 73 29 0a 09 09 09 09 09 69 64 29 29 0a 28 64 es)......id)).(d
0310: 65 66 69 6e 65 20 63 61 6e 64 69 64 61 74 65 73 efine candidates
0320: 3a 74 6f 70 2d 61 70 70 72 6f 76 61 6c 2d 69 64 :top-approval-id
0330: 20 20 20 28 6c 65 74 20 28 28 69 64 20 20 20 20 (let ((id
0340: 20 20 20 23 66 29 0a 09 09 09 09 09 20 20 20 28 #f)...... (
0350: 74 6f 70 73 63 6f 72 65 20 30 29 29 0a 09 09 09 topscore 0))....
0360: 09 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 . (for-eac
0370: 68 20 28 6c 61 6d 62 64 61 20 28 63 61 6e 64 29 h (lambda (cand)
0380: 0a 09 09 09 09 09 09 20 20 20 28 69 66 20 28 3e ....... (if (>
0390: 20 28 63 61 6e 64 69 64 61 74 65 3a 67 65 74 2d (candidate:get-
03a0: 73 63 6f 72 65 20 63 61 6e 64 29 20 74 6f 70 73 score cand) tops
03b0: 63 6f 72 65 29 0a 09 09 09 09 09 09 20 20 20 20 core).......
03c0: 20 20 20 28 62 65 67 69 6e 20 0a 09 09 09 09 09 (begin ......
03d0: 09 09 20 28 73 65 74 21 20 74 6f 70 73 63 6f 72 .. (set! topscor
03e0: 65 20 28 63 61 6e 64 69 64 61 74 65 3a 67 65 74 e (candidate:get
03f0: 2d 73 63 6f 72 65 20 63 61 6e 64 29 29 0a 09 09 -score cand))...
0400: 09 09 09 09 09 20 28 73 65 74 21 20 69 64 20 20 ..... (set! id
0410: 20 20 20 20 20 28 63 61 6e 64 69 64 61 74 65 3a (candidate:
0420: 67 65 74 2d 69 64 20 63 61 6e 64 29 29 29 29 29 get-id cand)))))
0430: 0a 09 09 09 09 09 09 20 63 61 6e 64 69 64 61 74 ....... candidat
0440: 65 73 29 0a 09 09 09 09 20 20 20 20 20 20 20 69 es)..... i
0450: 64 29 29 0a 09 09 09 09 09 09 09 20 20 20 0a 0a d))........ ..
0460: 28 64 65 66 69 6e 65 20 28 75 73 70 72 65 73 69 (define (uspresi
0470: 64 65 6e 74 2d 61 63 74 69 6f 6e 20 61 63 74 69 dent-action acti
0480: 6f 6e 29 0a 20 20 28 6c 65 74 20 28 28 61 63 73 on). (let ((acs
0490: 79 6d 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 ym (string->symb
04a0: 6f 6c 20 61 63 74 69 6f 6e 29 29 29 0a 20 20 20 ol action))).
04b0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 27 76 6f (cond. ('vo
04c0: 74 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 te. (let ((
04d0: 62 75 74 74 6f 6e 20 28 73 3a 67 65 74 2d 69 6e button (s:get-in
04e0: 70 75 74 20 27 76 6f 74 65 29 29 29 0a 09 28 63 put 'vote)))..(c
04f0: 6f 6e 64 0a 09 20 28 28 65 71 75 61 6c 3f 20 62 ond.. ((equal? b
0500: 75 74 74 6f 6e 20 22 56 6f 74 65 22 29 0a 09 20 utton "Vote")..
0510: 20 28 6c 65 74 2a 20 28 28 61 70 70 72 6f 76 61 (let* ((approva
0520: 6c 20 20 20 20 28 73 3a 67 65 74 2d 69 6e 70 75 l (s:get-inpu
0530: 74 20 27 61 70 70 72 6f 76 61 6c 29 29 0a 09 09 t 'approval))...
0540: 20 28 70 6c 75 72 61 6c 69 74 79 20 20 20 28 73 (plurality (s
0550: 3a 67 65 74 2d 69 6e 70 75 74 20 27 70 6c 75 72 :get-input 'plur
0560: 61 6c 69 74 79 29 29 0a 09 09 20 28 6e 65 77 64 ality))... (newd
0570: 61 74 20 20 20 20 20 20 28 6d 61 6b 65 2d 76 65 at (make-ve
0580: 63 74 6f 72 20 39 20 22 22 29 29 0a 09 09 20 28 ctor 9 ""))... (
0590: 65 6d 61 69 6c 20 20 20 20 20 20 20 28 73 3a 73 email (s:s
05a0: 65 73 73 69 6f 6e 2d 76 61 72 2d 67 65 74 20 22 ession-var-get "
05b0: 65 6d 61 69 6c 22 29 29 0a 09 09 20 28 6e 65 77 email"))... (new
05c0: 63 61 6e 64 6e 61 6d 65 20 28 73 3a 67 65 74 2d candname (s:get-
05d0: 69 6e 70 75 74 20 27 70 6f 6c 6c 5f 6e 61 6d 65 input 'poll_name
05e0: 29 29 0a 09 09 20 28 6e 69 63 6b 2d 65 6d 61 69 ))... (nick-emai
05f0: 6c 20 20 28 69 66 20 65 6d 61 69 6c 20 65 6d 61 l (if email ema
0600: 69 6c 20 28 73 3a 67 65 74 2d 69 6e 70 75 74 20 il (s:get-input
0610: 27 75 73 65 72 73 5f 65 6d 61 69 6c 29 29 29 29 'users_email))))
0620: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
0630: 6c 69 73 74 3f 20 61 70 70 72 6f 76 61 6c 29 29 list? approval))
0640: 0a 09 09 28 73 65 74 21 20 61 70 70 72 6f 76 61 ...(set! approva
0650: 6c 20 28 6c 69 73 74 20 61 70 70 72 6f 76 61 6c l (list approval
0660: 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 73 74 ))).. (if (st
0670: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
0680: 78 70 20 22 5e 5b 61 2d 7a 41 2d 5a 5d 2b 22 29 xp "^[a-zA-Z]+")
0690: 20 6e 65 77 63 61 6e 64 6e 61 6d 65 29 0a 09 09 newcandname)...
06a0: 28 6c 65 74 2a 20 28 28 64 61 74 20 28 63 61 6e (let* ((dat (can
06b0: 64 69 64 61 74 65 3a 67 65 74 2d 62 79 2d 6e 61 didate:get-by-na
06c0: 6d 65 20 6e 65 77 63 61 6e 64 6e 61 6d 65 29 29 me newcandname))
06d0: 29 0a 09 09 20 20 28 69 66 20 64 61 74 20 3b 3b )... (if dat ;;
06e0: 20 69 2e 65 2e 20 74 68 69 73 20 69 73 20 61 20 i.e. this is a
06f0: 6e 65 77 20 63 61 6e 64 69 64 61 74 65 0a 09 09 new candidate...
0700: 20 20 20 20 20 20 28 73 65 74 21 20 6e 65 77 64 (set! newd
0710: 61 74 20 64 61 74 29 0a 09 09 20 20 20 20 20 20 at dat)...
0720: 28 62 65 67 69 6e 0a 09 09 09 28 63 61 6e 64 69 (begin....(candi
0730: 64 61 74 65 3a 73 65 74 2d 6e 61 6d 65 21 20 6e date:set-name! n
0740: 65 77 64 61 74 20 6e 65 77 63 61 6e 64 6e 61 6d ewdat newcandnam
0750: 65 29 0a 09 09 09 28 63 61 6e 64 69 64 61 74 65 e)....(candidate
0760: 3a 73 65 74 2d 73 75 70 70 6f 72 74 73 2d 61 76 :set-supports-av
0770: 21 20 6e 65 77 64 61 74 20 28 73 3a 67 65 74 2d ! newdat (s:get-
0780: 69 6e 70 75 74 20 27 70 6f 6c 6c 5f 73 75 70 70 input 'poll_supp
0790: 6f 72 74 73 5f 61 76 29 29 0a 09 09 09 28 63 61 orts_av))....(ca
07a0: 6e 64 69 64 61 74 65 3a 73 65 74 2d 70 61 72 74 ndidate:set-part
07b0: 79 21 20 6e 65 77 64 61 74 20 28 73 3a 67 65 74 y! newdat (s:get
07c0: 2d 69 6e 70 75 74 20 27 70 6f 6c 6c 5f 70 61 72 -input 'poll_par
07d0: 74 79 29 29 0a 09 09 09 28 63 61 6e 64 69 64 61 ty))....(candida
07e0: 74 65 3a 73 65 74 2d 75 72 6c 21 20 6e 65 77 64 te:set-url! newd
07f0: 61 74 20 28 73 3a 67 65 74 2d 69 6e 70 75 74 20 at (s:get-input
0800: 27 70 6f 6c 6c 5f 75 72 6c 29 29 0a 09 09 09 28 'poll_url))....(
0810: 73 65 74 21 20 6e 65 77 64 61 74 20 28 63 61 6e set! newdat (can
0820: 64 69 64 61 74 65 3a 75 70 64 61 74 65 20 6e 65 didate:update ne
0830: 77 64 61 74 29 29 29 29 0a 09 09 20 20 28 73 3a wdat))))... (s:
0840: 6c 6f 67 20 22 63 69 64 3a 20 22 20 28 63 61 6e log "cid: " (can
0850: 64 69 64 61 74 65 3a 67 65 74 2d 69 64 20 6e 65 didate:get-id ne
0860: 77 64 61 74 29 29 0a 09 09 20 20 28 73 65 74 21 wdat))... (set!
0870: 20 61 70 70 72 6f 76 61 6c 20 20 28 63 6f 6e 73 approval (cons
0880: 20 28 63 61 6e 64 69 64 61 74 65 3a 67 65 74 2d (candidate:get-
0890: 69 64 20 6e 65 77 64 61 74 29 20 61 70 70 72 6f id newdat) appro
08a0: 76 61 6c 29 29 0a 09 09 20 20 28 73 65 74 21 20 val))... (set!
08b0: 70 6c 75 72 61 6c 69 74 79 20 28 63 61 6e 64 69 plurality (candi
08c0: 64 61 74 65 3a 67 65 74 2d 69 64 20 6e 65 77 64 date:get-id newd
08d0: 61 74 29 29 29 29 0a 09 20 20 20 20 28 73 65 74 at)))).. (set
08e0: 21 20 61 70 70 72 6f 76 61 6c 20 28 66 69 6c 74 ! approval (filt
08f0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6f er (lambda (x)(o
0900: 72 20 28 6e 75 6d 62 65 72 3f 20 78 29 28 73 74 r (number? x)(st
0910: 72 69 6e 67 3f 20 78 29 29 29 20 61 70 70 72 6f ring? x))) appro
0920: 76 61 6c 29 29 20 3b 3b 20 63 6c 65 61 6e 20 74 val)) ;; clean t
0930: 68 65 20 61 70 70 72 6f 76 61 6c 20 6c 69 73 74 he approval list
0940: 0a 09 20 20 20 20 28 73 3a 6c 6f 67 20 22 75 73 .. (s:log "us
0950: 69 6e 67 20 65 6d 61 69 6c 3a 20 22 20 6e 69 63 ing email: " nic
0960: 6b 2d 65 6d 61 69 6c 29 0a 09 20 20 20 20 28 73 k-email).. (s
0970: 3a 6c 6f 67 20 22 61 70 70 72 6f 76 61 6c 3a 20 :log "approval:
0980: 22 20 61 70 70 72 6f 76 61 6c 29 0a 09 20 20 20 " approval)..
0990: 20 28 73 3a 6c 6f 67 20 22 70 6c 75 72 61 6c 69 (s:log "plurali
09a0: 74 79 3a 20 22 20 70 6c 75 72 61 6c 69 74 79 29 ty: " plurality)
09b0: 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 61 .. (if (and a
09c0: 70 70 72 6f 76 61 6c 20 70 6c 75 72 61 6c 69 74 pproval pluralit
09d0: 79 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 61 70 y (not (null? ap
09e0: 70 72 6f 76 61 6c 29 29 29 0a 09 09 28 62 65 67 proval)))...(beg
09f0: 69 6e 0a 09 09 20 20 28 76 6f 74 69 6e 67 3a 68 in... (voting:h
0a00: 61 6e 64 6c 65 2d 76 6f 74 65 73 20 6e 69 63 6b andle-votes nick
0a10: 2d 65 6d 61 69 6c 0a 09 09 09 09 20 20 20 20 20 -email.....
0a20: 20 20 61 70 70 72 6f 76 61 6c 0a 09 09 09 09 20 approval.....
0a30: 20 20 20 20 20 20 70 6c 75 72 61 6c 69 74 79 29 plurality)
0a40: 0a 09 09 20 20 28 73 3a 73 65 73 73 69 6f 6e 2d ... (s:session-
0a50: 76 61 72 2d 73 65 74 21 20 22 76 6f 74 65 64 22 var-set! "voted"
0a60: 20 22 79 65 73 22 29 29 0a 09 09 28 73 3a 73 65 "yes"))...(s:se
0a70: 74 21 20 22 65 72 72 6d 73 67 22 20 22 50 6c 65 t! "errmsg" "Ple
0a80: 61 73 65 20 73 65 6c 65 63 74 20 6f 6e 65 20 70 ase select one p
0a90: 6c 75 72 61 6c 69 74 79 20 76 6f 74 65 20 61 6e lurality vote an
0aa0: 64 20 6f 6e 65 20 6f 72 20 6d 6f 72 65 20 61 70 d one or more ap
0ab0: 70 72 6f 76 61 6c 20 76 6f 74 65 73 22 29 29 29 proval votes")))
0ac0: 29 29 29 29 29 29 29 0a ))))))).