; bigint.lisp - prototype implementation of bigint integers
;
; Copyright (C) 2026 by Jef Poskanzer <jef@mail.acme.com>.
; All rights reserved.
;
; You may use this software however you like as long as you keep my
; name on it and don't sue me.
;
; For commentary on this license please see http://acme.com/license.html
;
;
; Bigints are represented by a vector of component integers, which are to
; be multiplied by successive powers of bigint-radix. They are in little-endian
; order - the least-significant component first, the most-significant last.
; So for example, if a bigint was the vector:
;     [a b c d]
; then the actual number would be:
;     a + b*r + c*r^2 + d*r^3
;
; The radix is chosen assuming 64-bit integers. However we only want
; to use half the bits in each component - this uses more space but
; allows some speed optimizations. We also want to steer clear of
; the topmost bit. This means the radix is 2^31.
;
; The results seem to be correct. The performance is poor. The code
; quality is hackish.

(define bigint-radix-bits 31)
(doc 'bigint-radix-bits "Number of bits in each bigint component.")

(define bigint-radix (ash 1 bigint-radix-bits))
(doc 'bigint-radix "The radix of the bigint components.")

(define bigint-mradix (negate bigint-radix))
(doc 'bigint-mradix "Negative of the radix.")

; Puts b into normal form, which is:
;   - all components have the same sign
;   - all components < bigint-radix
;   - most-significant zero components removed
(defun bigint-norm ("vector" b)
    (progn
	;(fprintf stderr "bigint-norm\n")	;!!!
	(vector-fill-set! b 0)
	(bigint-norm-fix-signs b)
	(cond
	    ((bigint-negative? b) (bigint-norm-negative b))
	    (t
		(progn
		    (bigint-norm-carry-borrow b)
		    ;!!! need to call bigint-norm-fix-signs again here?
		    (bigint-norm-trim-leading-zeroes b)
		)
	    )
	)
	b
    )
)
(doc 'bigint-norm "Puts a bigint into normal form.")

(defun bigint-norm-fix-signs ("vector" b)
    (let*
	(sb (bigint-signum b))
	;(fprintf stderr "bigint-norm-fix-signs\n")	;!!!
	(for-seq 0 (+ (vector-length b) 1)	; add 1 in case of lengthening
	    (lambda (i)
		(let*
		    (c (vector-get b i))
		    (sc (signum c))
		    (ip1 (+ i 1))
		    (cp1 (vector-get b ip1))
		    (nc ())
		    (if (and (= sc -1) (= sb 1))
			; c is negative but should be positive
			(progn
;			    (until
;				(setq! c (+ c bigint-radix))
;				(setq! cp1 (- cp1 1))
;				(>= c 0)
;			    )
			    (setq! nc (mod c bigint-radix))
			    (setq! cp1 (- cp1 (truncate (/ (- nc c) bigint-radix))))
			    (setq! c nc)
			    (vector-set! b i c)
			    (vector-set! b ip1 cp1)
			)
			(if (and (= sc 1) (= sb -1))
			    ; c is positive but should be negative
			    (progn
;				(until
;				    (setq! c (- c bigint-radix))
;				    (setq! cp1 (+ cp1 1))
;				    (< c 0)
;				)
				(setq! nc (- (mod c bigint-radix) bigint-radix))
				(setq! cp1 (+ cp1 (truncate (/ (- c nc) bigint-radix))))
				(setq! c nc)
				(vector-set! b i c)
				(vector-set! b ip1 cp1)
			    )
			)
		    )
		)
	    )
	)
	b
    )
)
(doc 'bigint-norm-fix-signs "Helper function for bigint-norm. Makes sure all components have the same sign as the top component.")

(defun bigint-norm-negative ("vector" b)
    (letrec
	(negate-in-place
	    (lambda ()
		(for-seq 0 (vector-length b)
		    (lambda (i)
			(vector-set! b i (negate (vector-get b i)))
		    )
		)
	    )
	)
	;(fprintf stderr "bigint-norm-negative  b[0] %d\n" (vector-get b 0))	;!!!
	(negate-in-place b)
	;(fprintf stderr "negated  b[0] %d\n" (vector-get b 0))	;!!!
	(bigint-norm b)
	;(fprintf stderr "normed  b[0] %d\n" (vector-get b 0))	;!!!
	(negate-in-place b)
	;(fprintf stderr "regated  b[0] %d\n" (vector-get b 0))	;!!!
	b
    )
)
(doc 'bigint-norm-negative "Helper function for bigint-norm. The math is easier if we normalize as positive and then reconvert to negative.")

(defun bigint-norm-carry-borrow ("vector" b)
    (progn
	;(fprintf stderr "bigint-norm-carry-borrow\n")	;!!!
	(for-seq 0 (+ (vector-length b) 1)	; add 1 in case of lengthening
	    (lambda (i)
		(let*
		    (c (vector-get b i))
		    (ip1 (+ i 1))
		    (cond
			((>= c bigint-radix)
			    ; Carry for components larger than radix.
			    (progn
				(vector-set! b ip1 (+ (vector-get b ip1) (truncate (/ c bigint-radix))))
				(vector-set! b i (rem c bigint-radix))
			    )
			)
			((negative? c)
			    ; Borrow for negative components.
			    (progn
				(vector-set! b ip1 (- (vector-get b ip1) (truncate (/ c bigint-radix))))
				(vector-set! b i (rem c bigint-radix))
			    )
			)
		    )
		)
	    )
	)
	b
    )
)
(doc 'bigint-norm-carry-borrow "Helper function for bigint-norm. Does carrying and borrowing to make sure all components are less than the radix.")

(defun bigint-norm-trim-leading-zeroes ("vector" b)
    (progn
	;(fprintf stderr "bigint-norm-trim-leading-zeroes\n")	;!!!
	(while (and (> (vector-length b) 1) (= 0 (vector-get b (- (vector-length b) 1))))
	    (vector-length-set! b (- (vector-length b) 1))
	)
	b
    )
)
(doc 'bigint-norm-trim-leading-zeroes "Helper function for bigint-norm. Elides any leading zeroes.")

(defun bigint ("integer|vector|string" x)
    (bigint-norm
	(cond
	    ((integer? x) (vector 1 x 0))
	    ((vector? x)
		(let*
		    (len (vector-length x))
		    (res (vector len 0))
		    (for-seq 0 len
			(lambda (i) (vector-set! res i (vector-get x i)))
		    )
		    res
		)
	    )
	    ((string? x) (string-tobigint x))
	    (t (err "unknown type for bigint initialization"))
	)
    )
)
(doc 'bigint "Creates a bigint out of an integer, a vector, or a string.")

(defun bigint-map ("function" f "vector" b)
    (bigint-norm (vector-map f b))
)
(doc 'bigint-map "Calls the one-argument function f on the components of the bigint arg, returning a normalized result bigint.")

(defun bigint-map2 ("function" f "vector" b1 "vector" b2)
    (bigint-norm (vector-map2 f b1 b2))
)
(doc 'bigint-map2 "Calls the two-argument function f on the components of the two bigint args, returning a normalized result bigint.")

(defun bigint-signum ("vector" b)
    ; The sign of the bigint is the sign of the most significant component.
    (signum (vector-get b (- (vector-length b) 1)))
)
(doc 'bigint-signum "Returns a bigint's sign, which is -1, 0, or 1.")

(defun bigint-positive? ("vector" b)
    (= (bigint-signum b) 1)
)
(doc 'bigint-positive? "Returns t for positive bigints, nil for zero or negative.")

(defun bigint-zero? ("vector" b)
    (= (bigint-signum b) 0)
)
(doc 'bigint-zero? "Returns t for zero, nil for anything else.")

(defun bigint-negative? ("vector" b)
    (= (bigint-signum b) -1)
)
(doc 'bigint-negative? "Returns t for negative bigints, nil for zero or positive.")

(defun bigint-negate ("vector" b)
    (bigint-map negate b)
)
(doc 'bigint-negate "Returns the negative of the arg.")

(defun bigint-abs ("vector" b)
    (bigint-map abs b)
)
(doc 'bigint-abs "Returns the absolute value of the arg.")

(defun bigint-add-int ("vector" b "integer" n)
    (bigint-norm (vector-set! (bigint b) 0 (+ (vector-get b 0) n)))
)
(doc 'bigint-add-int "Adds an integer to a bigint.")

(defun bigint-add ("vector" b1 "vector" b2)
    (bigint-map2 + b1 b2)
)
(doc 'bigint-add "Adds two bigints.")

(defun bigint-subtract-int ("vector" b "integer" n)
    (bigint-norm (vector-set! (bigint b) 0 (- (vector-get b 0) n)))
)
(doc 'bigint-subtract-int "Subtracts an integer from a bigint.")

(defun bigint-subtract ("vector" b1 "vector" b2)
    (bigint-map2 - b1 b2)
)
(doc 'bigint-subtract "Subtracts one bigint from another.")

(defun bigint-multiply-int ("vector" b "integer" n)
    (bigint-map (lambda (x) (* x n)) b)
)
(doc 'bigint-multiply-int "Multiplies a bigint by an integer.")

(defun bigint-multiply ("vector" b1 "vector" b2)
    (cond
	; First check for trivial cases.
	((or (bigint-= b1 bigint-0) (bigint-= b2 bigint-0)) bigint-0)
	((bigint-= b1 bigint-1) b2)
	((bigint-= b2 bigint-1) b1)
	((and (bigint-negative? b1) (bigint-negative? b2)) (bigint-multiply (bigint-abs b1) (bigint-abs b2)))
	((bigint-negative? b1) (bigint-negate (bigint-multiply (bigint-abs b1) b2)))
	((bigint-negative? b2) (bigint-negate (bigint-multiply b1 (bigint-abs b2))))
	((= (vector-length b1) 1) (bigint-multiply-int b2 (vector-get b1 0)))
	((= (vector-length b2) 1) (bigint-multiply-int b1 (vector-get b2 0)))
	(t
	    ; Ok, here's the actual multiply algorithm.
	    (let*
		(l1 (vector-length b1))
		(l2 (vector-length b2))
		(lr (+ l1 l2))
		(res (vector lr 0))
		(for-seq 0 l1
		    (lambda (i1)
			(progn
			    (for-seq 0 l2
				(lambda (i2)
				    (let*
					(ir (+ i1 i2))
					(vector-set! res ir (+ (vector-get res ir) (* (vector-get b1 i1) (vector-get b2 i2))))
				    )
				)
			    )
			    (bigint-norm res)
			)
		    )
		)
		res
	    )
	)
    )
)
(doc 'bigint-multiply "Multiplies two bigints.")

(defun bigint-divide-int ("vector" numer "integer" denom)
    (let*
	(rm 0)
	(res (bigint 0))
	(for-seqby (- (vector-length numer) 1) -1 -1
	    (lambda (i)
		(progn
		    (setq! rm (+ (* rm bigint-radix) (vector-get numer i)))
		    (vector-set! res i (truncate (/ rm denom)))
		    (setq! rm (rem rm denom))
		)
	    )
	)
	(bigint-norm res)
    )
)
(doc 'bigint-divide-int "Divides a bigint by an integer.")

(defun bigint-divide ("vector" numer "vector" denom)
    (cond
	; First check for errors and trivial cases.
	((bigint-= denom bigint-0) (err "divide by zero"))
	((bigint-= numer bigint-0) bigint-0)
	((and (bigint-negative? numer) (bigint-negative? denom)) (bigint-divide (bigint-abs numer) (bigint-abs denom)))
	((bigint-negative? numer) (bigint-negate (bigint-divide (bigint-abs numer) denom)))
	((bigint-negative? denom) (bigint-negate (bigint-divide numer (bigint-abs denom))))
	((bigint-= numer denom) bigint-1)
	((bigint-< numer denom) bigint-0)
	((= (vector-length denom) 1) (bigint-divide-int numer (vector-get denom 0)))
	(t
	    ; Ok, here's the actual divide algorithm.
	    (let*
		(nbits (bigint-bits numer))
		(dbits (bigint-bits denom))
		(res bigint-0)
		(setq! denom (bigint-multiply denom (bigint-power bigint-2 (bigint (- nbits dbits)))))
		(for-seq dbits (+ nbits 1)
		    (lambda (i)
			(progn
			    (setq! res (bigint-double res))
			    (if (bigint->= numer denom)
				(progn
				    (setq! res (bigint-add-int res 1))
				    (setq! numer (bigint-subtract numer denom))
				)
			    )
			    (setq! denom (bigint-half denom))
			)
		    )
		)
		res
	    )
	)
    )
)
(doc 'bigint-divide "Divides one bigint by another.")

(defun bigint-rem-int ("vector" b "integer" m)
    (let*
	(rad-r 1)
	(res 0)
	(setq! m (abs m))
	(for-seq 0 (vector-length b)
	    (lambda (i)
		(progn
		    (setq! res (mod (+ res (* (vector-get b i) rad-r)) m))
		    (setq! rad-r (mod (* rad-r bigint-radix) m))
		)
	    )
	)
	(if (bigint-negative? b)
	    (setq! res (negate res))
	)
	res
    )
)
(doc 'bigint-rem-int "The remainder after dividing a bigint by an integer (the result is an integer).")

(defun bigint-rem ("vector" b "vector" m)
    (bigint-subtract b (bigint-multiply (bigint-divide b m) m))
)
(doc 'bigint-rem "The remainder after dividing one bigint by another.")

(defun bigint-mod-int ("vector" b "integer" m)
    (let*
	(res (bigint-rem-int b m))
	(if (negative? res) (+ res m) res)
    )
)
(doc 'bigint-mod-int "A bigint modulo an ingeter (the result is an integer).")

(defun bigint-mod ("vector" b "vector" m)
    (if (bigint-negative? b)
	(bigint-add (bigint-rem b m) m)
	(bigint-rem b m)
    )
)
(doc 'bigint-mod "A bigint modulo another one.")

(defun bigint-compare ("vector" b1 "vector" b2)
    (cond
	((> (bigint-signum b1) (bigint-signum b2)) 1)
	((< (bigint-signum b1) (bigint-signum b2)) -1)
	((> (vector-length b1) (vector-length b2)) (if (bigint-negative? b1) -1 1))
	((< (vector-length b1) (vector-length b2)) (if (bigint-negative? b1) 1 -1))
	(t
	    ; Same number of components. Compare starting from the high end
	    ; and working down.
	    (letrec
		(compare-components
		    (lambda (i)
			(cond
			    ((< i 0) 0)
			    ((> (vector-get b1 i) (vector-get b2 i)) 1)
			    ((< (vector-get b1 i) (vector-get b2 i)) -1)
			    (t (compare-components (- i 1)))
			)
		    )
		)
		(compare-components (- (vector-length b1) 1))
	    )
	)
    )
)
(doc 'bigint-compare "Compares two bigints, result is -1, 0, 1 for less-than, equal, greater-than.")

(defun bigint-= ("vector" b1 "vector" b2)
    (= 0 (bigint-compare b1 b2))
)
(doc 'bigint-= "Are the two bigints equal?")

(defun bigint-< ("vector" b1 "vector" b2)
    (= -1 (bigint-compare b1 b2))
)
(doc 'bigint-< "Is the first bigint less than the second?")

(defun bigint-> ("vector" b1 "vector" b2)
    (= 1 (bigint-compare b1 b2))
)
(doc 'bigint-> "Is the first bigint greater than the second?")

(defun bigint-!= ("vector" b1 "vector" b2)
    (not (bigint-= b1 b2))
)
(doc 'bigint-!= "Are the two bigints not equal?")

(defun bigint-<= ("vector" b1 "vector" b2)
    (not (bigint-> b1 b2))
)
(doc 'bigint-<= "Is the first bigint less than or equal to the second?")

(defun bigint->= ("vector" b1 "vector" b2)
    (not (bigint-< b1 b2))
)
(doc 'bigint->= "Is the first bigint greater than or equal to the second?")

(defun bigint-odd? ("vector" b)
    (odd? (vector-get b 0))
)
(doc 'bigint-odd? "Is the bigint odd?")

(defun bigint-even? ("vector" b)
    (even? (vector-get b 0))
)
(doc 'bigint-even? "Is the bigint even?")

(defun bigint-half ("vector" b)
    (let*
	(l (vector-length b))
	(res (vector l 0))
	(hr (ash bigint-radix -1))	; (depends on radix being even)
	(for-seq 0 l
	    (lambda (i)
		(progn
		    (if (and (odd? (vector-get b i)) (> i 0))
			(vector-set! res (- i 1) (+ (vector-get res (- i 1)) hr))
		    )
		    (vector-set! res i (ash (vector-get b i) -1))
		)
	    )
	)
	(bigint-norm res)
    )
)
(doc 'bigint-half "Halves a bigint")

(defun bigint-double("vector" b)
    (let*
	(l (vector-length b))
	(res (vector l 0))
	(for-seq 0 l
	    (lambda (i)
		(vector-set! res i (ash (vector-get b i) 1))
	    )
	)
	(bigint-norm res)
    )
)
(doc 'bigint-double "Doubles a bigint")

(defun string-tobigint ("string" s "integer?" base)
    (let*
	(digits "0123456789abcdef")
	(if (not base) (setq! base 10))
	(if (or (> base 16) (< base 2)) (err "invalid base"))
	(if (eql? (string-chrat s 0) '-')
	    (bigint-negate (string-tobigint (string-substr s 1) base))
	    (let*
		(res (bigint 0))
		(for-seq 0 (string-length s)
		    (lambda (i)
			(let*
			    (c (string-chrat s i))
			    (d (string-find digits c))
			    (if (or (not d) (> d base))
				(err (string-concat "invalid digit - " c))
				(setq! res (bigint-add-int (bigint-multiply-int res base) d))
			    )
			)
		    )
		)
		res
	    )
	)
    )
)
(doc 'string-tobigint "Converts a string to a bigint, with optional base (default 10).")

(defun bigint-tostring ("vector" b "integer?" base)
    (let*
	(digits ['0' '1' '2' '3' '4' '5' '6' '7' '8' '9' 'a' 'b' 'c' 'd' 'e' 'f'])
	(if (not base) (setq! base 10))
	(if (or (> base 16) (< base 2)) (err "invalid base"))
	(if (bigint-negative? b)
	    (string-concat '-' (bigint-tostring (bigint-abs b) base))
	    (letrec
		(bigint-tostring-pos
		    (lambda (c)
			(cons
			    (vector-get digits (bigint-mod-int c base))
			    (if (or (> (vector-length c) 1) (>= (vector-get c 0) base))
				(bigint-tostring-pos (bigint-divide-int c base))
				()
			    )
			)
		    )
		)
		(apply string-concat (reverse (bigint-tostring-pos b)))
	    )
	)
    )
)
(doc 'bigint-tostring "Converts a bigint to a string, with optional base (default 10).")

; Add an sprintf formatter for bigs as %b.
(sprintf-add 'b' vector? bigint-tostring)

(defun bigint-write-base ("vector" b "integer" base "stream?" s)
    (if (not s)
	(bigint-write-base b base stdout)
	(write-string (bigint-tostring b base) s)
    )
)
(doc 'bigint-write-base "Writes a bigint in a specified base to a stream (default stdout).")

(defun bigint-write-base-line ("vector" b "integer" base "stream?" s)
    (if (not s)
	(bigint-write-base-line b base stdout)
	(progn
	    (bigint-write-base b base s)
	    (fprintf s "\n")
	)
    )
)
(doc 'bigint-write-base-line "Writes a bigint in a specified base to a stream (default stdout), followed by a newline.")

(defun bigint-write ("vector" b "stream?" s)
    (if (not s)
	(bigint-write b stdout)
	(bigint-write-base b 10 s)
    )
)
(doc 'bigint-write "Writes a bigint to a stream (default stdout).")

(defun bigint-write-line ("vector" b "stream?" s)
    (if (not s)
	(bigint-write-line b stdout)
	(progn
	    (bigint-write b s)
	    (fprintf s "\n")
	)
    )
)
(doc 'bigint-write-line "Writes a bigint to a stream (default stdout), followed by a newline.")

(defun bigint-power ("vector" b "vector" exp)
    (cond
	((bigint-negative? exp) (err "bigint-power: negative exponent"))
	(t
	    (let*
		(bb (bigint-bits exp))
		(res bigint-1)
		(if (bigint-odd? exp)
		    (setq! res b)
		)
		(for-seq 1 bb
		    (lambda ()
			(progn
			    (setq! b (bigint-square b))
			    (setq! exp (bigint-half exp))
			    (if (bigint-odd? exp)
				(setq! res (bigint-multiply res b))
			    )
			)
		    )
		)
		res
	    )
	)
    )
)
(doc 'bigint-power "Raises a bigint to a specified power.")

(defun bigint-factorial ("vector" b)
    (if (bigint-<= b bigint-1)
	bigint-1
	(bigint-multiply b (bigint-factorial (bigint-subtract b bigint-1)))
    )
)
(doc 'bigint-factorial "Computes the factorial of a bigint.")

(defun bigint-sqrt ("vector" b)
    (cond
	((bigint-negative? b) (err "bigint-sqrt: imaginary result"))
	((bigint-= b bigint-0) bigint-0)
	((bigint-= b bigint-1) bigint-1)
	(t
	    (let*
		(est1 (bigint-half b))
		(est2 (bigint-divide b est1))
		(diff (bigint-subtract est1 est2))
		(progn
		    (while (bigint-> (bigint-abs diff) bigint-1)
			(setq! est1 (bigint-half (bigint-add est1 est2)))
			(setq! est2 (bigint-divide b est1))
			(setq! diff (bigint-subtract est1 est2))
		    )
		    (if (bigint-= diff bigint-1)
			est2
			est1
		    )
		)
	    )
	)
    )
)
(doc 'bigint-sqrt "Computes the largest integer less than the arg's square root.")

(defun bigint-gcd ("vector" b1 "vector" b2)
    (if (bigint-= b2 bigint-0)
	b1
	(gcd b2 (bigint-mod b1 b2))
    )
)
(doc 'bigint-gcd "Computes the greatest common divisor of two bigints.")

(defun bigint-lcm ("vector" b1 "vector" b2)
    (bigint-div (bigint-mul b1 b2) (bigint-gcd b1 b2))
)
(doc 'bigint-lcm "Computes the lowest common multiplier of two bigints.")

(defun bigint-random ("vector" b)
    (let*
	(l (truncate (/ (* (vector-length b) 5) 4)))
	(res (vector l 0))
	(for-seq 0 l
	    (lambda (i) (vector-set! res i (random)))
	)
	(bigint-mod (bigint-norm res) b)
    )
)
(doc 'bigint-random "Returns a random bigint in [0..arg).")

(defun bigint-bit ("vector" b "integer" n)
    (let*
	(i (truncate (/ n bigint-radix-bits)))
	(if (>= i (vector-length b))
	    0
	    (bit (vector-get b i) (- n (* i bigint-radix-bits)))
	)
    )
)
(doc 'bigint-bit "Returns the nth bit of a bigint. The least significant bit is index 0.")

(defun bigint-bits ("vector" b)
    (let*
	(lm1 (- (vector-length b) 1))
	(+ (* bigint-radix-bits lm1) (bits (vector-get b lm1)))
    )
)
(doc 'bigint-bits "How many bits are in a bigint.")

(defun bigint-digits ("vector" b)
    (truncate (/ (+ (* (bigint-bits b) 1000001) 3321928) 3321929))
)
(doc 'bigint-digits "How many decimal digits are in a bigint.")

(defun bigint-square ("vector" b)
    (let*
	(l (vector-length b))
	(res (vector (* l 2) 0))
	(for-seq 0 l
	    (lambda (i1)
		(progn
		    (for-seq 0 i1
			(lambda (i2)
			    (let*
				(ir (+ i1 i2))
				(vector-set! res ir (+ (vector-get res ir) (* 2 (* (vector-get b i1) (vector-get b i2)))))
			    )
			)
		    )
		    (vector-set! res (* i1 2) (+ (vector-get res (* i1 2)) (* (vector-get b i1) (vector-get b i1))))
		    (bigint-norm res)
		)
	    )
	)
	res
    )
)
(doc 'bigint-square "Returns the square of a bigint.")

(defun bigint-mod-multiply ("vector" b1 "vector" b2 "vector" m)
    (cond
	((or (bigint-negative? b1) (bigint->= b1 m)) (bigint-mod-multiply (bigint-mod b1 m) b2 m))
	((or (bigint-negative? b2) (bigint->= b2 m)) (bigint-mod-multiply b1 (bigint-mod b2 m) m))
	(t (bigint-mod (bigint-multiply b1 b2) m))
    )
)
(doc 'bigint-mod-multiply "Multiplies two bigints modulo a third.")

(defun bigint-mod-power ("vector" b "vector" exp "vector" m)
    (cond
	((bigint-negative? exp) (bigint-mod-inverse (bigint-mod-power b (bigint-abs exp) m) m))
	(t
	    (let*
		(res (if (bigint-odd? exp) (bigint-mod b m) bigint-1))
		(bts (bigint-bits exp))
		(for-seq 1 bts
		    (lambda (i)
			(progn
			    (setq! b (bigint-mod-square b m))
			    (setq! exp (bigint-half exp))
			    (if (bigint-odd? exp)
				(setq! res (bigint-mod-multiply res b m))
			    )
			)
		    )
		)
		res
	    )
	)
    )
)
(doc 'bigint-mod-power "Raises a bigint to a specified power modulo a third bigint.")

(defun bigint-mod-square ("vector" b "vector" m)
    (bigint-mod-multiply b b m)
)
(doc 'bigint-mod-square "Squares a bigint modulo another bigint.")

(defun bigint-egcd ("vector" x "vector" y)
    (cond
	((bigint-negative? x)
	    (let*
		(res (bigint-egcd (bigint-abs x) y))
		(list (first res) (bigint-negate (second res)) (third res))
	    )
	)
	((bigint-negative? y)
	    (let*
		(res (bigint-egcd x (bigint-abs y)))
		(list (first res) (second res) (bigint-negate (third res)))
	    )
	)
	((< (bigint-compare x y) 0)
	    (let*
		(res (bigint-egcd y x))
		(list (first res) (third res) (second res))
	    )
	)
	(t
	    (let*
		(a0 bigint-1) (b0 bigint-0) (c0 x)
		(a1 bigint-0) (b1 bigint-1) (c1 y)
		(q ())
		(tmp ())
		(while (bigint-!= c1 bigint-0)
		    (progn
			(setq! q (bigint-divide c0 c1))
			(setq! tmp a0)
			(setq! a0 a1)
			(setq! a1 (bigint-subtract tmp (bigint-multiply q a1)))
			(setq! tmp b0)
			(setq! b0 b1)
			(setq! b1 (bigint-subtract tmp (bigint-multiply q b1)))
			(setq! tmp c0)
			(setq! c0 c1)
			(setq! c1 (bigint-subtract tmp (bigint-multiply q c1)))
		    )
		)
		(list c0 a0 b0)
	    )
	)
    )
)
(doc 'bigint-egcd "Euclidean extended GCD algorithm. Returns a list of three items: the result, the x multiplier, and the y multiplier.")

(defun bigint-mod-inverse ("vector" b "vector" m)
    (let*
	(res (bigint-egcd m b))
	(g (first res))
	(xmul (second res))
	(ymul (third res))
	(if (bigint-!= g bigint-1) (err "bigint-mod-inverse: not relatively prime"))
	(bigint-mod ymul m)
    )
)
(doc 'bigint-mod-inverse "Computes the modular inverse of a bigint.")

(defun bigint-miller-rabin ("vector" b "vector" bm1 "vector" s "integer" r)
    (catch 'bmr
	(let*
	    (a (bigint-add-int (bigint-random bm1) 1))
	    (p (bigint-mod-power a s b))
	    (cond
		((bigint-= p bigint-1) t)
		((bigint-= p bm1) t)
		(t
		    (progn
			(for-seq 1 r
			    (lambda (i)
				(progn
				    (setq! p (bigint-mod-square p b))
				    (if (bigint-= p bm1) (throw 'bmr t))
				)
			    )
			)
			()
		    )
		)
	    )
	)
    )
)
(doc 'bigint-miller-rabin "The Miller-Rabin probabilistic primality test.")

(defun bigint-is-probable-prime? ("vector" b "integer" certainty)
    (let*
	; Table of primes up to 10,000.
	(low-primes [
		2     3     5     7    11    13    17    19    23
	       29    31    37    41    43    47    53    59    61
	       67    71    73    79    83    89    97   101   103
	      107   109   113   127   131   137   139   149   151
	      157   163   167   173   179   181   191   193   197
	      199   211   223   227   229   233   239   241   251
	      257   263   269   271   277   281   283   293   307
	      311   313   317   331   337   347   349   353   359
	      367   373   379   383   389   397   401   409   419
	      421   431   433   439   443   449   457   461   463
	      467   479   487   491   499   503   509   521   523
	      541   547   557   563   569   571   577   587   593
	      599   601   607   613   617   619   631   641   643
	      647   653   659   661   673   677   683   691   701
	      709   719   727   733   739   743   751   757   761
	      769   773   787   797   809   811   821   823   827
	      829   839   853   857   859   863   877   881   883
	      887   907   911   919   929   937   941   947   953
	      967   971   977   983   991   997  1009  1013  1019
	     1021  1031  1033  1039  1049  1051  1061  1063  1069
	     1087  1091  1093  1097  1103  1109  1117  1123  1129
	     1151  1153  1163  1171  1181  1187  1193  1201  1213
	     1217  1223  1229  1231  1237  1249  1259  1277  1279
	     1283  1289  1291  1297  1301  1303  1307  1319  1321
	     1327  1361  1367  1373  1381  1399  1409  1423  1427
	     1429  1433  1439  1447  1451  1453  1459  1471  1481
	     1483  1487  1489  1493  1499  1511  1523  1531  1543
	     1549  1553  1559  1567  1571  1579  1583  1597  1601
	     1607  1609  1613  1619  1621  1627  1637  1657  1663
	     1667  1669  1693  1697  1699  1709  1721  1723  1733
	     1741  1747  1753  1759  1777  1783  1787  1789  1801
	     1811  1823  1831  1847  1861  1867  1871  1873  1877
	     1879  1889  1901  1907  1913  1931  1933  1949  1951
	     1973  1979  1987  1993  1997  1999  2003  2011  2017
	     2027  2029  2039  2053  2063  2069  2081  2083  2087
	     2089  2099  2111  2113  2129  2131  2137  2141  2143
	     2153  2161  2179  2203  2207  2213  2221  2237  2239
	     2243  2251  2267  2269  2273  2281  2287  2293  2297
	     2309  2311  2333  2339  2341  2347  2351  2357  2371
	     2377  2381  2383  2389  2393  2399  2411  2417  2423
	     2437  2441  2447  2459  2467  2473  2477  2503  2521
	     2531  2539  2543  2549  2551  2557  2579  2591  2593
	     2609  2617  2621  2633  2647  2657  2659  2663  2671
	     2677  2683  2687  2689  2693  2699  2707  2711  2713
	     2719  2729  2731  2741  2749  2753  2767  2777  2789
	     2791  2797  2801  2803  2819  2833  2837  2843  2851
	     2857  2861  2879  2887  2897  2903  2909  2917  2927
	     2939  2953  2957  2963  2969  2971  2999  3001  3011
	     3019  3023  3037  3041  3049  3061  3067  3079  3083
	     3089  3109  3119  3121  3137  3163  3167  3169  3181
	     3187  3191  3203  3209  3217  3221  3229  3251  3253
	     3257  3259  3271  3299  3301  3307  3313  3319  3323
	     3329  3331  3343  3347  3359  3361  3371  3373  3389
	     3391  3407  3413  3433  3449  3457  3461  3463  3467
	     3469  3491  3499  3511  3517  3527  3529  3533  3539
	     3541  3547  3557  3559  3571  3581  3583  3593  3607
	     3613  3617  3623  3631  3637  3643  3659  3671  3673
	     3677  3691  3697  3701  3709  3719  3727  3733  3739
	     3761  3767  3769  3779  3793  3797  3803  3821  3823
	     3833  3847  3851  3853  3863  3877  3881  3889  3907
	     3911  3917  3919  3923  3929  3931  3943  3947  3967
	     3989  4001  4003  4007  4013  4019  4021  4027  4049
	     4051  4057  4073  4079  4091  4093  4099  4111  4127
	     4129  4133  4139  4153  4157  4159  4177  4201  4211
	     4217  4219  4229  4231  4241  4243  4253  4259  4261
	     4271  4273  4283  4289  4297  4327  4337  4339  4349
	     4357  4363  4373  4391  4397  4409  4421  4423  4441
	     4447  4451  4457  4463  4481  4483  4493  4507  4513
	     4517  4519  4523  4547  4549  4561  4567  4583  4591
	     4597  4603  4621  4637  4639  4643  4649  4651  4657
	     4663  4673  4679  4691  4703  4721  4723  4729  4733
	     4751  4759  4783  4787  4789  4793  4799  4801  4813
	     4817  4831  4861  4871  4877  4889  4903  4909  4919
	     4931  4933  4937  4943  4951  4957  4967  4969  4973
	     4987  4993  4999  5003  5009  5011  5021  5023  5039
	     5051  5059  5077  5081  5087  5099  5101  5107  5113
	     5119  5147  5153  5167  5171  5179  5189  5197  5209
	     5227  5231  5233  5237  5261  5273  5279  5281  5297
	     5303  5309  5323  5333  5347  5351  5381  5387  5393
	     5399  5407  5413  5417  5419  5431  5437  5441  5443
	     5449  5471  5477  5479  5483  5501  5503  5507  5519
	     5521  5527  5531  5557  5563  5569  5573  5581  5591
	     5623  5639  5641  5647  5651  5653  5657  5659  5669
	     5683  5689  5693  5701  5711  5717  5737  5741  5743
	     5749  5779  5783  5791  5801  5807  5813  5821  5827
	     5839  5843  5849  5851  5857  5861  5867  5869  5879
	     5881  5897  5903  5923  5927  5939  5953  5981  5987
	     6007  6011  6029  6037  6043  6047  6053  6067  6073
	     6079  6089  6091  6101  6113  6121  6131  6133  6143
	     6151  6163  6173  6197  6199  6203  6211  6217  6221
	     6229  6247  6257  6263  6269  6271  6277  6287  6299
	     6301  6311  6317  6323  6329  6337  6343  6353  6359
	     6361  6367  6373  6379  6389  6397  6421  6427  6449
	     6451  6469  6473  6481  6491  6521  6529  6547  6551
	     6553  6563  6569  6571  6577  6581  6599  6607  6619
	     6637  6653  6659  6661  6673  6679  6689  6691  6701
	     6703  6709  6719  6733  6737  6761  6763  6779  6781
	     6791  6793  6803  6823  6827  6829  6833  6841  6857
	     6863  6869  6871  6883  6899  6907  6911  6917  6947
	     6949  6959  6961  6967  6971  6977  6983  6991  6997
	     7001  7013  7019  7027  7039  7043  7057  7069  7079
	     7103  7109  7121  7127  7129  7151  7159  7177  7187
	     7193  7207  7211  7213  7219  7229  7237  7243  7247
	     7253  7283  7297  7307  7309  7321  7331  7333  7349
	     7351  7369  7393  7411  7417  7433  7451  7457  7459
	     7477  7481  7487  7489  7499  7507  7517  7523  7529
	     7537  7541  7547  7549  7559  7561  7573  7577  7583
	     7589  7591  7603  7607  7621  7639  7643  7649  7669
	     7673  7681  7687  7691  7699  7703  7717  7723  7727
	     7741  7753  7757  7759  7789  7793  7817  7823  7829
	     7841  7853  7867  7873  7877  7879  7883  7901  7907
	     7919  7927  7933  7937  7949  7951  7963  7993  8009
	     8011  8017  8039  8053  8059  8069  8081  8087  8089
	     8093  8101  8111  8117  8123  8147  8161  8167  8171
	     8179  8191  8209  8219  8221  8231  8233  8237  8243
	     8263  8269  8273  8287  8291  8293  8297  8311  8317
	     8329  8353  8363  8369  8377  8387  8389  8419  8423
	     8429  8431  8443  8447  8461  8467  8501  8513  8521
	     8527  8537  8539  8543  8563  8573  8581  8597  8599
	     8609  8623  8627  8629  8641  8647  8663  8669  8677
	     8681  8689  8693  8699  8707  8713  8719  8731  8737
	     8741  8747  8753  8761  8779  8783  8803  8807  8819
	     8821  8831  8837  8839  8849  8861  8863  8867  8887
	     8893  8923  8929  8933  8941  8951  8963  8969  8971
	     8999  9001  9007  9011  9013  9029  9041  9043  9049
	     9059  9067  9091  9103  9109  9127  9133  9137  9151
	     9157  9161  9173  9181  9187  9199  9203  9209  9221
	     9227  9239  9241  9257  9277  9281  9283  9293  9311
	     9319  9323  9337  9341  9343  9349  9371  9377  9391
	     9397  9403  9413  9419  9421  9431  9433  9437  9439
	     9461  9463  9467  9473  9479  9491  9497  9511  9521
	     9533  9539  9547  9551  9587  9601  9613  9619  9623
	     9629  9631  9643  9649  9661  9677  9679  9689  9697
	     9719  9721  9733  9739  9743  9749  9767  9769  9781
	     9787  9791  9803  9811  9817  9829  9833  9839  9851
	     9857  9859  9871  9883  9887  9901  9907  9923  9929
	     9931  9941  9949  9967
	    ]
	)
	(cond
	    ; Check if it's actually in the table of small primes.
	    ((and (= (vector-length b) 1) (vector-find low-primes (vector-get b 0))) t)
	    ; Next do trial division by the table of small primes. This
	    ; eliminates many candidates and runs quickly.
	    ((vector-any? (lambda (x) (= (bigint-mod-int b x) 0)) low-primes) ())
	    ; Now do the probabilistic tests.
	    (t
		(catch 'ipp
		    (let*
			(bm1 (bigint-subtract-int b 1))
			(s bm1)
			(r 0)
			(while (bigint-even? s)
			    (setq! s (bigint-half s))
			    (setq! r (+ r 1))
			)
			(for-seq 0 certainty
			    (lambda (i)
				(if (not (bigint-miller-rabin b bm1 s r))
				    (throw 'ipp ())
				)
			    )
			)
			t
		    )
		)
	    )
	)
    )
)
(doc 'bigint-is-probable-prime? "Probabilistic primality test.")

(defun bigint-generate-prime ("integer" bts "integer" certainty)
    (let*
	(mo4 (bigint-power bigint-2 (bigint (- bts 2))))
	(mo2 (bigint-double mo4))
	(p ())
	(until
	    ; Pick a random prime candidate. In order for it to
	    ; have the requested number of bits, it should be in:
	    ;   2^(bits-1) <= p < 2^bits
	    ; However, most likely we are being called to generate the two
	    ; parts of an RSA key, which will be multiplied together.
	    ; The product is supposed to be 2*bits long, but for some
	    ; primes in the above range it will be one or two bits shorter.
	    ; To prevent this, we generate primes only in the upper half of
	    ; the range:
	    ;   2^(bits-1) + 2^(bits-2) <= p < 2^bits
	    ; Another way of putting this is that the top two bits are on,
	    ; instead of just the top bit.  This is actually a slightly
	    ; narrower range than we really need, but there are still plenty
	    ; of primes up there.
	    (setq! p (bigint-add (bigint-add (bigint-random mo4) mo2) mo4))
	    ; Check it.
	    (bigint-is-probable-prime p certainty)
	)
	p
    )
)
(doc 'bigint-generate-prime "Generates a random prime with a specified number of bits to a specified degree of certainty.")

; Make some useful constants.

(define bigint-0 (bigint 0))
(doc 'bigint-0 "A bigint of zero.")

(define bigint-1 (bigint 1))
(doc 'bigint-1 "A bigint of one.")

(define bigint-2 (bigint 2))
(doc 'bigint-2 "A bigint of two.")

(define bigint-3 (bigint 3))
(doc 'bigint-3 "A bigint of three.")

(define bigint-m1 (bigint -1))
(doc 'bigint-m1 "A bigint of minus one.")
