Ticket #6146: Main.2.hs

module Main (main) where

import Numeric
import System.IO
import Control.Concurrent

subtotal :: MVar Double -> Double -> Double -> Double -> IO ()
subtotal result posn max step = do
    let answer = puretotal posn max step 0.0 
    putMVar result (4.0 * answer / max)

puretotal :: Double -> Double -> Double -> Double -> Double
puretotal posn max step sum =
    if posn > max then
        sum
    else
        let x = (posn - 0.5) / max
            y = sqrt (1.0 - x * x)
            newpos = posn + step
            newsum = sum + y
        in seq newsum (seq newpos (puretotal newpos max step newsum))
             
main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    putStr "Terms?  "
    max <- readLn :: IO Double
    putStr "Tasks?  "
    step <- readLn :: IO Double
    ls <- spawn 1.0 max step []
    answer <- gather ls 0.0
    putStrLn $ (showFFloat (Just 12) answer) ""

spawn :: Double -> Double -> Double -> [MVar Double] -> IO [MVar Double]
spawn posn max step ls = do
    if posn > step then do
        return ls
    else do
        reply <- newEmptyMVar :: IO (MVar Double)
        forkIO $ subtotal reply posn max step
        let newposn = posn + 1.0
            newls = reply : ls
        seq newposn seq newls spawn newposn max step newls
        
gather :: [MVar Double] -> Double -> IO Double
gather [] sum = do
    return sum
gather (item : rest) sum = do
    term <- takeMVar item
    let newsum = sum + term
    seq newsum gather rest newsum