Ticket #6146: Main.2.hs

File Main.2.hs, 1.5 KB (added by emcdowell, 23 months ago)

Pi.hs

Line 
1
2module Main (main) where
3
4import Numeric
5import System.IO
6import Control.Concurrent
7
8subtotal :: MVar Double -> Double -> Double -> Double -> IO ()
9subtotal result posn max step = do
10    let answer = puretotal posn max step 0.0 
11    putMVar result (4.0 * answer / max)
12
13puretotal :: Double -> Double -> Double -> Double -> Double
14puretotal posn max step sum =
15    if posn > max then
16        sum
17    else
18        let x = (posn - 0.5) / max
19            y = sqrt (1.0 - x * x)
20            newpos = posn + step
21            newsum = sum + y
22        in seq newsum (seq newpos (puretotal newpos max step newsum))
23             
24main :: IO ()
25main = do
26    hSetBuffering stdout NoBuffering
27    putStr "Terms?  "
28    max <- readLn :: IO Double
29    putStr "Tasks?  "
30    step <- readLn :: IO Double
31    ls <- spawn 1.0 max step []
32    answer <- gather ls 0.0
33    putStrLn $ (showFFloat (Just 12) answer) ""
34
35spawn :: Double -> Double -> Double -> [MVar Double] -> IO [MVar Double]
36spawn posn max step ls = do
37    if posn > step then do
38        return ls
39    else do
40        reply <- newEmptyMVar :: IO (MVar Double)
41        forkIO $ subtotal reply posn max step
42        let newposn = posn + 1.0
43            newls = reply : ls
44        seq newposn seq newls spawn newposn max step newls
45       
46gather :: [MVar Double] -> Double -> IO Double
47gather [] sum = do
48    return sum
49gather (item : rest) sum = do
50    term <- takeMVar item
51    let newsum = sum + term
52    seq newsum gather rest newsum