[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Oct 18:
; shuffle

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(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 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! v)
  (do ((n (vector-length v) (- n 1))) ((zero? n) 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))))

(display (shuffle! (list->vector (range 20)))) (newline)

(define (shuffle xs)
  (if (or (null? xs) (null? (cdr xs))) xs
      (let split ((xs xs) (odd '()) (even '()))
        (if (pair? xs)
            (split (cdr xs) (cons (car xs) even) odd)
            (let merge ((odd (shuffle odd)) (even (shuffle even)))
              (cond ((null? odd) even)
                    ((null? even) odd)
                    ((zero? (randint 2)) (cons (car odd) (merge (cdr odd) even)))
                    (else (cons (car even) (merge odd (cdr even))))))))))

(display (shuffle (range 20))) (newline)

(define (shuffle xs)
  (let shuffle ((xs xs) (acc '()))
    (if (null? xs) acc
        (if (null? (cdr xs)) (cons (car xs) acc)
            (let split ((xs xs) (x1 '()) (x2 '()))
              (if (null? xs)
                  (if (null? x1)
                      (split x2 '() '())
                      (shuffle x1 (shuffle x2 acc)))
                  (if (zero? (randint 2))
                      (split (cdr xs) (cons (car xs) x1) x2)
                      (split (cdr xs) x1 (cons (car xs) x2)))))))))

(display (shuffle (range 20))) (newline)

(define (shuffle xs)
  (map cdr
    (sort (lambda (x y) (< (car x) (car y)))
      (map (lambda (x) (cons (rand) x)) xs))))

(display (shuffle (range 20))) (newline)

(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))))

(display (shuffle (range 20))) (newline)


Output:
1
2
3
4
5
#(5 19 10 0 9 3 4 7 16 11 8 12 1 6 13 15 2 18 14 17)
(8 11 7 19 10 12 15 5 3 13 16 1 0 17 4 14 9 18 2 6)
(17 2 18 19 1 6 7 10 16 13 4 0 15 3 8 5 12 14 9 11)
(8 7 19 6 11 12 17 3 18 14 5 15 13 9 4 0 1 10 16 2)
(12 17 10 4 18 14 16 6 19 3 7 1 0 15 8 11 2 9 5 13)


Create a new paste based on this one


Comments: