-- Jonathan Frech, 24th, 25th of January 2020
-- Entropy captures an entire probability space on which the appropriate
-- algorithm is performed. It thereby allows to fully determine the
-- involved probabilities.
type Entropy = [Int]
-- "Factorial entropy" denotes the entropy used in the correct shuffling
-- algorithm, "unrestricted entropy" the one used in the incorrect algorithm.
fullFactorialEntropy, fullUnrestrictedEntropy :: Int -> [Entropy]
fullFactorialEntropy n = cartesian . reverse $ [[1..j] | j <- [1..n]]
fullUnrestrictedEntropy n = cartesian . reverse $ [[1..n] | _ <- [1..n]]
-- a quicksort implementation
sort :: Ord a => [a] -> [a]
sort [] = []
sort (x:xs) = sort [y | y <- xs, y <= x] ++ [x]
++ sort [y | y <- xs, y > x]
-- the cartesian product on a variable number of lists;
-- cartesian [[1], [1,2], [1,2,3]]
-- === [ [1,1,1], [1,1,2], [1,1,3]
-- , [1,2,1], [1,2,2], [1,2,3]]
cartesian :: [[a]] -> [[a]]
cartesian [] = [[]]
cartesian (x:xs) = (:) <$> x <*> cartesian xs
-- perform a lookup and extract it from the association
lookupSplit :: Eq a => a -> [(a,b)] -> (Maybe b, [(a,b)])
lookupSplit = go []
where go :: Eq a => [(a,b)] -> a -> [(a,b)] -> (Maybe b,[(a,b)])
go lok _ [] = (Nothing,lok)
go lok x (a@(y,z):as) | x == y = (Just z, lok ++ as)
| otherwise = go (lok ++ [a]) x as
-- compute a tally of a list
tally :: Eq a => [a] -> [(a,Int)]
tally = go []
where go t [] = t
go t (x:xs) = go (ss ++ [(x, n)]) xs
where (n,ss) = case lookupSplit x t of
(Just n ,ss) -> (1+n,ss)
(Nothing,ss) -> (1 ,ss)
-- swap two list elements, zero-indexed
swap :: Int -> Int -> [a] -> [a]
swap j i xs | j > i = swap i j xs
| j == i = xs
| otherwise = take j xs
++ [xs !! i]
++ drop (j+1) (take i xs)
++ [xs !! j]
++ drop (i+1) xs
-- perform all swaps on a list given the process' full entropy
performSwaps :: Entropy -> [a] -> [a]
performSwaps = go 0
where go _ [] xs = xs
go j (e:es) xs | ys <- swap j ((e-1+j) `mod` length xs) xs
= go (j+1) es ys
-- perform the experiment using a certain amount of entropy
performExperiment :: [Entropy] -> [a] -> [[a]]
performExperiment entropy xs = flip performSwaps xs <$> entropy
-- perform the full experiment, using all possible entropy
performFullExperiment :: (Int -> [Entropy]) -> Int -> [[Int]]
performFullExperiment fullEntropy n = performExperiment (fullEntropy n) [1..n]
-- draw a histogram of the given data
histogram :: [(a,Int)] -> String
histogram dat | m <- maximum . fmap snd $ dat
= unlines . fmap borders
$ reverse [[if snd d >= line then '|' else ' '
| d <- dat] | line <- [1..m]]
where borders txt = "[" ++ txt ++ "]"
-- plot the discrete density for falseShuffle
main :: IO ()
main = do putStrLn $ "Jonathan Frech, 25th of January 2020\n\nPlots of the disc"
++ "rete density function of a false shuffle for 0 <= n <= 6"
++ ".\nSee https://jonathanfrech.wordpress.com/2020/01/25/no"
++ "n-uniform-shuffling/ for\nmore information.\n"
mapM_ plot [0..6]
where visualize = histogram . sort . tally
plot n = do putStrLn $ "n = " ++ show n ++ ":"
putStrLn . visualize
$ performFullExperiment fullUnrestrictedEntropy n