{-- Card rendering, suit and rank. --} -- Text coloring. color c s = "" ++ s ++ "" -- Following USPCC new deck order. A-K spades, A-K diamonds, K-A clubs, K-A hearts renderSuit 0 = "♠" renderSuit 1 = "♦" renderSuit 2 = "♣" renderSuit 3 = "♥" listAK = [ "A", "2", "3", "4", "5", "6", "7", "8", "9", "10", "J", "Q", "K" ] listSuit suit = [ listAK, reverse listAK ] !! (div suit 2) renderRank n suit = (listSuit suit) !! n -- Suit coloring. suitColor suit = [ "black", "red" ] !! (mod suit 2) renderColor suit s = color (suitColor suit) s -- Turn a card number into new deck order. renderCard n = do let o = n - 1 suit = div o 13 rank = mod o 13 renderColor suit ("" ++ (renderRank rank suit) ++ (renderSuit suit) ++ "") -- Render using USPCC new deck order, suit and rank. renderDeckUSPCC d = foldl (++) "" (map renderCard d) -- Render as numbers. renderDeckPlain d = "" ++ show d ++ "" -- Show a deck. If it has 52 cards, use suit and rank, otherwise just show number. showDeck d = if (length d) == 52 then renderDeckUSPCC d else renderDeckPlain d {-- Rendering shuffles. --} showShuffle s = "
  • " ++ (showDeck s) ++ "
    • \n" showShuffles n s = "

    " ++ (show n) ++ "-card deck

    Starting order:

    " ++ (showDeck [1..n]) ++ "

    Shuffles:

      \n" ++ (foldl (++) "" (map showShuffle s)) ++ "
    \n" {-- Deck shuffling. --} -- Merge two decks. mergeDecks [] [] = [] mergeDecks (x:xs) (y:ys) = [x, y] ++ (mergeDecks xs ys) -- Split and merge two decks. pharaohShuffle d = do let ds = splitAt (div (length d) 2) d mergeDecks (fst ds) (snd ds) {-- Generating a series of shuffles. --} -- Finish shuffling when the current deck is identical to the goal deck. pharaohShuffleUntil m dc dg = do if dc == dg then [dg] else [dc] ++ (pharaohShuffleUntil (m + 1) (pharaohShuffle dc) dg) -- Shuffle a deck of the specified size. pharaohShuffleDeck n = do let start = [1..n] pharaohShuffleUntil 1 (pharaohShuffle start) start -- Shuffle each possible size. pharaohShuffleRange [] = [] pharaohShuffleRange (x:xs) = [(x, pharaohShuffleDeck x)] ++ (pharaohShuffleRange xs) main = do putStrLn "Paraaoh's Shuffle of even-sized decks." putStrLn "

    Pharaoh's Shuffle

    " putStrLn "

    " putStrLn "(Also known as a \"Pharaoh Shuffle\" or a \"Faro Shuffle\".)" putStrLn "

    " putStrLn "

    " putStrLn "A Pharaoh's Shuffle is a common type of shuffle in card magic. Done correctly, it perfectly interleaves two halves of a deck with one another, and if done repeatedly will eventually yield the original deck order. For a magician working with a sorted check of 52 cards, 8 shuffles will yield the deck in its original order, which has obvious uses." putStrLn "

    " putStrLn "

    " putStrLn "With decks with an even number of cards but not 52, though, the results are a little different. In fact, they're quite interesting. And for powers of two, the number of shuffles is the log2 of the deck size, for reasons left as an exercise to the reader. There are various people claiming around the Internet that no matter the deck size, 8 shuffles works to return a deck to its original order. So here we present a series of shuffles for various deck sizes." putStrLn "

    " putStrLn "

    " putStrLn "For each deck size, a series of Pharaoh's Shuffles is given until the deck is in its original sorted order. Each numbered item shows the order of the deck after that shuffle, so the 8th item in the 52-card deck example shows the deck in its original order. Numbers are used here for clarity, except for the 52-card deck which is rendered with standard color, suit and rank, in new deck order." putStrLn "

    " putStrLn "

    " putStrLn "As you can see, if you want to shuffle a 52-card deck back to its original state with optimum efficiency, you should add 12 blanks, do 6 shuffles, and then remove the 12 blanks. You might even be able to fool other magicians with a perfect shuffle in under 8 shuffles. Palming 12 blanks is comparatively-easy." putStrLn "

    " putStrLn "

    " putStrLn "This page was generated with the (badly-written) Haskell program available here." putStrLn "

    " putStrLn (foldl (++) "" (map (\ (n, s) -> showShuffles n s) (pharaohShuffleRange [2,4..64]))) putStrLn "Copyright © 2012 Juli Mallett. Few, if any, rights reserved. Any reproduction to any person, living or dead, is purely allowed without limit." putStrLn ""