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

(module vandusen-poll ()

        (import chicken scheme srfi-1 extras data-structures)
        (use vandusen irc)

        (plugin 'poll
                (lambda ()
                  (define polls '())
                  (define all-choices '())
                  (define choice '(submatch (+ (~ #\,))))
                  (define all-votes '())
                  
                  (command 'poll
                           `(: "poll" (+ space) (submatch (+ (~ #\:))) ":" (* space) ,choice (* "," (* space) ,choice (* space)))
                           (lambda (m question . choices)
                             (let ((poll-idx (length polls)))

                               (set! polls (append polls (list (cons question choices))))
                               (set! all-choices (append all-choices (map (cut cons poll-idx <>) choices)))

                               (let* ((idx (iota (length choices) (add1 (- (length all-choices) (length choices)))))
                                      (choices (map (cut format "~A) ~A" <> <>) idx choices))
                                      (choices (string-intersperse choices ", ")))

                                 (reply-to m (format "Poll #~A is now open: ~A" (add1 poll-idx) choices) prefixed: #f)))))

                  (command 'vote
                           '(: "vote" (+ space) (submatch (+ any)))
                           (lambda (m choice)
                             (let* ((choice-idx (string->number choice)))
                               (if (and choice-idx (<= choice-idx (length all-choices)))
                                   (let* ((choice-idx (sub1 choice-idx))
                                          (voter      (string->symbol (car (irc:message-prefix m))))
                                          (choice     (list-ref all-choices choice-idx))
                                          (poll       (car choice))
                                          (choice     (cdr choice))
                                          (votes      (or (alist-ref poll all-votes) '())))
                                     (set! all-votes (alist-update! poll (alist-update! voter choice-idx votes) all-votes))
                                     (reply-to m (format "voted ~A" choice)))
                                   (reply-to m (format "invalid choice: ~A" choice)))))
                           public: #t)

                  (command 'poll-results
                           '(: "poll #" (submatch (+ num)))
                           (lambda (m poll)
                             (let* ((poll  (sub1 (string->number poll)))
                                    (votes (alist-ref poll all-votes))
                                    (result (fold (lambda (vote result)
                                                    (alist-update! (cdr vote) 
                                                                   (add1 (or (alist-ref (cdr vote) result) 0))
                                                                   result))
                                                  '()
                                                  votes))
                                    (result (map (lambda (r) 
                                                   (cons (cdr (list-ref all-choices (car r))) (cdr r)))
                                                 result))
                                    (result (sort result (compose > cdr)))
                                    (result (map (lambda (r) (format "~A: ~A" (car r) (cdr r))) result))
                                    (result (string-intersperse result ", ")))
                               (reply-to m (->string result) prefixed: #f)))))))