[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Mar 17:
; factoring multiple rsa keys

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(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 (fortune xs)
  (let loop ((n 1) (x #f) (xs xs))
    (cond ((null? xs) x)
          ((< (rand) (/ n))
            (loop (+ n 1) (car xs) (cdr xs)))
          (else (loop (+ n 1) x (cdr xs))))))

; primes [lo] hi -- list of primes on range [lo,hi], default lo=0
(define (primes . args)
  (let* ((lo (if (null? (cdr args)) 0 (car args)))
         (hi (if (null? (cdr args)) (car args) (cadr args))))
    (when (not (and (integer? lo) (integer? hi) (<= 0 lo hi)))
      (error 'primes "must be integer with (<= 0 lo hi)"))
    (cond

      ((< (- hi lo) 10) ; sanity check
        (let loop ((p hi) (ps (list)))
          (if (< p lo) ps
            (if (prime? p)
                (loop (- p 1) (cons p ps))
                (loop (- p 1) ps)))))

      ((and (<= lo 2) (<= hi 1000000)) ; simple sieve
        (let* ((len (quotient (- hi 1) 2))
               (bits (make-vector len #t)))
          (let loop ((i 0) (p 3) (ps (list 2)))
            (cond ((< hi (* p p))
                    (let loop ((i i) (p p) (ps ps))
                      (cond ((= i len) (reverse ps))
                            ((vector-ref bits i)
                              (loop (+ i 1) (+ p 2) (cons p ps)))
                            (else (loop (+ i 1) (+ p 2) ps)))))
                  ((vector-ref bits i)
                    (let loop ((j (+ (* 2 i i) (* 6 i) 3)))
                      (when (< j len)
                        (vector-set! bits j #f) (loop (+ j p))))
                    (loop (+ i 1) (+ p 2) (cons p ps)))
                  (else (loop (+ i 1) (+ p 2) ps))))))

      ((< lo (sqrt hi)) ; enforce segmenting condition
        (let* ((r (inexact->exact (ceiling (sqrt hi)))))
          (append (primes lo r) (primes (+ r 1) hi))))

      (else ; segmented sieve
        (let* ((lo (if (even? lo) lo (- lo 1)))
               (hi (if (even? hi) hi (+ hi 1)))
               (r (inexact->exact (ceiling (sqrt hi))))
               (b (quotient r 2)) (bs (make-vector b #t))
               (ps (cdr (primes r)))
               (qs (map (lambda (p)
                          (modulo (* -1/2 (+ lo 1 p)) p)) ps))
               (zs (list)) (z (lambda (p) (set! zs (cons p zs)))))
          (do ((t lo (+ t b b))
               (qs qs (map (lambda (p q) (modulo (- q b) p))
                           ps qs)))
              ((<= hi t) (reverse zs))
            (when (< hi (+ t b b)) (set! b (quotient (- hi t) 2)))
            (do ((i 0 (+ i 1))) ((= i b)) (vector-set! bs i #t))
            (do ((ps ps (cdr ps)) (qs qs (cdr qs))) ((null? qs))
              (do ((j (car qs) (+ j (car ps)))) ((<= b j))
                (vector-set! bs j #f)))
            (do ((j 0 (+ j 1))) ((= j b))
              (if (vector-ref bs j) (z (+ t j j 1))))))))))

(define keys
  (let ((ps (primes 12345 12543)))
    (list-of (* (fortune ps) q)
      (q in (primes 56789 56987)))))

; quadratic method
(display
  (unique equal?
    (sort (lambda (a b) (< (car a) (car b)))
      (list-of (list k1 d (/ k1 d))
        (k1 in keys)
        (k2 in keys)
        (d is (gcd k1 k2))
        (< 1 d k1)))))
(newline)

; linear method
(display
  (unique equal?
    (sort (lambda (a b) (< (car a) (car b)))
      (let ((k-prod (apply * keys)))
        (list-of (list k d (/ k d))
          (k in keys)
          (x is (/ (modulo k-prod (* k k)) k))
          (integer? x)
          (d is (gcd k x))
          (< 1 d k))))))
(newline)


Output:
1
2
((704139907 12377 56891) (704610233 12377 56929) (705624589 12421 56809) (705754187 12391 56957) (705828533 12391 56963) (706508659 12437 56807) (706667953 12421 56893) (707264161 12421 56941) (707627989 12437 56897) (708299587 12437 56951) (709798541 12487 56843) (709826057 12491 56827) (710173151 12487 56873) (711000211 12491 56921) (711128321 12517 56813) (713256211 12517 56983))
((704139907 12377 56891) (704610233 12377 56929) (705624589 12421 56809) (705754187 12391 56957) (705828533 12391 56963) (706508659 12437 56807) (706667953 12421 56893) (707264161 12421 56941) (707627989 12437 56897) (708299587 12437 56951) (709798541 12487 56843) (709826057 12491 56827) (710173151 12487 56873) (711000211 12491 56921) (711128321 12517 56813) (713256211 12517 56983))


Create a new paste based on this one


Comments: