{-# LANGUAGE BangPatterns #-}
import qualified Data.IntMap.Lazy as I
import Control.Monad
import System.Random

main :: IO ()
main = do
  (a, b) <- dicePi 4 1000000
  putStrLn $ "pi = " ++ show a
  print b

dicePi :: Int -> Double -> IO (Double, [(Int, Int)])
dicePi diceNum n = do
  (r, d) <- go n 0 (I.fromList $ zip [1..6] [0,0..])
  return (4 * r / n, I.assocs d)
  where
    go 0 count d = return (count, d)
    go m count d = do
      x0 <- replicateM diceNum rollDice
      y0 <- replicateM diceNum rollDice
      let !h = (sqrt $! x * x + y * y) :: Double
          !x = f x0
          !y = f y0
          d' = foldr upd d $ x0 ++ y0
      go (m - 1) (if h < 1.0 then count + 1 else count) d'
    f :: [Int] -> Double
    f xxs = (/ (6 ^ diceNum)) $ fromIntegral $ g xxs
      where
        g []     = 0
        g (x:xs) = x - 1 + 6 * (g xs)
    upd k im = I.update ((Just $!) . succ) k im

rollDice :: IO Int
rollDice = getStdRandom (randomR (1, 6))