From b097acaa89fbfb8e80e01b31704d3fe20aea3afd Mon Sep 17 00:00:00 2001
From: Salvador Fandino <sfandino@yahoo.com>
Date: Wed, 29 Apr 2015 17:26:14 +0200
Subject: [PATCH] Use a more efficient algorithm for list shuffling

Previously, the Yates-Fisher shuffling algorithm was used for all the
sequences, but unfortunatelly when applied to lists this algorithm is
O(N*N).

This patch implements a list shuffling algorithm that is O(N*log(N))
whitout using any extra heap memory.

It works by dividing the list to shuffle in two, randomly
redistributing the list elements between the two parts in-place and
recursing.

It is quite similar to quicksort with a random comparator but ensuring
than the list is always divided in two parts of (almost) equal size,
and so avoiding the O(N*N) worst case of quicksort.
---
 sequences.lisp | 35 +++++++++++++++++++++++++++++------
 1 file changed, 29 insertions(+), 6 deletions(-)

diff --git a/sequences.lisp b/sequences.lisp
index 94c16b9..cb15df8 100644
--- a/sequences.lisp
+++ b/sequences.lisp
@@ -79,6 +79,30 @@ share structure with it."
           (rotate-head-to-tail sequence (- n))
           sequence)))
 
+(defun shuffle-sublist (list n)
+  (declare (type fixnum n))
+  (if (< n 16)
+      ;; for small lists use Fisher-Yates - O(N*N)
+      (do ((list list (cdr list)))
+          ((< n 2))
+        (rotatef (car list) (car (nthcdr (random n) list)))
+        (decf n))
+      ;; else, divide and conquer - O(N*log(N))
+      (let* ((half (floor n 2))
+             (middle (nthcdr half list)))
+        (do ((a list)
+             (b middle)
+             (remaining n (1- remaining))
+             (remaining-a half))
+            ((= remaining-a 0))
+          (if (< (random remaining) remaining-a)
+              (progn (decf remaining-a)
+                     (setf a (cdr a)))
+              (progn (rotatef (car a) (car b))
+                     (setf b (cdr b)))))
+        (shuffle-sublist middle (- n half))
+        (shuffle-sublist list half))))
+
 (defun shuffle (sequence &key (start 0) end)
   "Returns a random permutation of SEQUENCE bounded by START and END.
 Original sequece may be destructively modified, and share storage with
@@ -88,12 +112,11 @@ sequence."
            (type (or fixnum null) end))
   (etypecase sequence
     (list
-     (let* ((end (or end (proper-list-length sequence)))
-            (n (- end start)))
-       (do ((tail (nthcdr start sequence) (cdr tail)))
-           ((zerop n))
-         (rotatef (car tail) (car (nthcdr (random n) tail)))
-         (decf n))))
+     (let* ((list (nthcdr start sequence))
+            (end (if end
+                     (- end start)
+                     (proper-list-length list))))
+       (shuffle-sublist list end)))
     (vector
      (let ((end (or end (length sequence))))
        (loop for i from start below end
-- 
2.1.4