From cfc4193ef58d64163477248651a18193b6d99c5e Mon Sep 17 00:00:00 2001
From: David Florness <david@florness.com>
Date: Wed, 4 Mar 2020 19:56:31 -0700
Subject: [PATCH] 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
---
 client.rkt | 96 ++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 79 insertions(+), 17 deletions(-)

diff --git a/client.rkt b/client.rkt
index 057cedc..6e01fc2 100644
--- a/client.rkt
+++ b/client.rkt
@@ -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))))))
-- 
2.38.4