codepad

Language:

; selection

(define rand
  (let* ((a 3141592653) (c 2718281829)
         (m (expt 2 35)) (x 5772156649)
         (next (lambda ()
                 (let ((x-prime (modulo (+ (* a x) c) m)))
                   (set! x x-prime) x-prime)))
         (k 103)
         (v (list->vector (reverse
              (let loop ((i k) (vs (list x)))
                (if (= i 1) vs
                  (loop (- i 1) (cons (next) vs)))))))
         (y (next))
         (init (lambda (s)
                 (set! x s) (vector-set! v 0 x)
                 (do ((i 1 (+ i 1))) ((= i k))
                   (vector-set! v i (next))))))
    (lambda seed
      (cond ((null? seed)
              (let* ((j (quotient (* k y) m))
                     (q (vector-ref v j)))
                (set! y q)
                (vector-set! v j (next)) (/ y m)))
            ((eq? (car seed) 'get) (list a c m x y k v))
            ((eq? (car seed) 'set)
              (let ((state (cadr seed)))
                (set! a (list-ref state 0))
                (set! c (list-ref state 1))
                (set! m (list-ref state 2))
                (set! x (list-ref state 3))
                (set! y (list-ref state 4))
                (set! k (list-ref state 5))
                (set! v (list-ref state 6))))
            (else (init (modulo (numerator
                    (inexact->exact (car seed))) m))
                  (rand))))))

(define (randint . args)
  (cond ((null? (cdr args))
          (floor (* (rand) (car args))))
        ((< (car args) (cadr args))
          (+ (floor (* (rand) (- (cadr args) (car args)))) (car args)))
        (else (+ (ceiling (* (rand) (- (cadr args) (car args)))) (car args)))))

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(define (partition xs)
  (let ((x (car xs)))
    (let loop ((xs xs) (lt '()) (gt '()))
      (cond ((null? xs) (values x lt gt))
            ((< (car xs) x)
              (loop (cdr xs) (cons (car xs) lt) gt))
            (else (loop (cdr xs) lt (cons (car xs) gt)))))))

(define (select k xs)
  (if (<= (length xs) k)
      (error 'select "out of range")
      (let loop ((k k) (xs (shuffle xs)))
        (let-values (((x lt gt) (partition xs)))
          (cond ((< k (length lt)) (loop k lt))
                ((< (length lt) k) (loop (- k (length lt)) gt))
                (else x))))))

(display (select 2 '(1 2 3 4 5 6 7)))

Private [?]

Run code