diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,23 @@ +Copyright (c) 2020-2021 +Luis Pedro Coelho + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog diff --git a/Data/IntervalIntMap.hs b/Data/IntervalIntMap.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalIntMap.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Data.IntervalIntMap +#ifndef IS_BUILDING_TEST + ( IntervalIntMap +#else + ( IntervalIntMap(..) +#endif + , IntervalIntMapAccumulator + , IM.Interval(..) + , fromList + , elems + , new + , insert + , unsafeFreeze + , lookup + , map + , overlaps + , overlapsWithKeys + ) where + +import Prelude hiding (lookup, map) + +import qualified Data.IntervalIntMap.Internal.IntervalIntIntMap as IM +import qualified Data.IntervalIntMap.Internal.GrowableVector as GV +import qualified Data.Vector.Storable as VS +import qualified Data.IntSet as IS +import Foreign.Storable (Storable(..)) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Control.Monad (forM_) +import Control.Monad.ST (runST) +import Control.Arrow (second) +import Control.DeepSeq (NFData(..)) + + +{-| The typical interval map structure models a function of the type @ f :: Int + - -> Maybe a@. That is, each position in the domain is either annotated by an + - interval or it is not. When you attempt to insert an interval that overlaps + - with an existing one, the new value may either (1) replace or (2) by + - combined with the older one. + - + - This is **not** the model here. The model here is @f :: Int -> [a]@! An + - interval map is a bag of intervals which may overlap. When they do overlap + - and you query at a position where multiple ones could be active, you get all + - of them (in some reliable, but unspecified, order; currently insertion + - order, but this is not an API guarantee). + - + - The API uses two objects: + - + - 'IntervalIntMapAccumulator': allows insertion. This is a Mutable object and + - insertions should be in a `PrimMonad` + - + - 'IntervalIntMap': allows querying and operations are pure. + - + -} + + +data IntervalIntMap a = IntervalIntMap !IM.IntervalIntMap + !(VS.Vector a) + + +instance NFData (IntervalIntMap a) where + rnf (IntervalIntMap im v) = rnf im `seq` rnf v + +data IntervalIntMapAccumulator s a = IntervalIntMapAccumulator + !(GV.GrowableVector s (IM.IntervalValue)) + !(GV.GrowableVector s a) + + +-- |Create an 'IntervalIntMap' from a list of (key, value) +fromList :: Storable a => [(IM.Interval, a)] -> IntervalIntMap a +fromList vs = runST $ do + acc <- new + forM_ vs $ \(i,v) -> insert i v acc + unsafeFreeze acc + +elems :: Storable a => IntervalIntMap a -> [a] +elems (IntervalIntMap _ vals) = VS.toList vals + +-- |New (empty) accumulator +new :: (PrimMonad m, Storable a) => m (IntervalIntMapAccumulator (PrimState m) a) +new = IntervalIntMapAccumulator <$> GV.new <*> GV.new + + +-- |Insert a value into an accumulator +insert :: (PrimMonad m, Storable a) => IM.Interval -> a -> IntervalIntMapAccumulator (PrimState m) a -> m () +insert (IM.Interval s e) v (IntervalIntMapAccumulator ivs dat) = do + ix <- GV.length dat + GV.pushBack v dat + GV.pushBack (IM.IntervalValue (toEnum s) (toEnum e) (toEnum ix)) ivs + + +-- |Transform an 'IntervalIntMapAccumulator' into an 'IntervalIntMap'. This is +--unsafe as the accumulator should **not** be used after this operation is +--performed. +unsafeFreeze :: (PrimMonad m, Storable a) => IntervalIntMapAccumulator (PrimState m) a -> m (IntervalIntMap a) +unsafeFreeze (IntervalIntMapAccumulator ivs values) = + IntervalIntMap + <$> (IM.freeze <$> GV.unsafeFreeze ivs) + <*> GV.unsafeFreeze values + +indexAll :: Storable a => VS.Vector a -> IS.IntSet -> [a] +indexAll values = (fmap $ (VS.!) values) . IS.toList + +-- |Lookup all values whose keys intersect the given position +lookup :: Storable a => Int -> IntervalIntMap a -> [a] +lookup p (IntervalIntMap imap values) = indexAll values $ IM.lookup p imap + +-- |Map: note that both the input and output types must be instances of +-- Storable, so this is not a functor. +map :: (Storable a, Storable b) => (a -> b) -> IntervalIntMap a -> IntervalIntMap b +map f (IntervalIntMap im vs) = IntervalIntMap im (VS.map f vs) + +-- |Lookup all values that overlap with the given input +overlaps :: Storable a => IM.Interval -> IntervalIntMap a -> [a] +overlaps i = fmap snd . overlapsWithKeys i + +-- |Lookup all values that overlap with the given input +overlapsWithKeys :: Storable a => IM.Interval -> IntervalIntMap a -> [(IM.Interval,a)] +overlapsWithKeys i (IntervalIntMap imap values) = fmap (second $ (VS.!) values) $ IM.overlapsWithKeys i imap + diff --git a/Data/IntervalIntMap/Internal/GrowableVector.hs b/Data/IntervalIntMap/Internal/GrowableVector.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalIntMap/Internal/GrowableVector.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Data.IntervalIntMap.Internal.GrowableVector + ( GrowableVector + , GrowableVectorData(..) + , new + , pushBack + , unsafeFreeze + , length + ) where + +import Prelude hiding (length) + +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Foreign.Storable (Storable(..)) +import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Primitive.MutVar (MutVar, newMutVar, readMutVar, writeMutVar) + +{--| This is a growable vector (i.e., one that includes the 'pushBack' + - function) which must exist in a 'PrimMonad'. It only supports Storable data + - items. + -} + + +type GrowableVector s a = MutVar s (GrowableVectorData s a) + +data GrowableVectorData s a = GrowableVectorData !Int !(VSM.MVector s a) + +-- | Empty vector +new :: (PrimMonad m, Storable a) => m (GrowableVector (PrimState m) a) +new = do + vd <- GrowableVectorData 0 <$> VSM.unsafeNew 16 + newMutVar vd + +-- | Insert an element at the end of the vector +pushBack :: (PrimMonad m, Storable a) => a -> GrowableVector (PrimState m) a -> m () +pushBack val gv = + readMutVar gv >>= pushBack' val >>= writeMutVar gv + +pushBack' :: (PrimMonad m, Storable a) => a -> GrowableVectorData (PrimState m) a -> m (GrowableVectorData (PrimState m) a) +pushBack' val (GrowableVectorData used vec) + | used == VSM.length vec = do + vec' <- VSM.grow vec (VSM.length vec `div` 2) -- multiplying by 1.5 is close to optimal + pushBack' val (GrowableVectorData used vec') + | otherwise = do + VSM.write vec used val + return $! GrowableVectorData (used+1) vec + +-- | This operation is unsafe as original vector should not be used again! +unsafeFreeze :: (PrimMonad m, Storable a) => GrowableVector (PrimState m) a -> m (VS.Vector a) +unsafeFreeze gv = do + GrowableVectorData used vec <- readMutVar gv + VS.take used <$> VS.unsafeFreeze vec + +-- | Return the current number of stored elements +length :: (PrimMonad m, Storable a) => GrowableVector (PrimState m) a -> m Int +length gv = do + GrowableVectorData len _ <- readMutVar gv + return len diff --git a/Data/IntervalIntMap/Internal/IntervalIntIntMap.hs b/Data/IntervalIntMap/Internal/IntervalIntIntMap.hs new file mode 100644 --- /dev/null +++ b/Data/IntervalIntMap/Internal/IntervalIntIntMap.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE FlexibleContexts, TypeApplications #-} + +module Data.IntervalIntMap.Internal.IntervalIntIntMap + ( IntervalValue(..) + , Interval(..) + , IntervalIntMap + , naiveIntervalMapLookup + , lookup + , overlaps + , overlapsWithKeys + , naiveOverlaps + , naiveOverlapsWithKeys + , NaiveIntervalInt + , intervalContains + , partition + , freeze +#ifdef IS_BUILDING_TEST + , mkTree +#endif + ) where +import Prelude hiding (lookup) + +import qualified Data.IntervalIntMap.Internal.GrowableVector as GV + +import qualified Foreign.Storable as FS +import Foreign.Ptr (castPtr, plusPtr) +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.Vector.Storable as VS +import Control.Monad.ST (runST) +import Data.Word (Word32) +import Data.Ord (comparing) +import Data.Vector.Algorithms.Tim (sortBy) +import Control.DeepSeq (NFData(..)) + + +{- DATA STRUCTURE + - + - An IntervalValue contains the interval [ivStart, ivPast) and the value. This + - is a closed-open interval, so represents `x` such that `ivStart <= x < + - ivPast`. + - + - The simplest map is the NaiveIntervalInt, which is just a vector. It is very + - memory efficient, but needs O(N) to search. However, for small N, it is + - likely very efficient and we can use this "structure" for testing too. + - + - The Tree is very simple: At each node, there is a split value and intervals + - are completely below it, completely above it, or contain the point. + - + - + - Leafs contain NaiveIntervalInt + -} + + +data Interval = Interval !Int !Int +#ifdef IS_BUILDING_TEST + deriving (Eq, Show) +#endif + +data IntervalValue = IntervalValue + { ivStart :: !Word32 + , ivPast :: !Word32 + , ivValue :: !Word32 + } +#ifdef IS_BUILDING_TEST + deriving (Show) +#endif + +instance Eq IntervalValue where + (IntervalValue s0 e0 ix0) == (IntervalValue s1 e1 ix1) = + s0 == s1 && e0 == e1 && ix0 == ix1 + +-- This is necessary to build sets of 'IntervalValue's (e.g., in 'naiveOverlapsWithKeys') +instance Ord IntervalValue where + (IntervalValue s0 e0 ix0) `compare` (IntervalValue s1 e1 ix1) + | s0 /= s1 = s0 `compare` s1 + | e0 /= e1 = e0 `compare` e1 + | otherwise = ix0 `compare` ix1 + +instance FS.Storable IntervalValue where + sizeOf _ = 3 * 4 -- aka 12 + alignment x = FS.alignment (ivStart x) + peek p = IntervalValue + <$> FS.peek (castPtr p) + <*> FS.peek (castPtr p `plusPtr` 4) + <*> FS.peek (castPtr p `plusPtr` 8) + poke ptr (IntervalValue s p v) = do + let ptr' = castPtr ptr + FS.pokeElemOff @Word32 ptr' 0 s + FS.pokeElemOff @Word32 ptr' 1 p + FS.pokeElemOff @Word32 ptr' 2 v + +intervalContains :: Int -> IntervalValue -> Bool +intervalContains p (IntervalValue s e _) = + let p' = toEnum p + in s <= p' && p' < e + +type NaiveIntervalInt = VS.Vector IntervalValue + +data IntervalIntMapNode = Leaf NaiveIntervalInt + | InnerNode + { _nodeSplitValue :: !Int + , _leftSplit :: !IntervalIntMapNode + , _centerSplit :: !IntervalIntMapNode + , _rightSplit :: !IntervalIntMapNode + } +#ifdef IS_BUILDING_TEST + deriving (Show) +#endif + +instance NFData IntervalIntMapNode where + rnf (Leaf v) = rnf v + rnf (InnerNode !_ left center right) = rnf left `seq` rnf center `seq` rnf right + +newtype IntervalIntMap = IntervalIntMap { _imapRoot :: IntervalIntMapNode } +#ifdef IS_BUILDING_TEST + deriving (Show) +#endif + +instance NFData IntervalIntMap where + rnf (IntervalIntMap !n) = rnf n + +partition :: Int -> NaiveIntervalInt -> (NaiveIntervalInt, NaiveIntervalInt, NaiveIntervalInt) +partition p vec = runST $ do + left <- GV.new + center <- GV.new + right <- GV.new + VS.forM_ vec $ \val -> + let target + | ivPast val <= toEnum p = left + | ivStart val > toEnum p = right + | otherwise = center + in GV.pushBack val target + (,,) + <$> GV.unsafeFreeze left + <*> GV.unsafeFreeze center + <*> GV.unsafeFreeze right + + +sortedByEnd :: NaiveIntervalInt -> NaiveIntervalInt +sortedByEnd vec = VS.create $ do + vec' <- VS.thaw vec + sortBy (comparing ivPast) vec' + return vec' + +{-| + Turn a 'NaiveIntervalInt' into an 'IntervalIntMap' +-} +freeze :: NaiveIntervalInt -> IntervalIntMap +freeze = mkTree 16 + +mkTree :: Int -> NaiveIntervalInt -> IntervalIntMap +mkTree maxSplit vec = IntervalIntMap $ mkTree' 0 maxSplit (sortedByEnd vec) + +maxSplitIters :: Int +maxSplitIters = 8 + +mkTree' nIters maxSplit vec + | VS.length vec <= maxSplit = Leaf vec + | nIters > maxSplitIters = Leaf vec + | otherwise = trySplit nIters maxSplit vec + +trySplit nIters maxSplit vec = InnerNode (fromEnum p) (r left) (r center) (r right) + where + r = mkTree' nIters' maxSplit + (left, center, right) = partition (fromEnum p) vec + nIters' + | successful = 0 + | otherwise = nIters + 1 + + -- The criterion for calling it a successful split is a bit random, but seems to work: + -- If after splitting the largest component is at least maxSplit + -- smaller than the input, that was a successful split + successful = VS.length vec - maximum (map VS.length [left, center, right]) >= maxSplit + + -- Choosing a pivot will probably have a big impact on the performance. + -- We pick the median end-point one, which is probably a decent heuristic + p = ivPast $ (VS.!) vec (VS.length vec `div` 2) + +lookup :: Int -> IntervalIntMap -> IS.IntSet +lookup x (IntervalIntMap root) = lookup' root + where + + lookup' (Leaf vec) = naiveIntervalMapLookup x vec + lookup' (InnerNode p left center right) + | x < p = lookup' left `IS.union` lookup' center + | x == p = lookup' center + | otherwise = lookup' center `IS.union` lookup' right + +naiveIntervalMapLookup :: Int -> NaiveIntervalInt -> IS.IntSet +naiveIntervalMapLookup x = IS.fromList . VS.toList . VS.map (fromEnum . ivValue) . VS.filter (intervalContains x) + +naiveOverlaps :: Interval -> NaiveIntervalInt -> IS.IntSet +naiveOverlaps i = IS.fromList . map snd . naiveOverlapsWithKeys i + +naiveOverlapsWithKeys :: Interval -> NaiveIntervalInt -> [(Interval, Int)] +naiveOverlapsWithKeys i = map asPair . S.toList . naiveOverlapsWithKeys' i + +asPair (IntervalValue s e ix) = (Interval (fromEnum s) (fromEnum e), fromEnum ix) + +naiveOverlapsWithKeys' :: Interval -> NaiveIntervalInt -> S.Set IntervalValue +naiveOverlapsWithKeys' (Interval s0 e0) = S.fromList . VS.toList . VS.filter overlap1 + where + overlap1 (IntervalValue s1' e1' _) + | s0 == e0 = False + | s1' == e1' = False + | otherwise = + let + s1 = fromEnum s1' + e1 = fromEnum e1' + in (s0 <= s1 && s1 < e0) || (s1 <= s0 && s0 < e1) + +overlaps :: Interval -> IntervalIntMap -> IS.IntSet +overlaps i (IntervalIntMap root) = overlaps' i root + +overlaps' i (Leaf vec) = naiveOverlaps i vec +overlaps' i (InnerNode p left centre right) + | i `intervalAbove` p = overlaps' i right `IS.union` overlaps' i centre + | i `intervalBelow` p = overlaps' i left `IS.union` overlaps' i centre + | otherwise = overlaps' i left `IS.union` overlaps' i centre `IS.union` overlaps' i right + +overlapsWithKeys :: Interval -> IntervalIntMap -> [(Interval, Int)] +overlapsWithKeys i (IntervalIntMap root) = map asPair . S.toList $ overlapsWithKeys' i root + +overlapsWithKeys' :: Interval -> IntervalIntMapNode -> S.Set IntervalValue +overlapsWithKeys' i (Leaf vec) = naiveOverlapsWithKeys' i vec +overlapsWithKeys' i (InnerNode p left centre right) + | i `intervalAbove` p = overlapsWithKeys' i right `S.union` overlapsWithKeys' i centre + | i `intervalBelow` p = overlapsWithKeys' i left `S.union` overlapsWithKeys' i centre + | otherwise = overlapsWithKeys' i left `S.union` overlapsWithKeys' i centre `S.union` overlapsWithKeys' i right + +intervalAbove (Interval s _) p = s > p +intervalBelow (Interval _ e) p = e <= p + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,63 @@ +# IntervalIntMap + +An interval map structure that is optimized for low memory (each interval is +represented by about 3 words + whatever the cargo is) and has semantics that +are appropriate for genomic intervals (namely, intervals can overlap and +queries will return **all** matches together). It also designed to be used in +two phases: a construction phase + query phase). + +This is not a general purpose package, it serves mostly as support for +[NGLess](https://ngless.embl.de) and is used there. + +Do get [in touch](mailto:luis@luispedro.org) if you want to use it more +generally, but the plans for this repo is to develop it only in so far as it +helps with NGLess' goals. + +## Example Usage + +### Step 1: construction + +In the first phase, an `IntervalIntMapAccumulator` accumulator is used. This is +a mutable object and it must be used inside a `PrimMonad` (typically either +`IO` or `ST s`). Elements can be inserted into this object. + +```haskell +import qualified Data.IntervalIntMap as IM + +insertMany :: [(Int, Int)] -> IO (IM.IntervalIntMap Int) +insertMany elems = do + acc <- IM.new + forM_ (zip elems [0..]) $ \((s,p), ix) -> + IM.insert (IM.Interval s p) ix + IM.unsafeFreeze acc +``` + +The final step in _construction_ is freezing the accumulator to produce a +`IntervalIntMap`. If the original accumulator is not to be used again, then +`unsafeFreeze` can be used. + +### Step 2: usage + +The `IntervalIntMap` object is a pure object, with the typical container +functions: `map`, `lookup`, `elems`,... + +Do note that the signature for `lookup` is + +```haskell +lookup :: Storable a => Int -> IntervalIntMap a -> [a] +``` + +Thus, a list is always returned: `[]` if nothing is found, but multiple +intervals can independently overlap with the query. + +## Citation + +If you do use this repository, please cite the main [NGLess](https://ngless.embl.de) paper: + +> _NG-meta-profiler: fast processing of metagenomes using NGLess, a +> domain-specific language_ by Luis Pedro Coelho, Renato Alves, Paulo Monteiro, +> Jaime Huerta-Cepas, Ana Teresa Freitas, Peer Bork, Microbiome (2019) +> [https://doi.org/10.1186/s40168-019-0684-8](https://doi.org/10.1186/s40168-019-0684-8) + +LICENSE: MIT + diff --git a/int-interval-map.cabal b/int-interval-map.cabal new file mode 100644 --- /dev/null +++ b/int-interval-map.cabal @@ -0,0 +1,87 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a6fd4a2bc6feee2444e88bd5e1d7922a8a860bdf846ee75842b6d97fd876b9a9 + +name: int-interval-map +version: 0.0.1.0 +synopsis: Interval map +description: Interval map with support for overlapping intervals +category: Data +homepage: https://github.com/ngless-toolkit/interval-to-int#readme +bug-reports: https://github.com/ngless-toolkit/interval-to-int/issues +author: Luis Pedro Coelho +maintainer: luis@luispedro.org +license: MIT +license-file: COPYING +build-type: Simple +extra-source-files: + README.md + ChangeLog + +source-repository head + type: git + location: https://github.com/ngless-toolkit/interval-to-int + +library + exposed-modules: + Data.IntervalIntMap + other-modules: + Data.IntervalIntMap.Internal.GrowableVector + Data.IntervalIntMap.Internal.IntervalIntIntMap + hs-source-dirs: + ./ + default-extensions: + BangPatterns + OverloadedStrings + LambdaCase + TupleSections + CPP + ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 + build-depends: + base >=4.12 && <4.16 + , containers + , deepseq + , either + , primitive + , vector + , vector-algorithms + default-language: Haskell2010 + +test-suite interval-int-map-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + other-modules: + Data.IntervalIntMap + Data.IntervalIntMap.Internal.GrowableVector + Data.IntervalIntMap.Internal.IntervalIntIntMap + Paths_int_interval_map + hs-source-dirs: + ./ + ./tests + default-extensions: + BangPatterns + OverloadedStrings + LambdaCase + TupleSections + CPP + ghc-options: -Wall -Wcompat -fwarn-tabs -fno-warn-missing-signatures -O2 + cpp-options: -DIS_BUILDING_TEST + build-depends: + base >=4.12 && <4.16 + , containers + , deepseq + , either + , hedgehog + , primitive + , tasty + , tasty-hedgehog + , tasty-hunit + , tasty-quickcheck + , tasty-th + , vector + , vector-algorithms + default-language: Haskell2010 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,124 @@ +{- Copyright 2020 Luis Pedro Coelho + - License: MIT + -} +{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleContexts #-} +module Main where + +import Test.Tasty.HUnit +import Test.Tasty.TH (defaultMainGenerator) +import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty.Hedgehog + + + +import qualified Data.Vector.Storable as VS +import qualified Data.IntervalIntMap as IMA +import qualified Data.IntervalIntMap.Internal.IntervalIntIntMap as IM +import qualified Data.IntervalIntMap.Internal.GrowableVector as GV +import Data.Foldable (forM_, for_) +import qualified Data.IntSet as IS + + +tData = + [ IM.IntervalValue 0 2 0 + , IM.IntervalValue 0 2 1 + , IM.IntervalValue 1 2 2 + , IM.IntervalValue 3 6 3 + , IM.IntervalValue 3 4 4 + , IM.IntervalValue 1 4 5 + , IM.IntervalValue 4 7 6 + , IM.IntervalValue 4 6 7 + , IM.IntervalValue 8 10 8 + , IM.IntervalValue 1 12 9 + ] + +tDataN :: IM.NaiveIntervalInt +tDataN = VS.fromList tData + +below x (IM.IntervalValue _ e _) = x >= e +above x (IM.IntervalValue s _ _) = x < s + +case_partition = + for_ [0..14] $ \split -> do + let (left,center,right) = IM.partition split tDataN + all (below $ toEnum split) (VS.toList left) @? "Center does not include split" + all (IM.intervalContains $ toEnum split) (VS.toList center) @? "Left is not below split" + all (above $ toEnum split) (VS.toList right) @? "Right is not above split" + VS.length left + VS.length center + VS.length right @=? VS.length tDataN + +case_small_build_tree_find = do + let t = IM.mkTree 4 tDataN + for_ [0..14] $ \x -> + IM.lookup x t @=? IM.naiveIntervalMapLookup x tDataN + +genSimpleInterval space = do + s <- Gen.integral (Range.linear 0 space) + len <- Gen.integral (Range.linear 0 space) + return (s, s + len) + +prop_build_tree_find = H.property $ do + -- the smaller values will generate more crowded inputs + space <- H.forAll $ Gen.integral (Range.linear 100 2000) + intervals <- H.forAll $ Gen.list (Range.linear 0 2000) $ genSimpleInterval space + ps <- H.forAll $ Gen.list (Range.linear 0 5) $ Gen.integral $ Range.linear 0 10000 + H.classify "empty" $ length intervals == 0 + H.classify "small (N< 100)" $ length intervals < 100 + H.classify "large (N>=100)" $ length intervals >= 100 + let naive = VS.fromList [IM.IntervalValue s e ix | ((s,e),ix) <- zip intervals [0..]] + t = IM.mkTree 16 naive + for_ ps $ \p -> + IM.lookup p t H.=== IM.naiveIntervalMapLookup p naive + + + +prop_naive_overlaps1 = H.property $ do + (s,e) <- H.forAll $ genSimpleInterval 100 + (s',e') <- H.forAll $ genSimpleInterval 100 + let naive = VS.fromList [IM.IntervalValue (toEnum s) (toEnum e) 0] + i = IM.Interval s' e' + doesOverlap + | s >= e = False + | otherwise = any (\c -> s' <= c && c < e') [s..(e-1)] + H.classify "empty interval" $ s == e || s' == e' + H.classify "overlaps" $ doesOverlap + H.classify "no overlap" $ not doesOverlap + (not . IS.null $ IM.naiveOverlaps i naive) H.=== doesOverlap + +prop_growable_vector = H.property $ do + values <- H.forAll $ Gen.list (Range.linear 0 1000) $ Gen.integral (Range.linear 0 1000) + let direct = VS.fromList (values :: [Int]) + built <- do + gv <- GV.new + forM_ values (`GV.pushBack` gv) + GV.unsafeFreeze gv + direct H.=== built + +case_simple_ima = do + acc <- IMA.new + IMA.insert (IMA.Interval 2 4) (7 :: Int) acc + IMA.insert (IMA.Interval 3 6) (8 :: Int) acc + im <- IMA.unsafeFreeze acc + IMA.lookup 1 im @=? [] + IMA.lookup 2 im @=? [7] + IS.fromList (IMA.lookup 3 im) @=? IS.fromList [7,8] + IMA.lookup 4 im @=? [8] + (length $ IMA.overlaps (IMA.Interval 2 5) im) @=? 2 + (length $ IMA.overlapsWithKeys (IMA.Interval 2 5) im) @=? 2 + + (length $ IMA.overlaps (IMA.Interval 4 5) im) @=? 1 + (length $ IMA.overlapsWithKeys (IMA.Interval 4 5) im) @=? 1 + + (length $ IMA.overlaps (IMA.Interval 4 9) im) @=? 1 + (length $ IMA.overlapsWithKeys (IMA.Interval 4 9) im) @=? 1 + +case_fromList = do + let im = IMA.fromList [(IMA.Interval (fromEnum s) (fromEnum e), v) | (IM.IntervalValue s e v) <- tData] + IMA.overlapsWithKeys (IM.Interval 11 15) im @?= [(IM.Interval 1 12, 9)] + + +main :: IO () +main = $(defaultMainGenerator) + +