# XXX on pil64 works after v16.1.10
#
(load "sha512.l")

(de modulo (X Y)
   (% (+ Y (% X Y)) Y) )
(de hexL (Lst)
   (make
      (while (cut 2 'Lst)
         (link (hex (pack @))) ) ) )
(de L2hex (Lst)
   (lowc
      (pack
         (mapcar '((B) (pad 2 (hex B))) Lst) ) ) )
(de steps (E)
   (flip
      (make
         (while
            (and
               (link (swap 'E (/ E 2)))
               (gt0 E) ) ) ) ) )
(de expmod- (B E M)
   (println 'B B 'E E 'M M)
   (let R 1
      (for I (steps E)
         (and
            (setq R (modulo (* R R) M))
            (bit? 1 I)
            (setq R (modulo (* R B) M)) ) )
      (println 'R R)
      R ) )
(de expmod (B E M)
   (if (=0 E)
      1
      (let R
         (%
            (** (expmod B (/ E 2) M) 2)
            M )
         (when (bit? 1 E)
            (setq R (modulo (* R B) M)) )
         R ) ) )
(de inv (X)
   (expmod X (- *Q 2) *Q) )
(de xrecover (Y)
   (let
      (YY (* Y Y)
         XX (* (dec YY) (inv (inc (* *D YY))))
         X (expmod XX (/ (+ *Q 3) 8) *Q) )
      (and
         (n0 (% (- (* X X) XX) *Q))
         (setq X (% (* *I X) *Q)) )
      (and
         (n0 (% X 2))
         (setq X (- *Q X)) )
      X ) )
(setq *S (0 -1 -2 -3 -4 -5 -6 -7 .))
(setq *B 256)
(setq *Q `(- (** 2 255) 19))
(setq *L `(+ (** 2 252) 27742317777372353535851937790883648493))
(setq *D `(* -121665 (inv 121666)))
(setq *I `(expmod 2 (/ (dec *Q) 4) *Q))
(setq *By `(* 4 (inv 5)))
(setq *Bxy
   (cons
      (% (xrecover *By) *Q)
      (% *By *Q) ) )
(de edwards (P Q)
   (let
      (X1 (car P)
         Y1 (cdr P)
         X2 (car Q)
         Y2 (cdr Q) )
      (cons
         (%
            (*
               (+ (* X1 Y2) (* X2 Y1))
               (inv (inc (* *D X1 X2 Y1 Y2))) )
            *Q )
         (%
            (*
               (+ (* Y1 Y2) (* X1 X2))
               (inv (- 1 (* *D X1 X2 Y1 Y2))) )
            *Q ) ) ) )
(de scalarmult-OLD (P E)
   (let Q (cons 0 1)
      (for I (steps E)
         (and
            (setq Q (edwards Q Q))
            (bit? 1 I)
            (setq Q (edwards Q P)) ) )
      Q ) )
(de scalarmult (P E)
   (if (=0 E)
      (cons 0 1)
      (let Q (scalarmult P (/ E 2))
         (setq Q (edwards Q Q))
         (when (bit? 1 E)
            (setq Q (edwards Q P)) )
         Q ) ) )
(de isoncurve (P)
   (let
      (X (car P)
         Y (cdr P)
         XX (* X X)
         YY (* Y Y) )
      (=0
         (modulo
            (-
               (+ (* -1 XX) YY)
               1
               (* *D XX YY) )
            *Q ) ) ) )
(de bits (Y B)
   (make
      (for (I 0 (> B I) (inc I))
         (link (or (bit? 1 (>> I Y)) 0)) ) ) )
(de ints (Lst)
   (make
      (do 32
         (link
            (sum
               '((L) (>> (pop '*S) L))
               (cut 8 'Lst) ) ) ) ) )
(de encodeint (Y)
   (ints (bits Y *B)) )
(de encodepoint (P)
   (ints
      (append
         (bits (cdr P) (dec *B))
         (cons (or (bit? 1 (car P)) 0)) ) ) )
(de bit (L I)
   (bit?
      1
      (>>
         (% I 8)
         (get L (inc (/ I 8)))) ) )
(de bitsum (S A B)
   (let R 0
      (for (I A (> B I) (inc I))
         (and
            (bit S I)
            (inc 'R (** 2 I)) ) )
      R ) )
(de decodeint (S)
   (bitsum S 0 *B) )
(de decodepoint (S)
   (let
      (Y (bitsum S 0 (dec *B))
         X (xrecover Y)
         R NIL )
      (or
         (= (bit? 1 X) (bit S (dec *B)))
         (setq X (- *Q X)) )
      (setq R (cons X Y))
      (or (isoncurve R) (quit "decoding point that is not on curve"))
      R ) )
(de Hint (Lst)
   (bitsum (sha512 Lst) 0 (* 2 *B)) )
(de publickey (Lst)
   (let A
      (+
         `(** 2 (- *B 2))
         (bitsum (sha512 Lst) 3 `(- *B 2)) )
      (encodepoint (scalarmult *Bxy A)) ) )
(de signature (M SK PK)
   (let
      (H (sha512 SK)
         A (+ `(** 2 (- *B 2)) (bitsum H 3 `(- *B 2)))
         r
         (Hint
            (append (head 32 (nth H `(inc 32))) M) )
         R (scalarmult *Bxy r)
         S
         (%
            (+
               r
               (* A (Hint (append (encodepoint R) PK M))) )
            *L ) )
      (append (encodepoint R) (encodeint S)) ) )
(de checkvalid (S M PK)
   (or
      (= `(/ *B 4) (length S))
      (quit "signature length is wrong") )
   (or
      (= `(/ *B 8) (length PK))
      (quit "public-key length is wrong") )
   (let
      (R (decodepoint (head 32 S))
         A (decodepoint PK)
         S (decodeint (head 32 (nth S `(inc 32))))
         H (Hint
            (append
               (encodepoint R)
               PK
               M ) ) )
      (= (scalarmult *Bxy S) (edwards R (scalarmult A H))) ) )