2016 Update

Task/Best-shuffle/Haskell/best-shuffle-1.hs

@@ -1,33 +1,12 @@
-import Data.Function (on)
-import Data.List
-import Data.Maybe
-import Data.Array
-import Text.Printf
+shufflingQuality l1 l2 = length $ filter id $ zipWith (==) l1 l2
 
-main = mapM_ f examples
-  where examples = ["abracadabra", "seesaw", "elk", "grrrrrr", "up", "a"]
-        f s = printf "%s, %s, (%d)\n" s s' $ score s s'
-          where s' = bestShuffle s
-
-score :: Eq a => [a] -> [a] -> Int
-score old new = length $ filter id $ zipWith (==) old new
-
-bestShuffle :: (Ord a, Eq a) => [a] -> [a]
-bestShuffle s = elems $ array bs $ f positions letters
-  where positions =
-            concat $ sortBy (compare `on` length) $
-            map (map fst) $ groupBy ((==) `on` snd) $
-            sortBy (compare `on` snd) $ zip [0..] s
-        letters = map (orig !) positions
-
-        f [] [] = []
-        f (p : ps) ls = (p, ls !! i) : f ps (removeAt i ls)
-          where i = fromMaybe 0 $ findIndex (/= o) ls
-                o = orig ! p
-
-        orig = listArray bs s
-        bs = (0, length s - 1)
-
-removeAt :: Int -> [a] -> [a]
-removeAt 0 (x : xs) = xs
-removeAt i (x : xs) = x : removeAt (i - 1) xs
+printTest prog = mapM_ test texts
+  where
+    test s = do
+      x <- prog s
+      putStrLn $ unwords $ [ show s
+                           , show x
+                           , show $ shufflingQuality s x]
+    texts = [ "abba", "abracadabra", "seesaw", "elk" , "grrrrrr"
+            , "up", "a", "aaaaa.....bbbbb"
+            , "Rosetta Code is a programming chrestomathy site." ]

Task/Best-shuffle/Haskell/best-shuffle-2.hs

@@ -1,2 +1,20 @@
-bestShuffle :: Eq a => [a] -> [a]
-bestShuffle s = minimumBy (compare `on` score s) $ permutations s
+import Data.Vector ((//), (!))
+import qualified Data.Vector as V
+import Data.List (delete, find)
+
+swapShuffle :: Eq a => [a] -> [a] -> [a]
+swapShuffle lref lst = V.toList $ foldr adjust (V.fromList lst) [0..n-1]
+  where
+    vref = V.fromList lref
+    n = V.length vref
+    adjust i v = case find alternative [0.. n-1] of
+      Nothing -> v
+      Just j -> v // [(j, v!i), (i, v!j)]
+      where
+        alternative j = and [ v!i == vref!i
+                            , i /= j
+                            , v!i /= vref!j
+                            , v!j /= vref!i ]
+
+shuffle :: Eq a => [a] -> [a]
+shuffle lst = swapShuffle lst lst

Task/Best-shuffle/Haskell/best-shuffle-3.hs

@@ -0,0 +1,11 @@
+perfectShuffle :: [a] -> [a]
+perfectShuffle [] = []
+perfectShuffle lst | odd n = b : shuffle (zip bs a)
+                   | even n = shuffle (zip (b:bs) a)
+  where
+    n = length lst
+    (a,b:bs) = splitAt (n `div` 2) lst
+    shuffle = foldMap (\(x,y) -> [x,y])
+	
+shuffleP :: Eq a => [a] -> [a]
+shuffleP lst = swapShuffle lst $ perfectShuffle lst

Task/Best-shuffle/Haskell/best-shuffle-4.hs

@@ -0,0 +1 @@
+import Control.Monad.Random (getRandomR)

Task/Best-shuffle/Haskell/best-shuffle-5.hs

@@ -0,0 +1,10 @@
+randomShuffle :: [a] -> IO [a]
+randomShuffle [] = return []
+randomShuffle lst = do
+  i <- getRandomR (0,length lst-1)
+  let (a, x:b) = splitAt i lst
+  xs <- randomShuffle $ a ++ b
+  return (x:xs)
+
+shuffleR :: Eq a => [a] -> IO [a]
+shuffleR lst = swapShuffle lst <$> randomShuffle lst

Task/Best-shuffle/Haskell/best-shuffle-6.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TupleSections, LambdaCase #-}
+import Conduit
+import Control.Monad.Random (getRandomR)
+import Data.List (delete, find)
+
+shuffleC :: Eq a => Int -> Conduit a IO a
+shuffleC 0 = awaitForever yield
+shuffleC k = takeC k .| sinkList >>= \v -> delay v .| randomReplace v
+
+delay :: Monad m => [a] -> Conduit t m (a, [a])
+delay [] = mapC $ \x -> (x,[x])
+delay (b:bs) = await >>= \case
+  Nothing -> yieldMany (b:bs) .| mapC (,[])
+  Just x -> yield (b, [x]) >> delay (bs ++ [x])
+
+randomReplace :: Eq a => [a] -> Conduit (a, [a]) IO a
+randomReplace vars = awaitForever $ \(x,b) -> do
+  y <- case filter (/= x) vars of
+    [] -> pure x
+    vs -> lift $ (vs !!) <$> getRandomR (0, length vs - 1)
+  yield y
+  randomReplace $ b ++ delete y vars
+
+shuffleW :: Eq a => Int -> [a] -> IO [a]
+shuffleW k lst = yieldMany lst =$= shuffleC k $$ sinkList

Task/Best-shuffle/Haskell/best-shuffle-7.hs

@@ -0,0 +1,4 @@
+import Data.ByteString.Builder (charUtf8)
+import Data.ByteString.Char8 (ByteString, unpack, pack)
+import Data.Conduit.ByteString.Builder (builderToByteString)
+import System.IO (stdin, stdout)

Task/Best-shuffle/Haskell/best-shuffle-8.hs

@@ -0,0 +1,13 @@
+shuffleBS :: Int -> ByteString -> IO ByteString
+shuffleBS n s =
+  yieldMany (unpack s)
+  =$ shuffleC n
+  =$ mapC charUtf8
+  =$ builderToByteString
+  $$ foldC
+
+main :: IO ()
+main =
+  sourceHandle stdin
+  =$ mapMC (shuffleBS 10)
+  $$ sinkHandle stdout