From 62183262dbff2f53fff16fe722b5313197555471 Mon Sep 17 00:00:00 2001
From: David Florness <david@florness.com>
Date: Sun, 8 Mar 2020 14:48:41 -0600
Subject: [PATCH] Use new ballot TUI in client

---
 ballot-tui.rkt | 15 ++++++----
 client.rkt     | 78 ++++++++++++++++++--------------------------------
 2 files changed, 38 insertions(+), 55 deletions(-)

diff --git a/ballot-tui.rkt b/ballot-tui.rkt
index e2bc6d0..a42ce83 100644
--- a/ballot-tui.rkt
+++ b/ballot-tui.rkt
@@ -1,13 +1,15 @@
 #lang racket/base
 
+(require racket/contract)
 (require racket/list)
+(require racket/set)
 
 (require charterm)
 
-(define (get-vote candidates)
+(define/contract (get-vote candidates)
+  (-> (non-empty-listof string?) (listof set?))
   (let* ([n (length candidates)]
-         [prefs (make-hash (for/list ([cand candidates])
-                             (cons cand n)))]
+         [prefs (make-hash (for/list ([i n]) (cons i n)))]
          [data-line 2])
     (with-charterm
       (charterm-clear-screen)
@@ -37,7 +39,7 @@
                 (if (and keynum (<= 49 keynum 57))
                     (let ([val (- keynum 49)])
                       (when (< cursor-line n)
-                        (hash-set! prefs (list-ref candidates cursor-line) val)
+                        (hash-set! prefs cursor-line val)
                         (charterm-display (bytes keynum)))
                       (loop-fast-next-key cursor-line))
                     (case keycode
@@ -51,7 +53,8 @@
                                      (partition (λ (e)
                                                   (eqv? (cdr e) (cdr p)))
                                                 rst)])
-                                 (cons (cons (car p) (map car same-rank))
+                                 (cons (set-add (list->set (map car same-rank))
+                                                (car p))
                                        (if (empty? rst)
                                            empty
                                            (loop (car rst) (cdr rst)))))))
@@ -68,3 +71,5 @@
                       [else
                        (loop-fast-next-key cursor-line)])))
               (loop-fast-next-key cursor-line)))))))
+
+(provide get-vote)
diff --git a/client.rkt b/client.rkt
index 6e6d188..c6f1f9e 100644
--- a/client.rkt
+++ b/client.rkt
@@ -41,6 +41,8 @@
 
 (require "merkle.rkt")
 (require "poly.rkt")
+(require/typed "ballot-tui.rkt"
+  [get-vote (-> (Listof String) (Listof (Setof Natural)))])
 
 (define (integer->hex-string [n : Integer])
   (bytes->hex-string
@@ -85,57 +87,33 @@
                       Positive-Integer))
   (newline)
 
-  (displayln "Candidates:")
-  (for ([i (in-naturals)]
-        [c candidates])
-    (displayln (format "~a) ~a" (add1 i) c)))
-
   (define vote
-    (let loop : Integer ()
-         (with-handlers ([exn:fail:user?
-                          (λ ([e : exn])
-                            (displayln (exn-message e))
-                            (loop))])
-           (let ([entries
-                  (map
-                   (λ ([s : String]) : Integer
-                      (let ([entry (assert (string->number s)
-                                           exact-integer?)])
-                        (when (or (< entry 1) (> entry cand-count))
-                          (raise-user-error
-                           (format "every entry in your ballot should be a valid integer ∈ [~a,~a]"
-                                   1 cand-count)))
-                        (sub1 entry)))
-                   (string-split
-                    (readline
-                     "Rank the candidates (most to least preferable): ")))])
-             (when (not (members-unique? entries))
-               (raise-user-error "every entry in your ballot must be unique"))
-             (let* ([m cand-count]
-                    [n m]
-                    [arr (array->mutable-array
-                          (make-array (vector m n) 0))])
-               (let loop ([entry (car entries)]
-                          [rst (cdr entries)]
-                          [remaining (set-remove (list->set (range cand-count))
-                                                 (car entries))])
-                 (for ([other remaining])
-                   (array-set! arr (vector entry other) 1))
-                 (when (not (empty? rst))
-                   (loop (car rst) (cdr rst) (set-remove remaining (car rst)))))
-               (bytes->integer
-                (for*/fold : Bytes
-                    ([bstr : Bytes #""])
-                    ([i : Natural (in-range m)]
-                     [j : Natural (in-range n)])
-                  (bytes-append bstr
-                                (integer->bytes
-                                 (array-ref arr (vector i j))
-                                 (cast
-                                  (min (integer-bytes-length peer-count #t) 1)
-                                  Positive-Integer)
-                                 #t)))
-                #t))))))
+    (let* ([vote (get-vote candidates)]
+           [m    cand-count]
+           [n    m]
+           [arr (array->mutable-array
+                 (make-array (vector m n) 0))])
+      (let loop ([rank      (car vote)]
+                 [rst       (cdr vote)]
+                 [remaining (set-subtract (list->set (range m)) (car vote))])
+        (for ([cand rank])
+          (for ([other remaining])
+            (array-set! arr (vector cand other) 1)))
+        (when (not (empty? rst))
+          (loop (car rst) (cdr rst) (set-subtract remaining (car rst)))))
+      (bytes->integer
+       (for*/fold : Bytes
+           ([bstr : Bytes #""])
+           ([i : Natural m]
+            [j : Natural n])
+         (bytes-append bstr
+                       (integer->bytes
+                        (array-ref arr (vector i j))
+                        (cast
+                         (max (integer-bytes-length peer-count #t) 1)
+                         Positive-Integer)
+                        #t)))
+       #t)))
 
   (displayln "committing poly...")
   (define poly (random-poly
-- 
2.38.4