From 62ad1cfc379768603b5e84adf41919068d81a17c Mon Sep 17 00:00:00 2001
From: David Florness <david@florness.com>
Date: Sun, 23 Feb 2020 00:36:50 -0700
Subject: [PATCH] Encode ranked voting

---
 client.rkt | 62 ++++++++++++++++++++++++++++++++++++++++++++++++------
 info.rkt   |  2 +-
 2 files changed, 56 insertions(+), 8 deletions(-)

diff --git a/client.rkt b/client.rkt
index e86bc5d..a48d435 100644
--- a/client.rkt
+++ b/client.rkt
@@ -1,4 +1,5 @@
 #lang typed/racket
+(require math/array)
 (require math/matrix)
 (require racket/list)
 (require racket/math)
@@ -34,6 +35,8 @@
 (require/typed crypto
   [crypto-random-bytes (Natural -> Bytes)])
 (require "poly.rkt")
+(require/typed sugar
+  [members-unique? (-> (Listof Any) Boolean)])
 
 (define (integer->hex-string [n : Integer])
   (bytes->hex-string
@@ -76,16 +79,61 @@
   (newline)
 
   (displayln "retrieving candidates...")
-  (define candidates (json-response-body (get bulletin "/candidates")))
+  (define candidates (cast (json-response-body
+                            (get bulletin "/candidates")) (Listof String)))
+
+  (displayln "Candidates:")
+  (for ([i (in-naturals)]
+        [c candidates])
+    (displayln (format "~a) ~a" (add1 i) c)))
 
   (define vote
     (let loop : Integer ()
-      (let [(n (string->number (readline "Vote: ")))]
-        (if (eq? n #f)
-            (begin
-              (displayln "Please enter a valid number")
-              (loop))
-            (assert n exact-integer?)))))
+         (with-handlers ([exn:fail:user?
+                          (λ ([e : exn])
+                            (displayln (exn-message e))
+                            (loop))])
+           (let* ([num-cands (length candidates)]
+                  [entries
+                   (map
+                    (λ ([s : String]) : Integer
+                       (let ([entry (assert (string->number s)
+                                            exact-integer?)])
+                         (if (and (>= entry 1) (<= entry num-cands))
+                             (sub1 entry)
+                             (raise-user-error
+                              (format "every entry in your ballot should be a valid integer ∈ [~a,~a]"
+                                      1 num-cands)))))
+                    (string-split
+                     (readline
+                      "Rank the candidates (most to least preferable): ")))])
+             (if (members-unique? entries)
+                 (let* ([m num-cands]
+                        [n m]
+                        [arr (array->mutable-array
+                              (make-array (vector m n) 0))]
+                        [num-peers (cast (length peer-inputs) Positive-Integer)])
+                   (let loop ([entry (car entries)]
+                              [rst (cdr entries)])
+                     (for ([other rst])
+                       (when (< entry other)
+                         (array-set! arr (vector entry other) 1)))
+                     (when (not (empty? rst))
+                       (loop (car rst) (cdr rst))))
+                   (bytes->integer
+                    (for*/fold : Bytes
+                       ([bstr : Bytes #""])
+                       ([i : Natural (in-range m)]
+                        [j : Natural (in-range n)]
+                        #:when (< i j))
+                     (bytes-append bstr
+                                   (integer->bytes
+                                    (array-ref arr (vector i j))
+                                    (cast (min (integer-bytes-length num-peers #t) 1)
+                                          Positive-Integer)
+                                    #t)))
+                    #t))
+                 (raise-user-error "every entry in your ballot must be unique"))))))
 
   (define poly (random-poly
                 (cast (sub1 (length peer-inputs)) Natural)
diff --git a/info.rkt b/info.rkt
index a4bbea3..6cf5943 100644
--- a/info.rkt
+++ b/info.rkt
@@ -1,6 +1,6 @@
 #lang info
 (define collection "tallyard")
-(define deps '("base" "crypto" "simple-http"))
+(define deps '("base" "crypto" "simple-http" "sugar"))
 (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
 (define scribblings '(("scribblings/tallyard.scrbl" ())))
 (define pkg-desc "Description Here")
-- 
2.38.4