Functional Programming - class 10

kent-class10.hs

import Control.Concurrent

mergesortM :: (Ord a) => [a] -> IO [a]
mergesortM xs = do
    c <- newChan
    mergesortP xs c
    result <- readChan c
    return result

mergesortP :: (Ord a) => [a] -> Chan [a] -> IO ()
mergesortP [] c =
    writeChan c []
mergesortP [x] c =
    writeChan c [x]
mergesortP (x:y:xs) c = do
    result <- splitAndSortM xs [x] [y]
    writeChan c result

splitAndSortM :: (Ord a) => [a] -> [a] -> [a] -> IO [a]
splitAndSortM [] xs ys =
    do
        -- Create a new channel
        c <- newChan
        -- Sort those lists
        forkIO $ mergesortP xs c
        forkIO $ mergesortP ys c
        -- Get the answers back
        xs' <- readChan c
        ys' <- readChan c
        -- Join the results
        mergeM xs' ys'

splitAndSortM (x:zs) xs ys =
    splitAndSortM zs (x:ys) xs

mergeM :: (Ord a) => [a] -> [a] -> IO [a]
mergeM [] xs = return xs
mergeM xs [] = return xs
mergeM (x:xs) (y:ys) = 
    if x <= y then do
        xs' <- mergeM xs (y:ys)
        return (x:xs')
    else do
        ys' <- mergeM (x:xs) ys
        return (y:ys')