sleepsort

sleepsort.erl

-module(sleepsort).                                                                                                                                                                                         
-export([sleepsort/1, sleepsort/2]).

timer(Val, Pid, Quality) ->
    receive after Quality * Val -> Pid ! Val end.

gather(Acc, N, Max) when N + 1 > Max -> lists:reverse(Acc);
gather(Acc, N, Max) -> receive Val -> gather([Val | Acc], N + 1, Max) end.

sort([], N, _) ->
    gather([], 0, N);
sort([Val | Arr], N, Quality) ->
    Me = self(),
    spawn(fun () -> timer(Val, Me, Quality) end),
    sort(Arr, N + 1, Quality).

sleepsort(Arr) -> sort(Arr, 0, 18).
sleepsort(Arr, Quality) -> sort(Arr, 0, Quality).

SleepSort.hs

module SleepSort (sleepsort) where

import Control.Concurrent                                                                                                                                                                                                                      
import Control.Concurrent.STM

worker chan timefun val = do
  threadDelay $ timefun val
  atomically $ writeTChan chan val

sleepsort :: (a -> Int) -> [a] -> IO [a]
sleepsort timefun arr = do
  chan <- newTChanIO
  mapM_ (forkIO . worker chan timefun) arr
  mapM (\_ -> atomically $ readTChan chan) [1 .. length arr]

SleepSortBar.hs

module SleepSortBar (sleepsort) where                                                                                                                                                                                                          

import Control.Concurrent
import Control.Concurrent.STM

--- Barriers
type Barrier a = MVar a

newBarrier :: IO (Barrier a)
newBarrier = newEmptyMVar

signalBarrier :: Barrier a -> a -> IO ()
signalBarrier = putMVar

waitBarrier :: Barrier a -> IO a
waitBarrier = readMVar

--- Sleepsort

worker bar chan timefun val = do
  waitBarrier bar
  threadDelay $ timefun val
  atomically $ writeTChan chan val

sleepsort :: (a -> Int) -> [a] -> IO [a]
sleepsort timefun arr = do
  bar <- newBarrier
  chan <- newTChanIO
  mapM_ (forkIO . worker bar chan timefun) arr
  signalBarrier bar ()
  mapM (\_ -> atomically $ readTChan chan) [1 .. length arr]