Haskell implementation of the dice puzzle presented at https://www.youtube.com/watch?v=Hfw8bB82-ps

DicePuzzle.hs

module DicePuzzle where

import Control.Arrow ((&&&))
import Control.Monad
import Data.List

{-|
  Projecting the result of three dice onto two dice.
  After the design of Katie and Paul [1,2,3].
  [1]: https://www.youtube.com/watch?v=Hfw8bB82-ps
  [2]: https://dl.dropboxusercontent.com/u/14337736/flowchart.png
  [3]: http://www.r-fiddle.org/#/fiddle?id=tdaLsnvA&version=4
|-}

type Dice = Int

possibleRolls :: [[Dice]]
possibleRolls = [[x, y, z]| x <- values, y <- values, z <- values]
  where
    values = [1..6]

projectToOne :: [Dice] -> Dice
projectToOne = f . (`mod` 6) . sum
  where
    f 0 = 6
    f x = x

flipIfEven :: Dice -> [Dice] -> [Dice]
flipIfEven d ds
  | even d = map (7 -) ds
  | otherwise = ds

twoDifferentEvens :: [Dice] -> Bool
twoDifferentEvens = (== 2) . length . nub . filter even
 
singular :: [Dice] -> [Dice]
singular ds = [d | d <- ds, length (filter (== d) ds) == 1]

differentsTwice :: [Dice] -> [Dice]
differentsTwice = return . (2*) . length . nub

projectToTwo :: [Dice] -> [Dice]
projectToTwo d3 =
  let d1 = projectToOne d3
      d3' = flipIfEven d1 d3
  in (d1:) $ flipIfEven d1 $ if twoDifferentEvens d3'
       then filter odd d3'
       else if d1 `notElem` [3,6]
         then map (+1) $ singular d3'
         else if [2,2,5] == sort d3'
           then [2]
           else differentsTwice d3'

report :: (Show d, Ord d) => [d] -> IO ()
report ds = do
  let ds' = map (head &&& length) . group $ sort ds
  forM_ ds' $ \(r, c) ->
    putStrLn $ "The result " ++ show r ++ " was rolled " ++ show c ++ " times."

main :: IO ()
main = do
  putStrLn "Projection of 3 dice to a single one:"
  report $ map projectToOne possibleRolls
  putStrLn "Projection of 3 dice to two dice:"
  report $ map projectToTwo possibleRolls