[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/wyHgxfpg    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Nov 21:
; 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)
        (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)))
      (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-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)
    (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)
      (apply append
        (map num->chars
          (map (lambda (c) (decrypt c n p q a b))
            (map chars->num
              (splits (+ blocksize 1)
                (string->list ciphertext)))))))))

    (encipher "Programming Praxis" 2090723993 3)
    2090723993 61027 34259 -14246 25377 3))

Programming Praxis

Create a new paste based on this one