Pastebin launched a little side project called VERYVIRAL.com, check it out ;-) Want more features on Pastebin? Sign Up, it's FREE!
Guest

Untitled

By: a guest on Jul 29th, 2010  |  syntax: Haskell  |  size: 1.51 KB  |  views: 124  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1. Source: http://okmij.org/ftp/Haskell/perfect-shuffle.txt.
  2.  
  3. import System.Random
  4.  
  5. data Tree a = Leaf a | Node !Int (Tree a) (Tree a) deriving Show
  6.  
  7. build_tree = grow_level . (map Leaf)
  8.     where
  9.     grow_level [node] = node
  10.     grow_level l = grow_level $ inner l
  11.              
  12.     inner [] = []
  13.     inner x@[_] = x
  14.     inner (e1:e2:rest) = (join e1 e2) : inner rest
  15.              
  16.     join l@(Leaf _)       r@(Leaf _)       = Node 2 l r
  17.     join l@(Node ct _ _)  r@(Leaf _)       = Node (ct+1) l r
  18.     join l@(Leaf _)       r@(Node ct _ _)  = Node (ct+1) l r
  19.     join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl+ctr) l r
  20.  
  21. shuffle1 :: [a] -> [Int] -> [a]
  22. shuffle1 elements rseq = shuffle1' (build_tree elements) rseq
  23.     where
  24.     shuffle1' (Leaf e) [] = [e]
  25.     shuffle1' tree (ri:r_others) = extract_tree ri tree
  26.                                     (\tree -> shuffle1' tree r_others)
  27.     extract_tree 0 (Node _ (Leaf e) r) k = e:k r
  28.     extract_tree 1 (Node 2 l@Leaf{} (Leaf r)) k = r:k l
  29.     extract_tree n (Node c l@Leaf{} r) k =
  30.         extract_tree (n-1) r (\new_r -> k $ Node (c-1) l new_r)
  31.     extract_tree n (Node n1 l (Leaf e)) k | n+1 == n1 = e:k l
  32.                                        
  33.     extract_tree n (Node c l@(Node cl _ _) r) k
  34.         | n < cl = extract_tree n l (\new_l -> k $ Node (c-1) new_l r)
  35.         | otherwise = extract_tree (n-cl) r (\new_r -> k $ Node (c-1) l new_r)
  36.  
  37. make_rs :: RandomGen g => Int -> g -> ([Int],g)
  38. make_rs n g = loop [] n g
  39.   where
  40.   loop acc 0 g = (reverse acc,g)
  41.   loop acc n g = let (r,g') = randomR (0,n) g
  42.                  in loop (r:acc) (pred n) g'