TC> dmin p = do TC> mv <- dmin' p TC> case mv of TC> Nothing -> error "dmin: no values" TC> Just (v,_) -> return v TC> dmin' p = do TC> t <- readTVar p TC> case t of TC> Empty -> return Nothing TC> Trie l m r -> do TC> mv <- dmin' l TC> case mv of TC> Nothing -> do TC> mv <- readTVar m TC> case mv of TC> Nothing -> do TC> mv <- dmin' r TC> case mv of TC> Nothing -> error "emit nasal daemons" TC> Just (v,e) -> do TC> if e TC> then writeTVar p Empty TC> else return () TC> return mv TC> Just v -> do TC> re <- null r TC> case re of TC> False -> writeTVar m Nothing TC> True -> writeTVar p Empty TC> return (Just (v,re)) TC> Just (v,e) -> do TC> case e of TC> True -> do TC> me <- empty m TC> re <- null r TC> case me && re of TC> False -> writeTVar m Nothing TC> True -> writeTVar p Empty TC> return (Just (v,me && re)) TC> False -> return mv TC> where TC> empty m = do TC> v <- readTVar m TC> case v of TC> Nothing -> return True TC> Just _ -> return False data MaybeT m a = MaybeT {runMaybeT :: m (Maybe a)} fromMaybeT dflt handle (MaybeT mmx) = mmx >>= maybe dflt handle instance Monad m => Monad (MaybeT m) where return x = MaybeT $ return $ Just x MaybeT mmx >>= f = MaybeT $ mmx >>= maybe (return Nothing) (runMaybeT . f) instance Monad m => MonadPlus (MaybeT m) where mzero = MaybeT $ return mzero MaybeT mmx `mplus` MaybeT mmy = MaybeT $ liftM2 mplus mmx mmy instance MonadTrans MaybeT where lift mx = MaybeT $ liftM return mx dmin p = fromMaybeT (error "dmin: no values") (\(v,_) -> return v) $ dmin' p dmin' p = do null' p >>= guard Trie l m r <- readMbTVar p (do mv@(v,e) <- dmin' l (do guard e me <- empty m re <- null' r let b = me && re if b then writeMbTVar p Empty else writeMbTVar m Nothing return (v,b)) `mplus` return mv) `mplus` (do v <- MaybeT $ readTVar m re <- null' r if re then writeMbTVar m Nothing else writeMbTVar p Empty return (v,re)) `mplus` (do mv@(v,e) <- dmin' r when e $ writeMbTVar p Empty return mv) `mplus` error "emit nasal daemons" where readMbTVar x = lift $ readTVar x writeMbTVar x y = lift $ writeTVar x y empty m = liftM isNothing $ readMbTVar m null' p = lift $ null p