module Control.Concurrent.ParallelTreeSearch ( parallelTreeSearch ) where
import Control.Monad.SearchTree
import Control.Concurrent
parallelTreeSearch :: Int
-> Int
-> SearchTree a
-> IO [a]
parallelTreeSearch tl wl t =
do counter <- newMVar 1
channel <- newChan
let env = SearchEnv tl wl counter channel
forkIO (parSearch env [] [t])
xs <- getChanContents channel
return (concNonEmpty xs)
concNonEmpty :: [[a]] -> [a]
concNonEmpty [] = []
concNonEmpty ([]:_) = []
concNonEmpty (xs:xss) = xs ++ concNonEmpty xss
data SearchEnv a = SearchEnv { threadLimit :: Int
, workLimit :: Int
, threadCounter :: MVar Int
, results :: Chan [a] }
type Queue a = [SearchTree a]
parSearch :: SearchEnv a -> [a] -> Queue a -> IO ()
parSearch env xs [] = do writeResults env xs
finaliseResults env
parSearch env xs q =
do noMoreThreads <- threadLimitReached env
if noMoreThreads
then let (ys,q') = search (workLimit env) xs q
in do writeResults env ys
parSearch env [] q'
else do (ys,q') <- process env [] q
parSearch env ys q'
process :: SearchEnv a -> [a] -> Queue a -> IO ([a], Queue a)
process _ xs [] = return (xs,[])
process env xs (None : q) = process env xs q
process env xs (One x : q) = process env (x:xs) q
process env xs (Choice s t : q) = do incThreadCounter env
forkIO (parSearch env xs [s])
return ([],t:q)
writeResults :: SearchEnv a -> [a] -> IO ()
writeResults _ [] = return ()
writeResults env xs = writeChan (results env) xs
incThreadCounter :: SearchEnv a -> IO ()
incThreadCounter env = modifyMVar_ (threadCounter env) (return.(+1))
threadLimitReached :: SearchEnv a -> IO Bool
threadLimitReached env = do count <- readMVar (threadCounter env)
return (count >= threadLimit env)
finaliseResults :: SearchEnv a -> IO ()
finaliseResults env = do count <- takeMVar (threadCounter env)
if count <= 1
then writeChan (results env) []
else putMVar (threadCounter env) (count1)
search :: Int -> [a] -> Queue a -> ([a],Queue a)
search _ xs [] = (xs,[])
search 0 xs q = (xs,q)
search n xs (None : q) = search (n1) xs q
search n xs (One x : q) = search (n1) (x:xs) q
search n xs (Choice s t : q) = search (n1) xs (s:t:q)