; rabin's cryptosystem
(define (split n xs)
(let loop ((n n) (xs xs) (zs '()))
(if (or (zero? n) (null? xs))
(values (reverse zs) xs)
(loop (- n 1) (cdr xs) (cons (car xs) zs)))))
(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
(define (mod-diff x y) (modulo (- x y) two31)) ; generic version
; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
(define (flip-cycle)
(do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
(vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
(do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
(vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
(set! fptr 54) (vector-ref a 55))
(define (init-rand seed)
(let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
(vector-set! a 55 prev)
(do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
(vector-set! a i next) (set! next (mod-diff prev next))
(set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
(set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
(flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
(define (next-rand)
(if (negative? (vector-ref a fptr)) (flip-cycle)
(let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
(define (unif-rand m)
(let ((t (- two31 (modulo two31 m))))
(let loop ((r (next-rand)))
(if (<= t r) (loop (next-rand)) (modulo r m)))))
(init-rand 19380110) ; happy birthday donald e knuth
(set! rand (lambda seed
(cond ((null? seed) (/ (next-rand) two31))
((eq? (car seed) 'get) (cons fptr (vector->list a)))
((eq? (car seed) 'set) (set! fptr (caadr seed))
(set! a (list->vector (cdadr seed))))
(else (/ (init-rand (modulo (numerator
(inexact->exact (car seed))) two31)) two31)))))
(set! randint (lambda args
(cond ((null? (cdr args))
(if (< (car args) two31) (unif-rand (car args))
(floor (* (next-rand) (car args)))))
((< (car args) (cadr args))
(let ((span (- (cadr args) (car args))))
(+ (car args)
(if (< span two31) (unif-rand span)
(floor (* (next-rand) span))))))
(else (let ((span (- (car args) (cadr args))))
(- (car args)
(if (< span two31) (unif-rand span)
(floor (* (next-rand) span))))))))))
(define (expm b e m)
(define (m* x y) (modulo (* x y) m))
(cond ((zero? e) 1)
((even? e) (expm (m* b b) (/ e 2) m))
(else (m* b (expm (m* b b) (/ (- e 1) 2) m)))))
(define (euclid x y)
(let loop ((a 1) (b 0) (g x) (u 0) (v 1) (w y))
(if (zero? w) (values a b g)
(let ((q (quotient g w)))
(loop u v w (- a (* q u)) (- b (* q v)) (- g (* q w)))))))
(define (prime? n)
(define (expm b e m)
(define (m* x y) (modulo (* x y) m))
(cond ((zero? e) 1)
((even? e) (expm (m* b b) (/ e 2) m))
(else (m* b (expm (m* b b) (/ (- e 1) 2) m)))))
(define (digits n . args)
(let ((b (if (null? args) 10 (car args))))
(let loop ((n n) (d '()))
(if (zero? n) d
(loop (quotient n b)
(cons (modulo n b) d))))))
(define (isqrt n)
(let loop ((x n) (y (quotient (+ n 1) 2)))
(if (<= 0 (- y x) 1) x
(loop y (quotient (+ y (quotient n y)) 2)))))
(define (square? n)
(let ((n2 (isqrt n)))
(= n (* n2 n2))))
(define (jacobi a n)
(if (not (and (integer? a) (integer? n) (positive? n) (odd? n)))
(error 'jacobi "modulus must be positive odd integer")
(let jacobi ((a a) (n n))
(cond ((= a 0) 0)
((= a 1) 1)
((= a 2) (case (modulo n 8) ((1 7) 1) ((3 5) -1)))
((even? a) (* (jacobi 2 n) (jacobi (quotient a 2) n)))
((< n a) (jacobi (modulo a n) n))
((and (= (modulo a 4) 3) (= (modulo n 4) 3))
(- (jacobi n a)))
(else (jacobi n a))))))
(define (inverse x n)
(let loop ((x (modulo x n)) (a 1))
(cond ((zero? x) (error 'inverse "division by zero"))
((= x 1) a)
(else (let ((q (- (quotient n x))))
(loop (+ n (* q x)) (modulo (* q a) n)))))))
(define (miller? n a)
(let loop ((r 0) (s (- n 1)))
(if (even? s) (loop (+ r 1) (/ s 2))
(if (= (expm a s n) 1) #t
(let loop ((r r) (s s))
(cond ((zero? r) #f)
((= (expm a s n) (- n 1)) #t)
(else (loop (- r 1) (* s 2)))))))))
(define (chain m f g x0 x1)
(let loop ((ms (digits m 2)) (u x0) (v x1))
(cond ((null? ms) (values u v))
((zero? (car ms)) (loop (cdr ms) (f u) (g u v)))
(else (loop (cdr ms) (g u v) (f v))))))
(define (lucas? n)
(let loop ((a 11) (b 7))
(let ((d (- (* a a) (* 4 b))))
(cond ((square? d) (loop (+ a 2) (+ b 1)))
((not (= (gcd n (* 2 a b d)) 1))
(loop (+ a 2) (+ b 2)))
(else (let* ((x1 (modulo (- (* a a (inverse b n)) 2) n))
(m (quotient (- n (jacobi d n)) 2))
(f (lambda (u) (modulo (- (* u u) 2) n)))
(g (lambda (u v) (modulo (- (* u v) x1) n))))
(let-values (((xm xm1) (chain m f g 2 x1)))
(zero? (modulo (- (* x1 xm) (* 2 xm1)) n)))))))))
(cond ((or (not (integer? n)) (< n 2))
(error 'prime? "must be integer greater than one"))
((even? n) (= n 2)) ((zero? (modulo n 3)) (= n 3))
(else (and (miller? n 2) (miller? n 3) (lucas? n)))))
(define (splits n xs)
(let loop ((xs xs) (zs (list)))
(if (null? xs) (reverse zs)
(call-with-values
(lambda () (split n xs))
(lambda (head tail)
(loop tail (cons head zs)))))))
(define (keygen k)
(define (gen k)
(let loop ((v (randint (expt 2 (- k 1)) (expt 2 k))))
(if (and (prime? v) (= (modulo v 4) 3)) v
(loop (+ v 1)))))
(let* ((k2 (quotient k 2)) (p (gen k2)) (q (gen k2)) (n (* p q)))
(call-with-values
(lambda () (euclid p q))
(lambda (a b g) (values n p q a b)))))
(define (encrypt m n)
(let ((m (+ (* m 256) 255)))
(expm m 2 n)))
(define (decrypt c n p q a b)
(let* ((r (expm c (/ (+ p 1) 4) p))
(s (expm c (/ (+ q 1) 4) q))
(aps (* a p s)) (bqr (* b q r))
(x (modulo (+ aps bqr) n))
(y (modulo (- aps bqr) n))
(m1 x) (m2 (modulo (- x) n))
(m3 y) (m4 (modulo (- y) n)))
(cond ((= (remainder m1 256) 255) (quotient m1 256))
((= (remainder m2 256) 255) (quotient m2 256))
((= (remainder m3 256) 255) (quotient m3 256))
((= (remainder m4 256) 255) (quotient m4 256))
(else (error 'decrypt "oops")))))
(define (prepare str n)
(let ((len (- n (modulo (string-length str) n))))
(string->list
(string-append str
(make-string len (integer->char len))))))
(define (unprepare xs)
(let loop ((xs (reverse xs)))
(if (char=? (car xs) (cadr xs))
(loop (cdr xs))
(reverse (cdr xs)))))
(define (chars->num cs)
(let loop ((cs cs) (n 0))
(if (null? cs) n
(loop (cdr cs)
(+ (* n 256) (char->integer (car cs)))))))
(define (num->chars n)
(let loop ((n n) (cs (list)))
(if (zero? n) cs
(loop (quotient n 256)
(cons (integer->char (remainder n 256)) cs)))))
(define (encipher plaintext key blocksize)
(list->string
(apply append
(map num->chars
(map (lambda (m) (encrypt m key))
(map chars->num
(splits blocksize
(prepare plaintext blocksize))))))))
(define (decipher ciphertext n p q a b blocksize)
(list->string
(unprepare
(apply append
(map num->chars
(map (lambda (c) (decrypt c n p q a b))
(map chars->num
(splits (+ blocksize 1)
(string->list ciphertext)))))))))
(display
(decipher
(encipher "Programming Praxis" 2090723993 3)
2090723993 61027 34259 -14246 25377 3))