(module elliptic-curve-arithmetic
  (ec+ ec- ec* on-elliptic-curve? with-elliptic-curve)
  (import
    scheme
    (chicken base)
    (chicken bitwise)
    (only (chicken memory representation) record-instance? record-instance-slot)
    srfi-1
    matchable
    modular-arithmetic elliptic-curve-parameters)
  (import-for-syntax
    scheme
    (chicken base)
    matchable)

;; Complex conjugate
(define (conj z)
  (make-rectangular (real-part z) (- (imag-part z))))

;; Elliptic curve point addition
(define (ec+ parameters)
  (match-let ([($ ec-parameters p a b _ _ _ _) parameters])
    (lambda Ps
      (fold
       (lambda (P A)
	 (cond
	  [(zero? A)
	   P]
	  [(zero? P)
	   A]
	  [(= P (conj A))
	   0]
	  [else
	   (with-modulus p
	     (let*-values ([(l x1 x2 y)
			    (if (= A P)
				(match-let ([(and (= real-part x) (= imag-part y)) A])
				  (values (/ (+ (* 3 x x) a) 2 y) x x y))
				(match-let ([(and (= real-part x1) (= imag-part y1)) A]
					    [(and (= real-part x2) (= imag-part y2)) P])
				  (values (/ (- y2 y1) (- x2 x1)) x1 x2 y1)))]
			   [(xR) (- (* l l) x1 x2)]
			   [(yR) (- (* l (- x1 xR)) y)])
	       (make-rectangular xR yR)))]))
       0 Ps))))

;; Elliptic curve point subtraction
(define (ec- parameters)
  (match-let ([+ (ec+ parameters)]
	      [($ ec-parameters p a b _ _ _ _) parameters])
    (case-lambda
     [(A)
      (conj A)]
     [(A . Ps)
      (apply + A (map conj Ps))])))

;; Elliptic curve point scalar multiplication
(define (ec* parameters)
  (let ([+ (ec+ parameters)])
    (lambda (P n)
      (let loop ([A 0]
                 [P (if (negative? n) (conj P) P)]
                 [n (abs n)])
        (if (positive? n)
	    (loop (if (zero? (bitwise-and n 1)) A (+ A P))
                  (+ P P)
                  (arithmetic-shift n -1))
            A)))))

;; Check whether a given point lies on an elliptic curve
(define (on-elliptic-curve? parameters P)
  (match-let ([($ ec-parameters p a b _ _ _ _) parameters]
	      [(and (= real-part x) (= imag-part y)) P])
    (with-modulus p
      (= (* y y) (+ (* x x x) (* a x) b)))))

;; Syntax to overload +, - and * with elliptic curve versions
(define-syntax with-elliptic-curve
  (er-macro-transformer
   (lambda (stx rename id=)
     (match stx
       [(with-elliptic-curve parameters body ...)
        (let ([~let (rename 'let)]
	      [~parameters (rename 'parameters)])
          `(,~let ([,~parameters ,parameters])
             (,~let ([+ (,(rename 'ec+) ,~parameters)]
		     [- (,(rename 'ec-) ,~parameters)]
		     [* (,(rename 'ec*) ,~parameters)])
               ,@body)))]))))

)

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;