3 files changed, 105 insertions(+), 51 deletions(-)

A ballot-tui.rkt
M client.rkt
M info.rkt

@@ 0,0 1,75 @@
+#lang racket/base
+
+(require racket/contract)
+(require racket/list)
+(require racket/set)
+
+(require charterm)
+
+(define/contract (get-vote candidates)
+  (-> (non-empty-listof string?) (listof set?))
+  (let* ([n (length candidates)]
+         [prefs (make-hash (for/list ([i n]) (cons i n)))]
+         [data-line 2])
+    (with-charterm
+      (charterm-clear-screen)
+      (for ([i (in-naturals data-line)]
+            [cand candidates])
+        (charterm-cursor 2 i)
+        (charterm-display "[ ] ")
+        (charterm-display cand))
+      (charterm-cursor 2 (+ 1 n data-line))
+      (charterm-display "[Submit]")
+      (let loop-fast-next-key ([cursor-line 0])
+        (if (>= cursor-line n)
+            (begin
+              (charterm-cursor 2 (+ 1 n data-line))
+              (charterm-display "[")
+              (charterm-inverse)
+              (charterm-display "Submit]")
+              (charterm-normal)
+              (charterm-cursor 2 (+ 1 n data-line)))
+            (charterm-cursor 3 (+ data-line cursor-line)))
+        (let ([keyinfo (charterm-read-keyinfo #:timeout 1)])
+          (if keyinfo
+              (let* ([keycode (charterm-keyinfo-keycode keyinfo)]
+                     [keynum  (if (char? keycode)
+                                  (char->integer keycode)
+                                  #f)])
+                (if (and keynum (<= 49 keynum 57))
+                    (let ([val (- keynum 49)])
+                      (when (< cursor-line n)
+                        (hash-set! prefs cursor-line val)
+                        (charterm-display (bytes keynum)))
+                      (loop-fast-next-key cursor-line))
+                    (case keycode
+                      [(return)
+                       (if (>= cursor-line n)
+                           (let ([prefs (sort (hash->list prefs) < #:key cdr)])
+                             (let loop ([p   (car prefs)]
+                                        [rst (cdr prefs)])
+                               (let-values
+                                   ([(same-rank rst)
+                                     (partition (λ (e)
+                                                  (eqv? (cdr e) (cdr p)))
+                                                rst)])
+                                 (cons (set-add (list->set (map car same-rank))
+                                                (car p))
+                                       (if (empty? rst)
+                                           empty
+                                           (loop (car rst) (cdr rst)))))))
+                           (loop-fast-next-key cursor-line))]
+                      [(ctrl-c)
+                       (raise exn:break)]
+                      [(down #\j)
+                       (loop-fast-next-key (min n (add1 cursor-line)))]
+                      [(up #\k)
+                       (when (>= cursor-line n)
+                         (charterm-cursor 2 (+ 1 n data-line))
+                         (charterm-display "[Submit]"))
+                       (loop-fast-next-key (max 0 (sub1 cursor-line)))]
+                      [else
+                       (loop-fast-next-key cursor-line)])))
+              (loop-fast-next-key cursor-line)))))))
+
+(provide get-vote)

@@ 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

@@ 1,6 1,7 @@
 #lang info
 (define collection "tallyard")
-(define deps '("base" "crypto" "sha" "simple-http" "sugar" "get-pass"))
+(define deps '("base" "charterm" "crypto" "get-pass"
+                      "sha" "simple-http" "sugar"))
 (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib"))
 (define scribblings '(("scribblings/tallyard.scrbl" ())))
 (define pkg-desc "Description Here")