MosML Shuffle

gistfile1.sml

load "Random";

signature SHUFFLE =
sig
    val shuffle : 'a list -> 'a list;
end;

structure Shuffle :> SHUFFLE =
struct

(* An implementation of shuffling.

Adapted from http://okmij.org/ftp/Haskell/perfect-shuffle.txt *)

datatype 'a Tree = Leaf of 'a | Node of int * 'a Tree * 'a Tree;

infixr $;
fun f $ x = f x;
fun id x = x;

fun join (l as Leaf _) (r as Leaf _) = Node (2, l, r)
  | join (l as Node (ct, _, _)) (r as Leaf _) = Node (ct + 1, l, r)
  | join (l as Leaf _) (r as Node (ct, _, _)) = Node (ct + 1, l, r)
  | join (l as Node (ctl, _, _)) (r as Node (ctr, _, _)) =
    Node (ctl + ctr, l, r);

fun inner [] = []
  | inner (x as [_]) = x
  | inner (e1 :: e2 :: rest) = (join e1 e2) :: inner rest;

fun growLevel [node] = node
  | growLevel l = growLevel $ inner l;

fun buildTree xs = growLevel (map Leaf xs);

fun extractTree 0 (Node (_, (Leaf e), r)) k = e :: k r
  | extractTree 1 (Node (2, l as Leaf _, Leaf r)) k = r :: k l
  | extractTree n (Node (c, l as Leaf _, r)) k =
    extractTree (n-1) r (fn new_r => k $ Node (c - 1, l, new_r))
  | extractTree n (Node (c, l as (Node (cl, _, _)), r)) k =
    (case (n + 1 = c, r) of
        (true, Leaf e) => e :: k l
     | _ => if n < cl then
                extractTree n l (fn newL => k $ Node (c - 1, newL, r))
            else
                extractTree (n - cl) r (fn newR => k $ Node (c - 1, l, newR)))
  | extractTree _ _ _ = raise Fail "Impossible";

fun shuffle1' (Leaf e) [] = [e]
  | shuffle1' tree (ri :: rs) =
    extractTree ri tree (fn tree => shuffle1' tree rs)
  | shuffle1' _ _ = raise Fail "Impossible";

fun shuffle1 elements rseq = shuffle1' (buildTree elements) rseq;

fun range n = List.tabulate(n, id);

fun shuffle [] = []
  | shuffle xs =
    let val len = length xs;
        val gen = Random.newgen();
        val rseq =
            List.tabulate(len - 1, fn i => Random.range(0, len - i) gen);
    in
        shuffle1 xs rseq
    end
end;