Commit bc438245 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

Factor out queue handling from splitBlock

This makes the interface easier to comprehend and write tests for.
There is now an extra function `addBlocksToQueue` that handles the
queue stuff.
parent 0a1855ae
{-# LANGUAGE BangPatterns #-}
module MA.Algorithm.Split
( SplitM
(
-- * Main interface
SplitM
, split
-- * Internal functions, exported only for testing
-- * Internal functions
-- | These are mainly exported for testing and benchmarking. Use 'split' or
-- even better: 'MA.Algorithm.refine'.
, collectTouchedBlocks
, updateBlock
, splitBlock
, addBlocksToQueue
) where
import Prelude hiding (pred)
......@@ -18,7 +26,7 @@ import Data.Maybe (maybeToList)
import Data.STRef
import System.IO.Unsafe (unsafeDupablePerformIO)
import Control.Monad.Extra (unlessM, whenM, ifM)
import Control.Monad.Extra (unlessM, whenM)
import Control.Monad.Reader
import Data.Tuple.Extra (snd3)
import qualified Data.Vector as V
......@@ -47,7 +55,7 @@ split blockS = do
forM_ touchedBlocks $ \(b, v0) -> do
updateBlock b v0
whenM (lift $ Partition.hasMarked (partition as) b) $
splitBlock b
splitBlock b >>= addBlocksToQueue b
-- | Update weights for all marked states in the given block @b@.
--
......@@ -85,9 +93,11 @@ updateBlock b v0 = ask >>= \(as, _) -> lift $ do
-- | Split block according to marked/unmarked status and saved H3s.
--
-- b must have at least one marked state
splitBlock :: RefinementInterface h => Block -> SplitM s h ()
splitBlock b = ask >>= \(as, queue) -> lift $ do
-- @b@ must have at least one marked state
--
-- Returns a list of new sub-blocks of @b@
splitBlock :: RefinementInterface h => Block -> SplitM s h [Block]
splitBlock b = ask >>= \(as, _) -> lift $ do
-- b has marked states, so b1 is guaranteed to be non-empty
(Just b1, bunmarked) <- Partition.splitMarked (partition as) b
......@@ -106,15 +116,32 @@ splitBlock b = ask >>= \(as, queue) -> lift $ do
(Just b1', b2) <- Partition.splitBy (partition as) b1
((==pmc) . unsafeH3)
blocks <- ((b1':maybeToList bunmarked) ++) <$> case b2 of
((b1':maybeToList bunmarked) ++) <$> case b2 of
Nothing -> return []
Just b2' -> Partition.groupBy (partition as) b2' unsafeH3
let enqueue = Queue.enqueue queue
ifM (b `Queue.elem` queue) (mapM_ enqueue blocks) $
deleteLargestM (Partition.blockSize (partition as)) (maybeAdd b blocks)
>>= mapM_ enqueue
-- | Add sub-blocks that were split off of a super-block to the queue.
--
-- If the original @b@ is already in the queue, we add all sub-blocks except the
-- one that shares its identity with @b@. If @b@ is not in the queue, we add all
-- blocks except a largest one.
--
-- Runtime: @O(|sub-blocks|)@
addBlocksToQueue
:: RefinementInterface h
=> Block -- ^ Original super-block
-> [Block] -- ^ List of split-off sub-blocks
-> SplitM s h ()
addBlocksToQueue b blocks = ask >>= \(as, queue) -> lift $ do
bInQueue <- Queue.elem b queue
blocks' <- if bInQueue
then return blocks
else deleteLargestM (Partition.blockSize (partition as)) (maybeAdd b blocks)
mapM_ (Queue.enqueue queue) blocks'
-- | Returns a list of blocks that have at least one predecessor state of the
-- given block @S@.
......
......@@ -157,19 +157,17 @@ splitBlockSpec = describe "splitBlock" $ do
$ let res = withState @Powerset (enc [True, False] [(0, (), 1)]) $ do
[(b, v0)] <- collectTouchedBlocks (Block 1)
updateBlock b v0
view _2 >>= lift . Queue.clear
lift . Queue.clear =<< view _2
splitBlock b
view _2 >>= lift . Queue.toList
in res `shouldBe` []
in res `shouldBe` [0]
it "splits blocks into marked and unmaked" $
let res = withState @Powerset (enc [True, True, False] [(0, (), 2), (1, (), 0)]) $ do
[(b, v0)] <- collectTouchedBlocks (Block 1)
updateBlock b v0
view _2 >>= lift . Queue.clear
lift . Queue.clear =<< view _2
splitBlock b
view _2 >>= lift . Queue.toList
in res `shouldBe` [Block 0]
in res `shouldMatchList` [Block 0, Block 2]
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment