~edwargix/tallyard

cfc4193ef58d64163477248651a18193b6d99c5e — David Florness 5 years ago 52b6b15
Implement the Schulze method for our preferential voting system

This is used by Gentoo and Debian for their elections.

https://en.wikipedia.org/wiki/Schulze_method
1 files changed, 79 insertions(+), 17 deletions(-)

M client.rkt
M client.rkt => client.rkt +79 -17
@@ 131,8 131,9 @@
                  (bytes-append bstr
                                (integer->bytes
                                 (array-ref arr (vector i j))
                                 (cast (min (integer-bytes-length peer-count #t) 1)
                                       Positive-Integer)
                                 (cast
                                  (min (integer-bytes-length peer-count #t) 1)
                                  Positive-Integer)
                                 #t)))
                #t))))))



@@ 221,18 222,79 @@
       Integer)))
  (newline)

  (let* ([partial-size (cast (integer-bytes-length peer-count #t) Positive-Integer)]
         [bstr (integer->bytes constant (* partial-size cand-count cand-count) #t)]
         [arr (for/array: #:shape (vector cand-count cand-count)
                  ([section : Natural (in-range 0 (bytes-length bstr) partial-size)])
                : Integer
                (bytes->integer bstr #t #t section (+ section partial-size)))]
         [candidates (list->vector candidates)])
    (for* ([i (in-range cand-count)]
           [j (in-range cand-count)]
           #:when (< i j))
      (displayln (format "~a over ~a: ~a"
                         (vector-ref candidates i)
                         (vector-ref candidates j)
                         (- (array-ref arr (vector i j))
                            (array-ref arr (vector j i))))))))
  (displayln ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; RESULTS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;")
  (define pairwise-prefs
    (let* ([partial-size (cast (integer-bytes-length peer-count #t)
                               Positive-Integer)]
           [bstr (integer->bytes constant
                                 (* partial-size cand-count cand-count)
                                 #t)]
           [arr (for/array: #:shape (vector cand-count cand-count)
                    ([section : Natural (in-range 0
                                                  (bytes-length bstr)
                                                  partial-size)])
                  : Integer
                  (bytes->integer bstr #t #t section
                                  (+ section partial-size)))]
           [candidates (list->vector candidates)])
      (for*/hash : (HashTable (Pairof Natural Natural) Integer)
          ([i cand-count]
           [j cand-count]
           #:when (not (eqv? i j)))
        (values (cons i j)
                (let ([prefer-i-over-j (array-ref arr (vector i j))])
                  (displayln (format "~a over ~a: ~a"
                                     (vector-ref candidates i)
                                     (vector-ref candidates j)
                                     prefer-i-over-j))
                  prefer-i-over-j)))))

  (define strongest-paths
    (let ([p : (HashTable (Pairof Natural Natural) Integer)
             (make-hash)])
      (for* ([i cand-count]
             [j cand-count]
             #:when (not (eqv? i j)))
        (hash-set! p (cons i j)
                   (if (> (hash-ref pairwise-prefs (cons i j))
                          (hash-ref pairwise-prefs (cons j i)))
                       (hash-ref pairwise-prefs (cons i j))
                       0)))
      (for* ([i cand-count]
             [j cand-count]
             #:when (not (eqv? i j))
             [k cand-count]
             #:when (and (not (eqv? i k)) (not (eqv? j k))))
        (hash-update! p (cons j k)
                      (λ ([c : Integer])
                        (cast
                         (max c (min (hash-ref p (cons j i))
                                     (hash-ref p (cons i k))))
                         Integer))))
      p))

  (define rankings
    (let loop : (Listof (Setof Natural))
         ([remaining : (Setof Natural)
                     (list->set (range cand-count))])
         (if (set-empty? remaining)
             empty
             (let ([winners
                    (for/set : (Setof Natural)
                        ([cand : Natural remaining]
                         #:when
                         (for/and : Boolean
                             ([other : Natural remaining]
                              #:when (not (eqv? cand other)))
                           (>= (hash-ref strongest-paths
                                         (cons cand other))
                               (hash-ref strongest-paths
                                         (cons other cand)))))
                      cand)])
               (cons winners (loop (set-subtract remaining winners)))))))

  (displayln "Rankings:")
  (for ([i (in-naturals)]
        [rank rankings])
    (for ([r rank])
      (displayln (format "~a) ~a" (add1 i) (list-ref candidates r))))))