From 73f4fa86a3304b34437c0a1b94ea0e14f6f62de0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 31 Oct 2014 13:19:49 -0500
Subject: [PATCH] Replace the racket/list shuffle function with the
 fisher-yates shuffling algorithm.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Thanks to Daniel Prager for the push to fix this and doing
most of the work.

The timing tests below seem to indicate that it takes a constant
amount of time per element (about 1/7th of a microsecond per element
on my laptop) and even for 10 element lists it runs faster than
the sort-based version that this code replaces.

Below is some code that I used to explore the shuffles. I used Mike
Bostock diagrams (http://bost.ocks.org/mike/shuffle/compare.html)
to double check that the FY algorithm was implemented properly.

 #lang racket/gui
(require pict)

;; some shuffling algorithms:

(define (st-shuffle l)
  (sort l < #:key (λ(_) (random)) #:cache-keys? #t))

(define (fy-shuffle l)
  (define a (make-vector (length l)))
  (for ([x (in-list l)] [i (in-naturals)])
    (define j (random (add1 i)))
    (unless (= j i) (vector-set! a i (vector-ref a j)))
    (vector-set! a j x))
  (vector->list a))

(define (naive-swap-random->random l)
  (define v (apply vector l))
  (define len (vector-length v))
  (for ([x (in-range len)])
    (define n (random len))
    (define m (random len))
    (define t (vector-ref v n))
    (vector-set! v n (vector-ref v m))
    (vector-set! v m t))
  (vector->list v))

;; replication of the ``Will it Shuffle?'' diagram

(define green '(0 100 0))
(define red '(165 42 42))

(define (shuffle-pict shuffle size)
  (define pict-size 300)
  (define sq-size (/ pict-size size))
  (define v (build-vector size (λ (i) (make-vector size 0))))
  (define ht (make-hash))
  (define l (build-list size values))
  (define shuffles 10000)
  (for ([x (in-range shuffles)])
    (for ([x (in-list (shuffle l))] [i (in-naturals)])
      (define r (vector-ref v x))
      (vector-set! r i (+ (vector-ref r i) 1))))
  (apply
   hc-append
   (for/list ([r (in-vector v)])
     (apply
      vc-append
      (for/list ([e (in-vector r)])
        (colorize (filled-rectangle sq-size sq-size #:draw-border? #f)
                  (triple->color
                   (sq-color shuffles size e))))))))

(define (sq-color shuffles size n)
  (define mid-point (/ shuffles size))
  (cond
    [(<= n mid-point)
     (interp-color red
                   (- 1 (map-between (/ mid-point 3) mid-point n)))]
    [else
     (interp-color green (map-between mid-point (* mid-point 3) n))]))

(define (map-between lower-bound upper-bound n)
  (cond
    [(<= lower-bound n upper-bound)
     (/ (- n lower-bound) (- upper-bound lower-bound))]
    [(<= n lower-bound) 0]
    [else 1]))

(define (interp-color color %)
  (define (i n) (- 255 (* (- 255 n) %)))
  (list (i (list-ref color 0))
        (i (list-ref color 1))
        (i (list-ref color 2))))

(define (triple->color triple)
  (define (get n) (inexact->exact (floor (list-ref triple n))))
  (make-object color% (get 0) (get 1) (get 2)))

(module+ test
  (require rackunit)
  (check-equal? (map-between 10 110 0) 0)
  (check-equal? (map-between 10 110 10) 0)
  (check-equal? (map-between 10 110 20) 1/10)
  (check-equal? (map-between 10 110 100) 9/10)
  (check-equal? (map-between 10 110 150) 1)
  (check-equal? (sq-color 1000 10 0) red)
  (check-equal? (sq-color 1000 10 100) (list 255 255 255))
  (check-equal? (sq-color 1000 10 1000) green))

(define (pictures)
  (values
   (shuffle-pict st-shuffle 60)
   (shuffle-pict fy-shuffle 60)
   (shuffle-pict naive-swap-random->random 60)))

;; timing tests

(define (time-it a-shuffler size iters)
  (printf "~a ~a ~a " (object-name a-shuffler) size iters)
  (flush-output)
  (define l (build-list size values))
  (collect-garbage) (collect-garbage) (collect-garbage)
  (time (for ([x (in-range iters)])
          (a-shuffler l))))

(define (timings)
  (time-it fy-shuffle 10 100000)
  (time-it fy-shuffle 100 10000)
  (time-it fy-shuffle 1000 1000)
  (time-it fy-shuffle 10000 100)

  (time-it st-shuffle 10 100000)
  (time-it st-shuffle 100 10000)
  (time-it st-shuffle 1000 1000)
  (time-it st-shuffle 10000 100))

(module+ main (timings))
---
 racket/collects/racket/list.rkt | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/racket/collects/racket/list.rkt b/racket/collects/racket/list.rkt
index 2cd9833fd1..6468cded09 100644
--- a/racket/collects/racket/list.rkt
+++ b/racket/collects/racket/list.rkt
@@ -445,8 +445,14 @@
       (reverse result)
       (loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
 
+;; Fisher-Yates Shuffle
 (define (shuffle l)
-  (sort l < #:key (λ(_) (random)) #:cache-keys? #t))
+  (define a (make-vector (length l)))
+  (for ([x (in-list l)] [i (in-naturals)])
+    (define j (random (add1 i)))
+    (unless (= j i) (vector-set! a i (vector-ref a j)))
+    (vector-set! a j x))
+  (vector->list a))
 
 ;; This implements an algorithm known as "Ord-Smith".  (It is described in a
 ;; paper called "Permutation Generation Methods" by Robert Sedgewlck, listed as