diff --git a/HiggsSet.cabal b/HiggsSet.cabal new file mode 100644 --- /dev/null +++ b/HiggsSet.cabal @@ -0,0 +1,91 @@ +-- HiggsSet.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: HiggsSet + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: A multi-index set with advanced query capabilites + +-- A longer description of the package. +Description: This package allows you to define several typesafe + indizes on a set. You can query the set with an SQL-like + set of query operations. + This package was developed as a successor of 'Data.IxSet'. + It is meant to be more space efficient, since it uses + 'Data.IntSet' and 'Data.TrieMap' as an underlying represenation. + It also has the potential to be fast, since indizes don't + need to be recalculated after each query and since + Patricia trees perform quite well for intersection and union. + + This package comes without warranties. Although I use it + without problems in a large web project it is neither properly + tested nor benchmarked. + + Patches or suggestions for improvement are welcome. If you like, + start an issue on github. + +-- URL for the project homepage or repository. +Homepage: github.com/lpeterse/HiggsSet + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Lars Petersen + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: info@lars-petersen.net + +-- A copyright notice. +-- Copyright: + +Category: Data + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.6 + + +Library + -- Modules exported by the library. + --ghc-options: -O2 + hs-source-dirs: src + Exposed-modules: Data.HiggsSet + Build-depends: base >= 4.2 && < 6 + , vector + , TrieMap >= 4.0.1 + , containers + , mtl + , deepseq + , bytestring + , text + + + -- Packages needed in order to build this package. + -- Build-depends: + + -- Modules not exported by this package. + -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + +source-repository head + type: git + location: git://github.com/lpeterse/HiggsSet.git + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Lars Petersen + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Lars Petersen nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/HiggsSet.hs b/src/Data/HiggsSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/HiggsSet.hs @@ -0,0 +1,666 @@ +{-# OPTIONS -XFlexibleInstances -XUndecidableInstances -XTupleSections #-} +{-# LANGUAGE TemplateHaskell, ExistentialQuantification, TypeFamilies, ScopedTypeVariables, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.HiggsSet +-- Copyright : (c) Lars Petersen 2011 +-- License : BSD-style +-- Maintainer : info@lars-petersen.net +-- +-- Since many function names clash with +-- "Prelude" names, this module is usually imported @qualified@, e.g. +-- +-- > import qualified Data.HiggsSet as HS +-- +-- Throughout this documentation we'll assume that we want work on a set +-- of the following example type and its index: +-- +-- > data Book = Book +-- > { isbn :: ISBN +-- > , authors :: Set String +-- > , publisher :: String +-- > , year :: Word +-- > , price :: (Rational, Currency) +-- > , title :: String +-- > } +-- > +-- > data BookIndex = IIsbn ISBN +-- > | IAuthor String +-- > | IPriceInEuro Rational +-- > | IPublisherAndYear String Word +-- > | INewerThan2000 +-- > | ITitle String +-- +----------------------------------------------------------------------------- +module Data.HiggsSet + ( -- * Set Type + HiggsSet () + -- * Classes + , Indexable (..) + , Index (..) + -- * General information + , size + -- * Construction + , empty + , insert + , delete + , update + , updateUnsafe + -- * Lookup + , lookup + , updateLookup + , updateLookupUnsafe + -- * Query + , nothing + , everything + , equals + , greater + , greaterEq + , lower + , lowerEq + , range + , union + , intersection + -- * Query Application + , querySize + , querySet + , queryList + , groupOver + -- * Conversion to/from List + , toList + , fromList + -- * Auxillary Types + , Property (..) + , Order (..) + , Margin (..) + , HiggsQuery () + , Selection () + ) where + + +import Prelude hiding (lookup) + +import GHC.Exts (build) + +import Control.DeepSeq +import Data.TrieMap.Representation + +import Data.Maybe +import Data.List hiding (insert, null, lookup, delete, union) + +import Control.Applicative hiding (empty) +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader + +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.Map as M +import qualified Data.IntMap as IM +import qualified Data.TrieMap as TM +import qualified Data.Vector as V + +import Data.Function (on) + +data IndexMap i = SingletonMap { unSingletonMap :: !(TM.TMap i Int) } + | MultiMap { unMultiMap :: !(TM.TMap i IS.IntSet) } + +data HiggsSet a i = HiggsSet + { elements :: !(IM.IntMap a) + , maxKey :: !Int + , indizes :: !(V.Vector (IndexMap i)) + } + +-- | Don't rely on this. I just had no time to hide the plumbing, yet. +type HiggsQuery e i a = Reader (HiggsSet e i) a + +-- | The type to be indexed needs to be an instance of `Indexable`. +-- Furthermore you have to specify an associated type +-- as index and how the type maps to the index. +-- +-- > instance Indexable Book where +-- > type IndexOf Book = BookIndex +-- > project (IIsbn _) x = [isbn x] +-- > project (IAuthor _) x = map IAuthor (toList $ authors x) +-- > project (IPriceInEuro _) x = [priceInEuro (price x)] +-- > project (IPublisherAndYear _ _) x = [IPublisherAndYear (publisher x) (year x)] +-- > project (INewerThan2000 _) x = [INewerThan2000 | year x >= 2000] +-- > project (ITitle _) x = map ITitle $ words $ title x +class Indexable a where + type IndexOf a + project :: IndexOf a -> a -> [IndexOf a] + +-- | The associated index type needs to be an instance of `Index`. +-- First of all this means that it needs to be an instance of +-- the context classes, whereas we exploit them a bit. +-- Specifying properties of the indizes is optional, but might result +-- in better time/space efficiency. +-- +-- See the example: +-- +-- > instance Bounded BookIndex where +-- > minBound = IIsbn undefined +-- > maxBound = ITitle undefined +-- > +-- > instance Enum BookIndex where +-- > fromEnum (IIsbn _) = 0 +-- > fromEnum (IAuthor _) = 1 +-- > fromEnum (IPriceInEuro _) = 2 +-- > fromEnum (IPublisherAndYear _ _) = 3 +-- > fromEnum (INewerThan2000 _) = 4 +-- > fromEnum (ITitle _) = 5 +-- > toEnum 0 = (IIsbn undefined) +-- > toEnum 1 = (IAuthor undefined) +-- > toEnum 2 = (IPriceInEuro undefined) +-- > toEnum 3 = (IPublisherAndYear undefined undefined) +-- > toEnum 4 = (INewerThan2000 undefined) +-- > toEnum 5 = (ITitle undefined) +-- > +-- > -- You may use the template haskell capabilites of TrieMap! +-- > instance TrieMap.Repr BookIndex where +-- > type Rep BookIndex = Either (ISBN) +-- > (Either (String) +-- > (Either (Rational) +-- > (Either (String, Word) +-- > (Either () +-- > (Either (String) +-- > () +-- > ) ) ) ) ) +-- > toRep (IIsbn a) = Left (toRep a) +-- > toRep (IAuthor a) = Right $ Left (toRep a) +-- > toRep (IPriceInEuro a) = Right $ Right $ Left (toRep a) +-- > toRep (IPublisherAndYear a b) = Right $ Right $ Right $ Left $ toRep (a,b) +-- > toRep (INewerThan2000) = Right $ Right $ Right $ Right $ Left () +-- > toRep (ITitle a) = Right $ Right $ Right $ Right $ Right $ Left (toRep a) +-- > +-- > instance Index BookIndex where +-- > property (IIsbn _) = Bijective +-- > property _ = NothingSpecial +class (TM.TKey a, Ord a, Bounded a, Enum a) => Index a where + property :: a -> Property + property = const NothingSpecial + +index :: (Index i) => i -> HiggsSet a i -> IndexMap i +index i s = (indizes s) V.! (fromEnum i) + +data Property = Bijective + | Injective + | Surjective + | NothingSpecial + +data Order = Ascending + | Descending + +data Margin a = -- | The wrapped element is not included + Open a + -- | The wrapped element is included + | Closed a + -- | The wrapped element just serves as a proxy. It is safe to use 'undefined'. + | Infinite a + +unMargin (Open a) = a +unMargin (Closed a) = a +unMargin (Infinite a) = a + +-- | Try to avoid explicit usage of the type 'Selection' in your code. It might disappear soon. +data Selection k = Nothing' + | Singleton !Int + | Set !IS.IntSet + | Everything + | Range (Margin k) (Margin k) + | Union (Selection k) (Selection k) + | Intersection (Selection k) (Selection k) + +-- | An empty 'HiggsSet' with empty indizes. +empty :: forall a i.(Indexable a, Index i, IndexOf a ~ i) => HiggsSet a i +empty = HiggsSet + { elements = IM.empty + , maxKey = minBound + , indizes = V.fromList + [case property i of + Bijective -> SingletonMap TM.empty + Injective -> SingletonMap TM.empty + _ -> MultiMap TM.empty + | i <- [minBound..maxBound] :: [i] + ] + } + +-- | /O(n)/ Count the elements within the set. Note that a 'HiggsSet' may contain elements equal according to 'Eq' more than once. +size :: HiggsSet a i -> Int +size = IM.size . elements + +----------------- + +-- | Insert an element to an 'HiggsSet'. Indexing takes place according to the class instances defined before. It is not checked whether such an element (according to 'Eq') already exists. If so, the set contains more than once afterwards. In such a case you may rather want to use 'update'. +insert :: forall a i.(Indexable a, Index i, IndexOf a ~ i) => a -> HiggsSet a i -> HiggsSet a i +insert a s = s { elements = IM.insert key a (elements s) + , maxKey = key + , indizes = V.accum + (foldl' + (\x y-> case x of + SingletonMap m -> SingletonMap $ TM.insert y key m + MultiMap m -> MultiMap $ TM.insertWith + -- unite with elements already existing at index position + IS.union + -- the index position "where" + y + -- the new elements' key is the value of the index map + (IS.singleton key) + -- the index (TMap i IntSet) + m + ) + ) + (indizes s) -- the vector + [(fromEnum x, project x a) | x <- [minBound..maxBound :: i]] + -- list of index sections with index positions to add + } + where + key = succ $ maxKey s + +-- | Delete /all/ elements that match the query. If you want to delete a single element, you should define a unique index. +delete :: (Indexable a, Index i, IndexOf a ~ i) => HiggsQuery a i (Selection i) -> HiggsSet a i -> HiggsSet a i +delete = update (const Nothing) + +-- | Update /all/ elements that match the query. If you want to update a single element, you should define a unique index. If the update function evaluates to 'Nothing' the element is removed from the set. Note that the resulting element gets completely indexed again, even if certain fields were not affected. You may want to have a look at 'updateUnsafe'. +update :: (Indexable a, Index i, IndexOf a ~ i) => (a -> Maybe a) -> HiggsQuery a i (Selection i) -> HiggsSet a i -> HiggsSet a i +update = updateUnsafe [minBound..maxBound] + +-- | Like 'update', but only the supplied indizes are updated. DANGER: It is possible to corrupt the 'HiggsSet'. +updateUnsafe :: (Indexable a, Index i, IndexOf a ~ i) => [i] -> (a -> Maybe a) -> HiggsQuery a i (Selection i) -> HiggsSet a i -> HiggsSet a i +updateUnsafe ix f query + = \s-> case runReader (query >>= resolve) s of + Nothing' -> s + Singleton x -> g s x + Set xs -> foldl' g s (IS.toList xs) + Everything -> fromList $ mapMaybe f $ toList s + where + g acc i = case IM.lookup i (elements acc) of + Nothing -> acc + Just a -> + case f a of + Nothing -> + acc { elements = IM.delete i (elements acc) + , indizes = V.accum + (foldl' + (\m k-> case m of + SingletonMap m' -> SingletonMap $ TM.delete k m' + MultiMap m' -> MultiMap $ TM.update + (\is-> let is' = IS.delete i is + in if IS.null is' + then Nothing + else Just is' + ) + k + m' + ) + ) + (indizes acc) + [ (fromEnum x, project x a) | x <- ix ] + } + Just a' -> + acc { elements = IM.insert i a' (elements acc) + , indizes = V.accum + (foldl' + (\m k-> case m of + SingletonMap m' -> SingletonMap $ TM.insert + k + i + m' + MultiMap m' -> MultiMap $ TM.insertWith + IS.union + k + (IS.singleton i) + m' + ) + ) + (V.accum + (foldl' + (\m k-> case m of + SingletonMap m' -> SingletonMap $ TM.delete k m' + MultiMap m' -> MultiMap $ TM.update + (\is-> let is' = IS.delete i is + in if IS.null is' + then Nothing + else Just is' + ) + k + m' + ) + ) + (indizes acc) + [ (fromEnum x, project x a) | x <- ix ] + ) + [ (fromEnum x, project x a') | x <- ix ] + } + + +------------------ + +-- | Enumerates all elements of the set in an arbitrary order. This is meant to be the standard of export. +toList :: HiggsSet a i -> [a] +toList = IM.elems . elements + +-- | /Strictly/ creates an 'HiggsSet' from a list. No check for double entries. All indizes are created according to 'Indexable' class instance. +fromList :: (Indexable a, Index i, IndexOf a ~ i) => [a] -> HiggsSet a i +fromList = foldl' (flip insert) empty + +------------------ + +resolve :: forall a i.(Indexable a, Index i, IndexOf a ~ i) + => Selection i + -> HiggsQuery a i (Selection i) + +resolve Nothing' + = return Nothing' + +resolve (Singleton i) + = return (Singleton i) + +resolve (Set a) + = if IS.null a + then return $ Nothing' + else return $ Set a + +resolve Everything + = return Everything + +resolve (Range a b) + = do ind <- index (unMargin a) <$> ask + case ind of + SingletonMap ind1 -> do let ind2 = case a of + Infinite k -> ind1 + _ -> let (ma,la) = TM.search (unMargin a) ind1 + in f a ma $ TM.after la + let ind3 = case b of + Infinite k -> ind2 + _ -> let (mb,lb) = TM.search (unMargin b) ind2 + in f b mb $ TM.before lb + return $ case TM.elems ind3 of + [] -> Nothing' + [i] -> Singleton i + is -> Set $ foldl' (flip IS.insert) IS.empty is + MultiMap ind1 -> do let ind2 = case a of + Infinite k -> ind1 + _ -> let (ma,la) = TM.search (unMargin a) ind1 + in f a ma $ TM.after la + let ind3 = case b of + Infinite k -> ind2 + _ -> let (mb,lb) = TM.search (unMargin b) ind2 + in f b mb $ TM.before lb + return $ case TM.elems ind3 of + [] -> Nothing' + [is] -> Set is + iss -> Set $ foldl' IS.union IS.empty iss + where + f :: Margin i -> Maybe b -> TM.TMap i b -> TM.TMap i b + f (Closed x) = maybe id (TM.insert x) + f _ = const id + +resolve (Union a b) + = do a <- resolve a + case a of + Nothing' -> resolve b + Singleton i -> do b <- resolve b + return $ case b of + Nothing' -> Singleton i + Singleton j -> Set $ IS.fromList [i,j] + Set js -> Set $ IS.insert i js + Everything -> Everything + Set is -> do b <- resolve b + return $ case b of + Nothing' -> Set is + Singleton j -> Set $ IS.insert j is + Set js -> Set $ IS.union is js + Everything -> Everything + Everything -> return Everything + +resolve (Intersection a b) + = do a <- resolve a + case a of + Nothing' -> return a + Singleton i -> do b <- resolve b + return $ case b of + Nothing' -> Nothing' + Singleton j -> if i == j + then Singleton i + else Nothing' + Set js -> if IS.member i js + then Singleton i + else Nothing' + Everything -> Singleton i + Set is -> do b <- resolve b + return $ case b of + Nothing' -> Nothing' + Singleton j -> if IS.member j is + then Singleton j + else Nothing' + Set js -> Set $ IS.intersection is js + Everything -> Set is + Everything -> resolve b + + +---------------------------- + +-- | An empty selection. Do not hesitate to use it as a base element of a 'foldl': +-- +-- > foldl union nothing xs +nothing :: HiggsQuery a i (Selection i) +nothing = return Nothing' + +-- | Select all elements. Do not hesitate to use it as a base element of a 'foldl'. +-- The selection doesn't allocate anything and is optimised away: +-- +-- > foldl intersection everything xs +everything :: HiggsQuery a i (Selection i) +everything = return Everything + +-- | Select all elements that matching the given index position. +equals :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsQuery a i (Selection i) +equals i = return $ Range (Closed i) (Closed i) + +-- | Select all elements that are /strictly/ greater than the given index position (only within the given subindex). +greater :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsQuery a i (Selection i) +greater i = return $ Range (Open i) (Infinite i) + +-- | Select all elements that are greater or equal than the given index position (only within the given subindex). +greaterEq :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsQuery a i (Selection i) +greaterEq i = return $ Range (Closed i) (Infinite i) + +-- | Select all elements that are /strictly/ lower than the given index position (only within the given subindex). +lower :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsQuery a i (Selection i) +lower i = return $ Range (Infinite i) (Open i) + +-- | Select all elements that are lower or equal than the given index position (only within the given subindex). +lowerEq :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsQuery a i (Selection i) +lowerEq i = return $ Range (Infinite i) (Closed i) + +-- | Selects all elements within a certain range (must not leave a subindex). +range :: (Indexable a, Index i, IndexOf a ~ i) => Margin i -- ^ the lower margin + -> Margin i -- ^ the uppper margin + -> HiggsQuery a i (Selection i) +range a b = return $ Range a b + +-- | The union of two selections. The underlying representation uses patricia trees for which unions are quite efficient. +union :: HiggsQuery a i (Selection i) -> HiggsQuery a i (Selection i) -> HiggsQuery a i (Selection i) +union a b = a >>= \a'-> b >>= \b'-> (return $ Union a' b') + +-- | The intersection of two selections. The underlying representation uses patricia trees for which intersections are quite efficient. +intersection :: HiggsQuery a i (Selection i) -> HiggsQuery a i (Selection i) -> HiggsQuery a i (Selection i) +intersection a b = a >>= \a'-> b >>= \b'-> (return $ Intersection a' b') + + +-- | Returns how many elements match a certain query. +querySize :: (Indexable a, Index i, IndexOf a ~ i) => HiggsQuery a i (Selection i) -> HiggsSet a i -> Int +querySize q s = case runReader (q >>= resolve) s of + Nothing' -> 0 + Singleton i -> 1 + Set is -> IS.size is + Everything -> IM.size (elements s) + +-- | Returns all elements matching a certain query as a 'Data.Set.Set'. Double entries are removed, but construction of the set takes /O(n*log(n)/. +querySet :: (Indexable a, Ord a, Index i, IndexOf a ~ i) => HiggsQuery a i (Selection i) -> HiggsSet a i -> S.Set a +querySet q s = S.fromList $ queryList q s + +-- | Returns all elements matching a certain query as a list in arbitrary order. +queryList :: (Indexable a, Index i, IndexOf a ~ i) => HiggsQuery a i (Selection i) -> HiggsSet a i -> [a] +queryList q s = case runReader (q >>= resolve) s of + Nothing' -> [] + Singleton i -> return $ fromMaybe (error "corrupted HiggsSet (error 2a)") $ IM.lookup i (elements s) + Set is -> map + (\i-> fromMaybe (error "corrupted HiggsSet (error 2b)") $ IM.lookup i (elements s)) + (IS.toList is) + Everything -> toList s + + +-- | Looks up an element by index position. If the index is not unique an arbitrary (but not random!) element is returned. +lookup :: (Indexable a, Index i, IndexOf a ~ i) => i -> HiggsSet a i -> Maybe a +lookup i s = case queryList (equals i) s of + [] -> Nothing + (x:_) -> Just x + +-- | Updates an element by index position and returns the updated element. If the index is not unique one arbitrary element gets updated. +-- The old element is removed from all indizes and the new one gets completely indexed. Again, see 'updateLookupUnsafe' as well. +updateLookup :: (Indexable a, Index i, IndexOf a ~ i) => (a -> Maybe a) -> i -> HiggsSet a i -> (Maybe a, HiggsSet a i) +updateLookup = updateLookupUnsafe [minBound..maxBound] + +-- | Like 'updateLookup', but only the supplied indizes get updated. DANGER: This may corrupt the 'HiggsSet'. +updateLookupUnsafe :: (Indexable a, Index i, IndexOf a ~ i) => [i] -> (a -> Maybe a) -> i -> HiggsSet a i -> (Maybe a, HiggsSet a i) +updateLookupUnsafe ix f i s + = case lookup i s of + Nothing -> (Nothing, s) + Just a -> (f a, updateUnsafe ix f (equals i) s) + +-- | Some examples of how to use this function w.r.t. our example type: +-- +-- List all books more expensive than 10 Euro by price in an ascending order. +-- +-- > let p = concatMap snd $ groupOver +-- > Ascending +-- > everything +-- > [(Infinite (IPriceInEuro 10), Infinite (IPriceInEuro undefined)] +-- > myHiggsSet +-- +-- +-- List all books ordered by year from 1987 to 2010 which were either +-- written by one of the Simons or have a /Haskell/ in the title and were written +-- 1990 or later. In all cases, it mustn't be more expensive than 40 Euro. +-- +-- > let p = concatMap snd $ groupOver +-- > Descending +-- > ( ( equals (IAuthor "S.P. Jones") +-- > `union` equals (IAuthor "S. Marlow") +-- > `union` ( equals (ITitle "Haskell") +-- > `intersection` greaterEq (IYear 1990) +-- > ) +-- > ) +-- > `intersection` lowerEq (IPrice 40) +-- > ) +-- > [(Closed (IYear 1987), Open (IYear 2011)] +-- > myHiggsSet +-- +-- In certain applications one needs something that is @LIMIT@ in SQL for getting the result segmentwise. +-- In this implementation there is no better way than walking along the index. Thanks to lazyness we save +-- some lookups if we throw elements right away and don't touch them. So do your @LIMIT@ like this: +-- +-- > take 10 $ drop 100 p +groupOver :: forall a i. (Indexable a, Index i, IndexOf a ~ i) + => Order -- ^ Whether to traverse the given index segments in 'Ascending' or 'Descending' order. + -> HiggsQuery a i (Selection i) -- ^ A selection that every element must be part of. + -> [(Margin i, Margin i)] -- ^ A list of index segments @(lowerBound, upperBound)@ that we traverse over. + -- It is not checked whether neighbouring segments overlap or are in the right order. + -> HiggsSet a i + -> [(i,[a])] -- ^ Every index positions elements got intersected with the supplied selection. + -- The associated list is in arbitrary order. Since we traverse over the whole segment + -- all index positions appear what also means that the associated list might be empty. + -- You may want to apply your favourite sorting algorithm to group\/sort on the second level. + +groupOver order query intervals s + = concatMap + (f (runReader (query >>= resolve) s)) + intervals + where + f selection (a, b) + = case index (unMargin a) s of + SingletonMap ind1 -> let ind2 = case a of + Infinite k -> ind1 + _ -> let (ma,la) = TM.search (unMargin a) ind1 + in t a ma $ TM.after la + in let ind3 = case b of + Infinite k -> ind2 + _ -> let (mb,lb) = TM.search (unMargin b) ind2 + in t b mb $ TM.before lb + in let traverse = case order of + Ascending -> TM.assocs + Descending -> toListDesc + in case selection of + Nothing' -> map + (\(k,_)->(k,[])) + (traverse ind3) + Singleton i -> map + (\(k,y)->(k,) $ if i == y + then [fromMaybe (error "corrupted HiggsSet (error 3a)") $ IM.lookup i (elements s)] + else [] + ) + (traverse ind3) + Set is -> map + (\(k,y)->(k,) $ if IS.member y is + then [fromMaybe (error "corrupted HiggsSet (error 3b)") $ IM.lookup y (elements s)] + else [] + ) + (traverse ind3) + Everything -> map + (\(k,y)->(k,) $ [fromMaybe (error "corrupted HiggsSet (error 3c)") $ IM.lookup y (elements s)] + ) + (traverse ind3) + MultiMap ind1 -> let ind2 = case a of + Infinite k -> ind1 + _ -> let (ma,la) = TM.search (unMargin a) ind1 + in t a ma $ TM.after la + in let ind3 = case b of + Infinite k -> ind2 + _ -> let (mb,lb) = TM.search (unMargin b) ind2 + in t b mb $ TM.before lb + in let traverse = case order of + Ascending -> TM.assocs + Descending -> toListDesc + in case selection of + Nothing' -> map + (\(k,_)->(k,[])) + (traverse ind3) + Singleton i -> map + (\(k,y)->(k,) $ if IS.member i y + then [fromMaybe (error "corrupted HiggsSet (error 3d)") $ IM.lookup i (elements s)] + else [] + ) + (traverse ind3) + Set is -> map + (\(k,y)->(k,) $ map + (fromMaybe (error "corrupted HiggsSet (error 3e)") . ((flip IM.lookup) (elements s))) + (IS.toList $ IS.intersection is y) + ) + (traverse ind3) + Everything -> map + (\(k,y)->(k,) $ map + (fromMaybe (error "corrupted HiggsSet (error 3f)") . ((flip IM.lookup) (elements s))) + (IS.toList y) + ) + (traverse ind3) + t :: Margin i -> Maybe b -> TM.TMap i b -> TM.TMap i b + t (Closed x) = maybe id (TM.insert x) + t _ = const id + +toListDesc :: (TM.TKey i) => TM.TMap i a -> [(i,a)] +toListDesc m = build (\ c n -> TM.foldlWithKey (\z x y-> (curry c) x y z) n m) + +-- Instances + +instance (Indexable a, Index i, IndexOf a ~ i, NFData a, NFData i) => NFData (HiggsSet a i) where + rnf s = (rnf $ elements s) `seq` V.foldl' (\a b-> a `seq` rnf b) () (indizes s) + +instance (TM.TKey a, NFData a, NFData b) => NFData (TM.TMap a b) where + rnf x = (rnf $ TM.assocs x) `seq` () + +instance (TM.TKey a, NFData a) => NFData (IndexMap a) where + rnf (SingletonMap x) = rnf x `seq` () + rnf (MultiMap x) = rnf x `seq` () +