source: project/release/4/vandusen/trunk/vandusen-poll.scm @ 21508

Last change on this file since 21508 was 18508, checked in by Moritz Heidkamp, 10 years ago

vandusen: allow for more than two choices in polls

File size: 2.8 KB
Line 
1(module vandusen-poll ()
2
3(import chicken scheme srfi-1 extras data-structures srfi-13)
4(use vandusen irc)
5
6(plugin 'poll
7        (lambda ()
8          (define polls '())
9          (define all-choices '())
10          (define choice '(submatch (+ (~ #\,))))
11          (define all-votes '())
12
13          (command 'poll
14                   `(: "poll" (+ space) (submatch (+ (~ #\:))) ":" (* space) (submatch (+ any)) (* space))
15                   (lambda (m question choices)
16                     (let ((choices  (map string-trim-both (string-split choices ",")))
17                           (poll-idx (length polls)))
18
19                       (set! polls (append polls (list (cons question choices))))
20                       (set! all-choices (append all-choices (map (cut cons poll-idx <>) choices)))
21
22                       (let* ((idx (iota (length choices) (add1 (- (length all-choices) (length choices)))))
23                              (choices (map (cut format "~A) ~A" <> <>) idx choices))
24                              (choices (string-intersperse choices ", ")))
25
26                         (reply-to m (format "poll #~A is now open: ~A" (add1 poll-idx) choices) prefixed: #f)))))
27
28          (command 'vote
29                   '(: "vote" (+ space) (submatch (+ any)))
30                   (lambda (m choice)
31                     (let* ((choice-idx (string->number choice)))
32                       (if (and choice-idx (<= choice-idx (length all-choices)) (> choice-idx 0))
33                           (let* ((choice-idx (sub1 choice-idx))
34                                  (voter      (string->symbol (car (irc:message-prefix m))))
35                                  (choice     (list-ref all-choices choice-idx))
36                                  (poll       (car choice))
37                                  (choice     (cdr choice))
38                                  (votes      (or (alist-ref poll all-votes) '())))
39                             (set! all-votes (alist-update! poll (alist-update! voter choice-idx votes) all-votes))
40                             (reply-to m (format "voted ~A" choice)))
41                           (reply-to m (format "invalid choice: ~A" choice)))))
42                   public: #t)
43                 
44          (command 'poll-results
45                   '(: "poll " (submatch (+ num)))
46                   (lambda (m given-poll)
47                     (unless (and-let* ((poll-idx (string->number given-poll))
48                                        (poll-idx (and (<= poll-idx (length polls))
49                                                       (> poll-idx 0)
50                                                       (sub1 poll-idx)))
51                                        (poll     (list-ref polls poll-idx))
52                                        (votes    (or (alist-ref poll-idx all-votes) '()))
53                                        (result   (fold (lambda (vote result)
54                                                          (alist-update! (cdr vote) 
55                                                                         (add1 (alist-ref (cdr vote) result))
56                                                                         result))
57                                                        (filter-map (lambda (choice idx)
58                                                                      (and (= poll-idx (car choice)) (cons idx 0)))
59                                                                    all-choices
60                                                                    (iota (length all-choices)))
61                                                        votes))
62                                        (result (map (lambda (r) 
63                                                       (cons (cdr (list-ref all-choices (car r))) (cdr r)))
64                                                     result))
65                                        (result (sort result (lambda (a b) (> (cdr a) (cdr b)))))
66                                        (result (map (lambda (r) (format "~A: ~A" (car r) (cdr r))) result))
67                                        (result (string-intersperse result ", ")))
68                               (reply-to m (conc (car poll) "\n" result) prefixed: #f))
69                                   
70                       (reply-to m (format "unknown poll: ~A" given-poll)))))))
71
72)
Note: See TracBrowser for help on using the repository browser.