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

main :: IO ()
main = do
  rd <- rollDice
  let (a, b) = dicePi 4 300000 rd

  putStrLn $ "pi = " ++ show a
  print b

dicePi :: Int -> Double -> [Int] -> (Double, [(Int, Int)])
dicePi diceNum n rd = (4 * c / n, I.assocs im)
  where
    (c, im) = go n 0 rd (I.fromList $ zip [1..6] [0,0..])
    go 0 count _     im = (count, im)
    go m count rolls im =
      let !h = sqrt $! x * x + y * y :: Double
          (r1, rs) = splitAt diceNum rolls
          r2       = take diceNum rs
          !x       = dicesToRandom r1
          !y       = dicesToRandom r2
          !count'  = if h < 1.0 then count + 1 else count
          rolls'   = drop diceNum rs
          !im'     = foldr (I.update ((Just $!) . succ)) im $! r1 ++ r2
      in go (m - 1) count' rolls' im'
    diceToRandom :: [Int] -> Double
    diceToRandom xxs = (/ (6 ^ diceNum)) $ fromIntegral $ foldl g 0 xxs
      where
        g !x !y = 6 * x + y - 1

rollDice :: IO [Int]
rollDice = getStdGen >>= (return . randomRs (1, 6))