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

Last change on this file since 18259 was 18259, checked in by Moritz Heidkamp, 11 years ago

vandusen: initial import

File size: 2.3 KB
Line 
1(module vandusen-poll ()
2
3        (import chicken scheme srfi-1 extras data-structures)
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) ,choice (* "," (* space) ,choice (* space)))
15                           (lambda (m question . choices)
16                             (let ((poll-idx (length polls)))
17
18                               (set! polls (append polls (list (cons question choices))))
19                               (set! all-choices (append all-choices (map (cut cons poll-idx <>) choices)))
20
21                               (let* ((idx (iota (length choices) (add1 (- (length all-choices) (length choices)))))
22                                      (choices (map (cut format "~A) ~A" <> <>) idx choices))
23                                      (choices (string-intersperse choices ", ")))
24
25                                 (reply-to m (format "Poll #~A is now open: ~A" (add1 poll-idx) choices) prefixed: #f)))))
26
27                  (command 'vote
28                           '(: "vote" (+ space) (submatch (+ any)))
29                           (lambda (m choice)
30                             (let* ((choice-idx (string->number choice)))
31                               (if (and choice-idx (<= choice-idx (length all-choices)))
32                                   (let* ((choice-idx (sub1 choice-idx))
33                                          (voter      (string->symbol (car (irc:message-prefix m))))
34                                          (choice     (list-ref all-choices choice-idx))
35                                          (poll       (car choice))
36                                          (choice     (cdr choice))
37                                          (votes      (or (alist-ref poll all-votes) '())))
38                                     (set! all-votes (alist-update! poll (alist-update! voter choice-idx votes) all-votes))
39                                     (reply-to m (format "voted ~A" choice)))
40                                   (reply-to m (format "invalid choice: ~A" choice)))))
41                           public: #t)
42
43                  (command 'poll-results
44                           '(: "poll #" (submatch (+ num)))
45                           (lambda (m poll)
46                             (let* ((poll  (sub1 (string->number poll)))
47                                    (votes (alist-ref poll all-votes))
48                                    (result (fold (lambda (vote result)
49                                                    (alist-update! (cdr vote) 
50                                                                   (add1 (or (alist-ref (cdr vote) result) 0))
51                                                                   result))
52                                                  '()
53                                                  votes))
54                                    (result (map (lambda (r) 
55                                                   (cons (cdr (list-ref all-choices (car r))) (cdr r)))
56                                                 result))
57                                    (result (sort result (compose > cdr)))
58                                    (result (map (lambda (r) (format "~A: ~A" (car r) (cdr r))) result))
59                                    (result (string-intersperse result ", ")))
60                               (reply-to m (->string result) prefixed: #f)))))))
Note: See TracBrowser for help on using the repository browser.