Mind boggling card trick: Difference between revisions
Content added Content deleted
m (→{{header|Haskell}}: mapM -> traverse) |
|||
Line 285: | Line 285: | ||
import Data.List (partition) |
import Data.List (partition) |
||
import Data.Monoid ((<>)) |
import Data.Monoid ((<>)) |
||
main :: IO [Int] |
main :: IO [Int] |
||
main = do |
main = do |
||
-- DEALT |
-- DEALT |
||
ns <- knuthShuffle [1 .. 52] |
ns <- knuthShuffle [1 .. 52] |
||
let (rs_, bs_, discards) = threeStacks (rb <$> ns) |
let (rs_, bs_, discards) = threeStacks (rb <$> ns) |
||
-- SWAPPED |
-- SWAPPED |
||
nSwap <- randomRIO (1, min (length rs_) (length bs_)) |
nSwap <- randomRIO (1, min (length rs_) (length bs_)) |
||
let (rs, bs) = exchange nSwap rs_ bs_ |
let (rs, bs) = exchange nSwap rs_ bs_ |
||
-- CHECKED |
-- CHECKED |
||
let rrs = filter ('R' ==) rs |
let rrs = filter ('R' ==) rs |
||
Line 311: | Line 311: | ||
] |
] |
||
return ns |
return ns |
||
-- RED vs BLACK ---------------------------------------- |
-- RED vs BLACK ---------------------------------------- |
||
rb :: Int -> Char |
rb :: Int -> Char |
||
Line 317: | Line 317: | ||
| even n = 'R' |
| even n = 'R' |
||
| otherwise = 'B' |
| otherwise = 'B' |
||
-- THREE STACKS ---------------------------------------- |
-- THREE STACKS ---------------------------------------- |
||
threeStacks :: String -> (String, String, String) |
threeStacks :: String -> (String, String, String) |
||
Line 327: | Line 327: | ||
| 'R' == x = go (y : rs, bs, x : ds) xs |
| 'R' == x = go (y : rs, bs, x : ds) xs |
||
| otherwise = go (rs, y : bs, x : ds) xs |
| otherwise = go (rs, y : bs, x : ds) xs |
||
exchange :: Int -> [a] -> [a] -> ([a], [a]) |
exchange :: Int -> [a] -> [a] -> ([a], [a]) |
||
exchange n xs ys = |
exchange n xs ys = |
||
let [xs_, ys_] = splitAt n <$> [xs, ys] |
let [xs_, ys_] = splitAt n <$> [xs, ys] |
||
in (fst ys_ <> snd xs_, fst xs_ <> snd ys_) |
in (fst ys_ <> snd xs_, fst xs_ <> snd ys_) |
||
-- SHUFFLE ----------------------------------------------- |
-- SHUFFLE ----------------------------------------------- |
||
-- (See Knuth Shuffle task) |
-- (See Knuth Shuffle task) |
||
knuthShuffle :: [a] -> IO [a] |
knuthShuffle :: [a] -> IO [a] |
||
knuthShuffle xs = (foldr swapElems xs . zip [1 ..]) <$> randoms (length xs) |
knuthShuffle xs = (foldr swapElems xs . zip [1 ..]) <$> randoms (length xs) |
||
randoms :: Int -> IO [Int] |
randoms :: Int -> IO [Int] |
||
randoms x = |
randoms x = traverse (randomRIO . (,) 0) [1 .. (pred x)] |
||
swapElems :: (Int, Int) -> [a] -> [a] |
swapElems :: (Int, Int) -> [a] -> [a] |
||
swapElems (i, j) xs |
swapElems (i, j) xs |
||
| i == j = xs |
| i == j = xs |
||
| otherwise = replaceAt j (xs !! i) $ replaceAt i (xs !! j) xs |
| otherwise = replaceAt j (xs !! i) $ replaceAt i (xs !! j) xs |
||
replaceAt :: Int -> a -> [a] -> [a] |
replaceAt :: Int -> a -> [a] -> [a] |
||
replaceAt i c l = |
replaceAt i c l = |