diff options
author | Ben Sima <ben@bsima.me> | 2019-10-27 09:48:52 -0700 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2019-10-27 12:14:40 -0700 |
commit | c790672cc244ac4caba1bda3572829a6c6862891 (patch) | |
tree | 2706bb8044f7b14840c5f90f215b79b433e81045 /lore/System | |
parent | 44df4ba39f65c3afd84bee6b03f47d9b061e9038 (diff) |
move everything to namespace directories
Diffstat (limited to 'lore/System')
-rw-r--r-- | lore/System/Random/Shuffle.hs | 122 |
1 files changed, 0 insertions, 122 deletions
diff --git a/lore/System/Random/Shuffle.hs b/lore/System/Random/Shuffle.hs deleted file mode 100644 index 02cd3e0..0000000 --- a/lore/System/Random/Shuffle.hs +++ /dev/null @@ -1,122 +0,0 @@ -{- | -Module : System.Random.Shuffle -Copyright : (c) 2009 Oleg Kiselyov, Manlio Perillo -License : BSD3 (see LICENSE file) - -<http://okmij.org/ftp/Haskell/perfect-shuffle.txt> - - -Example: - - import System.Random (newStdGen) - import System.Random.Shuffle (shuffle') - - main = do - rng <- newStdGen - let xs = [1,2,3,4,5] - print $ shuffle' xs (length xs) rng --} -{-# OPTIONS_GHC -funbox-strict-fields #-} - -module System.Random.Shuffle - ( shuffle - , shuffle' - , shuffleM - ) -where - -import Data.Function ( fix ) -import System.Random ( RandomGen - , randomR - ) -import Control.Monad ( liftM - , liftM2 - ) -import Control.Monad.Random ( MonadRandom - , getRandomR - ) - - --- | A complete binary tree, of leaves and internal nodes. --- Internal node: Node card l r --- where card is the number of leaves under the node. --- Invariant: card >=2. All internal tree nodes are always full. -data Tree a = Leaf !a - | Node !Int !(Tree a) !(Tree a) - deriving Show - - --- | Convert a sequence (e1...en) to a complete binary tree -buildTree :: [a] -> Tree a -buildTree = (fix growLevel) . (map Leaf) - where - growLevel _ [node] = node - growLevel self l = self $ inner l - - inner [] = [] - inner [e ] = [e] - inner (e1 : e2 : es) = e1 `seq` e2 `seq` (join e1 e2) : inner es - - join l@(Leaf _ ) r@(Leaf _ ) = Node 2 l r - join l@(Node ct _ _ ) r@(Leaf _ ) = Node (ct + 1) l r - join l@(Leaf _ ) r@(Node ct _ _) = Node (ct + 1) l r - join l@(Node ctl _ _) r@(Node ctr _ _) = Node (ctl + ctr) l r - - --- |Given a sequence (e1,...en) to shuffle, and a sequence --- (r1,...r[n-1]) of numbers such that r[i] is an independent sample --- from a uniform random distribution [0..n-i], compute the --- corresponding permutation of the input sequence. -shuffle :: [a] -> [Int] -> [a] -shuffle elements = shuffleTree (buildTree elements) - where - shuffleTree (Leaf e) [] = [e] - shuffleTree tree (r : rs) = - let (b, rest) = extractTree r tree in b : (shuffleTree rest rs) - shuffleTree _ _ = error "[shuffle] called with lists of different lengths" - - -- Extracts the n-th element from the tree and returns - -- that element, paired with a tree with the element - -- deleted. - -- The function maintains the invariant of the completeness - -- of the tree: all internal nodes are always full. - extractTree 0 (Node _ (Leaf e) r ) = (e, r) - extractTree 1 (Node 2 (Leaf l) (Leaf r)) = (r, Leaf l) - extractTree n (Node c (Leaf l) r) = - let (e, r') = extractTree (n - 1) r in (e, Node (c - 1) (Leaf l) r') - - extractTree n (Node n' l (Leaf e)) | n + 1 == n' = (e, l) - - extractTree n (Node c l@(Node cl _ _) r) - | n < cl - = let (e, l') = extractTree n l in (e, Node (c - 1) l' r) - | otherwise - = let (e, r') = extractTree (n - cl) r in (e, Node (c - 1) l r') - extractTree _ _ = error "[extractTree] impossible" - --- |Given a sequence (e1,...en) to shuffle, its length, and a random --- generator, compute the corresponding permutation of the input --- sequence. -shuffle' :: RandomGen gen => [a] -> Int -> gen -> [a] -shuffle' elements len = shuffle elements . rseq len - where - -- The sequence (r1,...r[n-1]) of numbers such that r[i] is an - -- independent sample from a uniform random distribution - -- [0..n-i] - rseq :: RandomGen gen => Int -> gen -> [Int] - rseq n = fst . unzip . rseq' (n - 1) - where - rseq' :: RandomGen gen => Int -> gen -> [(Int, gen)] - rseq' 0 _ = [] - rseq' i gen = (j, gen) : rseq' (i - 1) gen' - where (j, gen') = randomR (0, i) gen - --- |shuffle' wrapped in a random monad -shuffleM :: (MonadRandom m) => [a] -> m [a] -shuffleM elements - | null elements = return [] - | otherwise = liftM (shuffle elements) (rseqM (length elements - 1)) - where - rseqM :: (MonadRandom m) => Int -> m [Int] - rseqM 0 = return [] - rseqM i = liftM2 (:) (getRandomR (0, i)) (rseqM (i - 1)) |