\section{Threaded Quality Control}
\begin{code}
module RSAGL.QualityControl
(QualityCache,newQuality,getQuality)
where
import Control.Parallel.Strategies
import Data.Map as Map
import Control.Concurrent
import Control.Monad
import Data.Maybe
import RSAGL.Bottleneck
\end{code}
The \texttt{QualityCache} object is used to memoize entities with variable levelofdetail.
\texttt{QualityCache}s use \texttt{Bottlenecks} to limit the amount of nonessential computation that is taking place at any one time.
\texttt{getQuality} answers the highestquality available object that has a quality less than or equal to the requested quality.
If necessary, the \texttt{QualityCache} fires off a worker thread to generate higherquality versions of the entity. At most
one worker thread is ever actually running for each \texttt{QualityCache}.
The effect when \texttt{QualityCache} is used to view 3D models is a little like loading a progressive JPEG. First a very low
quality model appears, which is gradually replaced by higher and higher qualities until the desired level of detail is finished.
\begin{code}
data QualityCache q a = QualityCache Bottleneck (Strategy a) (q -> a) (MVar [q]) (MVar (Map q a))
newQuality :: (Ord q) => Bottleneck -> Strategy a -> (q -> a) -> [q] -> IO (QualityCache q a)
newQuality _ _ _ [] = error "mkQuality: empty quality list"
newQuality bottleneck strategy f (q:qs) =
do lowest_quality <- return $! (f q `using` strategy)
liftM2 (QualityCache bottleneck strategy f) (newMVar qs) (newMVar $ singleton q lowest_quality)
completeQuality :: (Ord q) => QualityCache q a -> q -> IO ()
completeQuality (qo@(QualityCache bottleneck strategy f quality_mvar map_mvar)) want_q =
do qualities <- takeMVar quality_mvar
case qualities of
(q:qs) | q < want_q -> do new_elem <- constrict bottleneck $ return $| strategy $ f q
modifyMVar_ map_mvar (return . Map.insert q new_elem)
putMVar quality_mvar qs
completeQuality qo want_q
_ -> do putMVar quality_mvar qualities
getQuality :: (Ord q) => QualityCache q a -> q -> IO a
getQuality (qo@(QualityCache _ _ _ quality_mvar mv)) q =
do m <- readMVar mv
case Map.lookup q m of
Just a -> return a
Nothing -> do e <- isEmptyMVar quality_mvar
when (not e) $ (forkIO $ completeQuality qo q) >> return ()
let suitable_qualities = filterWithKey (\k _ -> (k <= q)) m
return $ snd $ if Map.null suitable_qualities
then findMin m
else findMax suitable_qualities
\end{code}