module Main where -- Don't look at these! import Data.Time.Clock (diffUTCTime, getCurrentTime) import Data.IntMap (IntMap) import Data.List import Data.Tuple (swap) import System.Environment (getArgs) import System.Random (StdGen, mkStdGen, getStdGen, randoms) import qualified Data.IntMap.Strict as Map import SparseGraph import HeavyStuff -- You can look here though. import Control.Parallel -- par and pseq (should be in base) import Control.Monad.Par -- Par monad (monad-par on hackage) -------------------------------------------------------------------------------- -- * Intro. -------------------------------------------------------------------------------- mMap :: (a -> b) -> [a] -> [b] mMap f [] = [] --mMap f (x:xs) = f x : mMap f xs mMap f (x:xs) = let x' = f x xs' = mMap f xs in x' : xs' mLength :: [a] -> Int mLength [] = 0 mLength (_:xs) = 1 + mLength xs mSum :: [Int] -> Int mSum [] = 0 mSum (x:xs) = x + mSum xs -------------------------------------------------------------------------------- -- * Smaller examples. -------------------------------------------------------------------------------- -- par & pseq :: a -> b -> b heavy :: Int heavy = mEuler `par` (mFib `pseq` mEuler + mFib) -------------------------------------------------------------------------------- todoFibs :: [Int] todoFibs = [37,38,39,40] todoEulers :: [Int] todoEulers = [7600, 7600] heavy2 :: Int heavy2 = sum $ concat [pMap fib todoFibs, pMap euler todoEulers] heavy3 :: Int heavy3 = (force mEulers) `par` (force mFibs `pseq` sum mEulers + sum mFibs) force :: [Int] -> () force [] = () force (x:xs) = x `pseq` force xs pMap :: (a -> b) -> [a] -> [b] pMap f [] = [] pMap f (x:xs) = let x' = f x xs' = pMap f xs in x' `par` (xs' `pseq` (x' : xs')) mSpawn :: NFData a => Par a -> Par (IVar a) mSpawn a = do i <- new fork $ (do x <- a; put i x) return i parMap :: NFData b => (a -> Par b) -> [a] -> Par [b] parMap f xs = do is <- mapM (\x -> mSpawn (f x)) xs mapM get is -- newtype Par a -- instance Monad Par -- runPar :: Par a -> a -- fork :: Par () -> Par () -- data IVar a -- instance Eq (IVar a) -- new :: Par (IVar a) -- put :: NFData a => IVar a -> a -> Par () -- get :: IVar a -> Par a apa :: Int apa = runPar $ do i <- new j <- new fork $ put i (mFib) fork $ put j (mEuler) a <- get i b <- get j return (a + b) -------------------------------------------------------------------------------- -- ** Main. main = do start <- getCurrentTime pseq (heavy3) (return ()) end <- getCurrentTime putStrLn ("sum: " ++ show apa) putStrLn ("time: " ++ show (end `diffUTCTime` start) ++ " seconds") -- hint to self: don't scroll down yet! -------------------------------------------------------------------------------- -- * Bigger example. -------------------------------------------------------------------------------- sSort :: [Int] -> [Int] sSort [] = [] sSort (x:xs) = lt ++ x : gte where lt = sSort [ y | y <- xs, y < x] gte = sSort [ y | y <- xs, y >= x] mSort :: Int -> [Int] -> [Int] mSort d [] = [] mSort 0 xs = sSort xs --let x = sSort xs in (force x) `pseq` x mSort d (x:xs) = (force2 lt) `par` (force2 gte `pseq` (lt ++ x : gte)) where lt = mSort (d-1) [ y | y <- xs, y < x] gte = mSort (d-1) [ y | y <- xs, y >= x] -------------------------------------------------------------------------------- -- ** New Main. {- main = do start <- getCurrentTime input <- randomInts 5000000 `fmap` getStdGen let res = mSort 5 input pseq (force res) (return ()) end <- getCurrentTime --putStrLn ("sum: " ++ show res) putStrLn ("time: " ++ show (end `diffUTCTime` start) ++ " seconds") -} -- makes some random numbers. randomInts :: Int -> StdGen -> [Int] randomInts k g = let result = take k (randoms g) in force2 result `pseq` result -- force the spine of a list to be evaluated. force2 :: [a] -> () force2 xs = go xs `pseq` () where go (_:xs) = go xs go [] = 1 -- hint to self: don't scroll down yet! -------------------------------------------------------------------------------- -- * Even bigger example. -------------------------------------------------------------------------------- -- shortestPaths :: Graph -> Vertex -> Vertex -> Vertex -> Weight -- shortestPaths g i j 0 = weight g i j -- shortestPaths g i j k = min -- ( shortestPaths g i j (k-1) -- , shortestPaths g i k (k-1) + shortestPaths g k j (k-1)) -- type Vertex = Int -- type Weight = Int -- type Graph = Vertex -> (Vertex -> Weight) -------------------------------------------------------------------------------- shortestPaths :: [Vertex] -> Graph -> Graph shortestPaths vs g = foldl' update g vs -- <1> where update :: Graph -> Vertex -> Graph -- <2> update g k = Map.mapWithKey (\v jmap -> shortmap v jmap) g where shortmap :: Vertex -> IntMap Weight -> IntMap Weight shortmap i jmap = foldr shortest Map.empty vs -- <3> where shortest j m = case (old,new) of -- <6> (Nothing, Nothing) -> m (Nothing, Just w ) -> Map.insert j w m (Just w, Nothing) -> Map.insert j w m (Just w1, Just w2) -> Map.insert j (min w1 w2) m where old = Map.lookup j jmap -- <4> new = do w1 <- weight g i k -- <5> w2 <- weight g k j return (w1+w2) -------------------------------------------------------------------------------- {- main :: IO () main = do let h = 1000 let n = 800 let g = mkStdGen 9999 let (mat,vs) = randomGraph g h 100 n let check = checksum (shortestPaths vs mat) start <- getCurrentTime pseq (check) (return ()) end <- getCurrentTime putStrLn ("checksum: " ++ show check) putStrLn ("time: " ++ show (end `diffUTCTime` start) ++ " seconds") -} -------------------------------------------------------------------------------- -- newtype Par a -- instance Monad Par -- runPar :: Par a -> a -- fork :: Par () -> Par () -- data IVar a -- instance Eq (IVar a) -- new :: Par (IVar a) -- put :: NFData a => IVar a -> a -> Par () -- get :: IVar a -> Par a -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- -- Solutions, in case I forget them. -- Par {- f `par` (f + e) Bad! Spark has no time to finish since main thread will start on f immediately. f `par` (e + f) Very Bad! Haskell migth re-write the expression and put us back to square one. f `par` (e `pseq` e + f) Better! -} -- Par lists {- f `par` (e `pseq` e + f) -- Bad! We only evaluate to the first list constructor, not its elements. (force f) `par` ((force e) `pseq` sum e + sum f) -- Better! -} -- Graphs {- mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b traverseWithKey :: Monad t => (Key -> a -> m b) -> IntMap a -> m (IntMap b) update g k = runPar $ do m <- Map.traverseWithKey (\i jmap -> spawn (return (shortmap i jmap))) g traverse get m -}