diff --git a/src/Algorithm.hs b/src/Algorithm.hs index f920535258036988ee59619ed7e1530cb0bdc23f..48aca6732dddd864e1ab9a53175aa9de773cb6fa 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -139,12 +139,11 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do Just b2' -> Partition.groupBy (partition as) b2' (unsafeDupablePerformIO . unsafeSTToIO . VM.read (h3Cache as)) - let s = sort as - enqueueSorted = Queue.enqueue queue . (s,) + let enqueue = Queue.enqueue queue - ifM ((s,b) `Queue.elem` queue) (mapM_ enqueueSorted blocks) $ + ifM (b `Queue.elem` queue) (mapM_ enqueue blocks) $ deleteLargest (Partition.blockSize (partition as)) (maybeAdd b blocks) - >>= mapM_ enqueueSorted + >>= mapM_ enqueue -- | Remove one largest element from the list -- @@ -186,7 +185,7 @@ processQueue :: RefinementInterface h => BlockQueue s -> AlgoState s h -> ST s processQueue queue as = whileM $ Queue.dequeue queue >>= \case Nothing -> return False - Just (_, block) -> do + Just block -> do states <- Partition.statesOfBlock (partition as) block runReaderT (split states) (as, queue) return True @@ -196,9 +195,9 @@ refine encoding = do -- FIXME: This is a hack: We use only a single sort of the queue. Once the -- algorithm is replaced with the desorted variant, change the queue -- implementation to only support one sort. - queue <- Queue.empty (V.singleton (size encoding)) + queue <- Queue.empty (size encoding) (blocks, state) <- initialize @f 0 encoding (size encoding) - mapM_ (Queue.enqueue queue . (0,)) blocks + mapM_ (Queue.enqueue queue) blocks processQueue queue state diff --git a/src/Data/BlockQueue.hs b/src/Data/BlockQueue.hs index 924b6913138a0bc1e2b494f6898bffffe0845639..a60ed886123c8e7c88d590c17ddb9bcdb68bdc24 100644 --- a/src/Data/BlockQueue.hs +++ b/src/Data/BlockQueue.hs @@ -2,9 +2,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} --- | A queue for sorted blocks that can be used in the lumping algorithm. +-- | A queue for blocks that can be used in the lumping algorithm. -- --- Each sorted block can only be present once in the queue. +-- Each block can only be present once in the queue. -- -- Has O(1) operations for everything including membership test, which is -- required by the algorithm mentioned above. @@ -20,43 +20,38 @@ module Data.BlockQueue import Prelude hiding (null, elem) import Control.Monad.ST -import Control.Monad (forM) import Data.Primitive.MutVar import Data.Sequence (Seq) import qualified Data.Sequence as Seq import qualified Data.Vector.Unboxed.Mutable as UnboxedV -import qualified Data.Vector as V import Lens.Micro import Lens.Micro.TH import Lens.Micro.Platform () import Control.Monad.Extra (unlessM) import Data.RefinablePartition (Block(..)) -import Data.Sort (Sorted) --- | A mutable fifo queue specialized for sorted blocks +-- | A mutable fifo queue specialized for blocks data BlockQueue s = Q - { _queue :: MutVar s (Seq (Sorted Block)) + { _queue :: MutVar s (Seq Block) -- This vector has one entry for each sort - , _presence :: V.Vector (UnboxedV.MVector s Bool) + , _presence :: UnboxedV.MVector s Bool } makeLenses ''BlockQueue -- | Create an empty queue -- --- `@empty vec@` creates an empty queue for blocks from `@length vec@` sorts, --- where the maximum block id that will be inserted per sort (probably the --- number of states) is given in `@vec[sort]@`. +-- `@empty max@` creates an empty queue where the maximum block id that will be inserted (probably the +-- number of states) is given in `@max@`. -- -- Runtime: O(total number of possible blocks) -empty :: V.Vector Int -- ^ The maximum block id that will be added for each sort +empty :: Int -- ^ The maximum block id that will be added -> ST s (BlockQueue s) -empty sortSizes = do +empty maxSize = do q <- newMutVar Seq.empty - p <- forM sortSizes $ \maxSize -> - UnboxedV.replicate maxSize False + p <- UnboxedV.replicate maxSize False return $ Q q p -- | Check if this queue is empty @@ -68,26 +63,26 @@ null q = Seq.null <$> readMutVar (q^.queue) -- | Add an element to the end of the queue if it isn't already present. -- -- Runtime: O(1) -enqueue :: BlockQueue s -> Sorted Block -> ST s () -enqueue q (sort, block) = unlessM (elem (sort,block) q) $ do - modifyMutVar (q^.queue) $ \s -> s Seq.|> (sort, block) - UnboxedV.write (q^?!presence.ix sort) (fromBlock block) True +enqueue :: BlockQueue s -> Block -> ST s () +enqueue q block = unlessM (elem block q) $ do + modifyMutVar (q^.queue) $ \s -> s Seq.|> block + UnboxedV.write (q^.presence) (fromBlock block) True -- | Read and delete the first element in the queue -- -- Returns 'Nothing' and doesn't modify the queue if it was empty. -- -- Runtime: O(1) -dequeue :: BlockQueue s -> ST s (Maybe (Sorted Block)) +dequeue :: BlockQueue s -> ST s (Maybe Block) dequeue q = Seq.viewl <$> readMutVar (q^.queue) >>= \case Seq.EmptyL -> return Nothing - ((sort,x) Seq.:< rest) -> do - UnboxedV.write (q^?!presence.ix sort) (fromBlock x) False + (x Seq.:< rest) -> do + UnboxedV.write (q^.presence) (fromBlock x) False writeMutVar (q^.queue) rest - return (Just (sort, x)) + return (Just x) -- | Tests whether an element is in the queue -- -- Runtime: O(1) -elem :: Sorted Block -> BlockQueue s -> ST s Bool -elem (!sort, Block block) !q = UnboxedV.read (q^?!presence.ix sort) block +elem :: Block -> BlockQueue s -> ST s Bool +elem (Block block) !q = UnboxedV.read (q^.presence) block