diff --git a/Data/HBlock.hs b/Data/HBlock.hs new file mode 100644 --- /dev/null +++ b/Data/HBlock.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE BangPatterns #-} +module Data.HBlock where +import Prelude hiding (foldr, foldl) +import Data.Foldable (Foldable(..)) +import Control.Monad.ST +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.SafeCopy +import GHC.Exts (build) +import qualified Data.List as L +-- import Data.Indexation.IxData (IxData(IxData, ixDataPos, ixData)) + +data HBlock a = HBlock { set :: !IntSet + , values :: (Vector a) + , size :: !Int + , numItems :: !Int + , blockLen :: !Int + , emptyVal :: !a + } + +instance Functor HBlock where + fmap f (HBlock s v len num blen e) = + if num == 0 + then emptyhb + else IS.foldl transf emptyhb s + where + emptyhb = empty len blen (f e) + transf hb pos = insert (f $ V.unsafeIndex v pos) hb + +instance Foldable HBlock where + foldr f z (HBlock s v _ num _ _) = + if num == 0 then z else IS.foldr' foldit z s + where + foldit pos item = f (V.unsafeIndex v pos) item + foldl f z (HBlock s v _ num _ _) = + if num == 0 then z else IS.foldl foldit z s + where + foldit item pos = f item (V.unsafeIndex v pos) + +instance (SafeCopy a) => SafeCopy (HBlock a) where + version = 0 + kind = base + putCopy h@(HBlock _ _ _ n bl e) = contain $ do safePut n + safePut bl + safePut e + safePut (toList h) + return () + getCopy = contain $ do n <- safeGet + bl <- safeGet + e <- safeGet + lst <- safeGet + return $ fromList n bl e lst + +-- | Creates a new HBlock +-- receives the initial size, the ammount of items that the vector gets +-- incremented when it is almost full, and an empty item to place on the growth +-- vector +empty :: Int -> Int -> a -> HBlock a +empty initSize blockSize e = + HBlock { set = IS.empty + , values = V.replicate initSize e + , size = initSize + , numItems = 0 + , blockLen = blockSize + , emptyVal = e + } +{-# INLINABLE empty #-} + +length :: HBlock a -> Int +length b = numItems b +{-# INLINE length#-} + +-- | similar to insert but returns the index where the item was placed +insertGetIx :: a -> HBlock a -> (Int, HBlock a) +insertGetIx item b = + (pos, b { set = IS.insert pos (set b) + , values = newvec + , size = if growthNeeded then blockLen b else (size b) - 1 + , numItems = numItems b + 1 + }) + where + pos = if IS.null (set b) then 0 else IS.findMax (set b) + 1 + oldvec = values b + growthNeeded = size b == 0 + growthSize = blockLen b + newvec = runST $ + do v <- V.unsafeThaw oldvec + -- grow the vector by the extendAmmount + let extendIxs = [pos..(pos+growthSize)] + v' <- if growthNeeded + then do newv <- VM.unsafeGrow v growthSize + (mapM_ (\i -> VM.write newv i (emptyVal b)) extendIxs) + return newv + else return v + VM.write v' pos item + V.unsafeFreeze v' +{-# INLINABLE insertGetIx #-} + +insert :: a -> HBlock a -> HBlock a +insert i b = snd $ insertGetIx i b +{-# INLINE insert #-} + +adjust :: (a -> a) -> Int -> HBlock a -> HBlock a +adjust f pos b = b { values = adjusted } + where + oldvec = values b + adjusted = runST $ + do v <- V.unsafeThaw oldvec + val <- VM.read v pos + VM.write v pos (f val) + V.unsafeFreeze v +{-# INLINABLE adjust #-} + +update :: a -> Int -> HBlock a -> HBlock a +update new pos b = b { values = adjusted } + where + oldvec = values b + adjusted = runST $ + do v <- V.unsafeThaw oldvec + VM.write v pos new + V.unsafeFreeze v +{-# INLINABLE update #-} + +occupied :: Int -> HBlock a -> Bool +occupied pos b = IS.member pos (set b) +{-# INLINE occupied #-} + +getPos :: HBlock a -> Int -> Maybe a +getPos hb pos = if occupied pos hb then Just $ V.unsafeIndex (values hb) pos + else Nothing +{-# INLINABLE getPos #-} + +getSet :: HBlock a -> IntSet -> HBlock a +getSet hb s = hb { set = newSet + , numItems = IS.size newSet + } + where + newSet = IS.intersection s (set hb) + -- ^TODO map and copy the whole vector into the new hb ? + -- test growing the vector and then using the returned HB from this function + +delete :: Int -> HBlock a -> HBlock a +delete pos b = b { set = IS.delete pos (set b) + , numItems = if occupied pos b then numItems b - 1 + else numItems b + } +{-# INLINABLE delete #-} + +-- | /O(n)/ Return a list of this hblock's elements. The list is +-- produced lazily. +-- toList :: HashMap k v -> [(k, v)] +-- toList t = build (\ c z -> foldrWithKey (curry c) z t) +toList :: HBlock a -> [a] +toList hb = build (\c z -> foldr c z hb) +{-# INLINE toList #-} + +-- | /O(n)/ Construct a hblock with the values from a list. +fromList :: Int -> Int -> a -> [a] -> HBlock a +fromList s bs e lst = L.foldl' (flip insert) (empty s bs e) lst +{-# INLINABLE fromList #-} diff --git a/Data/Indexation/Constraints.hs b/Data/Indexation/Constraints.hs new file mode 100644 --- /dev/null +++ b/Data/Indexation/Constraints.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE RankNTypes, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +module Data.Indexation.Constraints + ( Text128 + , Text256 + , Text512 + , Text1024 + , Text2048 + , Text4096 + , TextConstraint(..) + , t128 + , t256 + , t512 + , t1024 + , t2048 + , t4096) where +import Prelude +import qualified Data.Text as T +import Data.Data +import Data.String +import Data.Monoid +import Control.Monad +import Control.DeepSeq +import Data.SafeCopy +import Data.Serialize +import Data.Text.Encoding +import Data.Hashable +import Data.Aeson +import qualified Data.Aeson as Aeson + +-- | Text with a maximum of 128 characters +newtype Text128 = Text128 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) +newtype Text256 = Text256 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) +newtype Text512 = Text512 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) +newtype Text1024 = Text1024 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) +newtype Text2048 = Text2048 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) +newtype Text4096 = Text4096 T.Text deriving(Eq, Data, Ord, Read, Show, Typeable, IsString, Monoid, NFData) + +class TextConstraint a where + txtConstraint :: T.Text -> a + getTxt :: a -> T.Text + fromText :: T.Text -> a + fromText = txtConstraint + toText :: a -> T.Text + toText = getTxt + +instance TextConstraint Text128 where txtConstraint = t128 + getTxt (Text128 t) = t +instance TextConstraint Text256 where txtConstraint = t256 + getTxt (Text256 t) = t +instance TextConstraint Text512 where txtConstraint = t512 + getTxt (Text512 t) = t +instance TextConstraint Text1024 where txtConstraint = t1024 + getTxt (Text1024 t) = t +instance TextConstraint Text2048 where txtConstraint = t2048 + getTxt (Text2048 t) = t +instance TextConstraint Text4096 where txtConstraint = t4096 + getTxt (Text4096 t) = t + +instance (TextConstraint a) => TextConstraint (Maybe a) where + txtConstraint t = Just $ txtConstraint t + getTxt t = case t of + Just a -> getTxt a + Nothing -> T.empty + +instance Hashable Text128 where hashWithSalt s d = hashWithSalt s (getTxt d) +instance Hashable Text256 where hashWithSalt s d = hashWithSalt s (getTxt d) +instance Hashable Text512 where hashWithSalt s d = hashWithSalt s (getTxt d) +instance Hashable Text1024 where hashWithSalt s d = hashWithSalt s (getTxt d) +instance Hashable Text2048 where hashWithSalt s d = hashWithSalt s (getTxt d) +instance Hashable Text4096 where hashWithSalt s d = hashWithSalt s (getTxt d) + +instance Serialize Text128 where put (Text128 t) = put $ encodeUtf8 t + get = (Text128 . decodeUtf8) `fmap` get +instance Serialize Text256 where put (Text256 t) = put $ encodeUtf8 t + get = (Text256 . decodeUtf8) `fmap` get +instance Serialize Text512 where put (Text512 t) = put $ encodeUtf8 t + get = (Text512 . decodeUtf8) `fmap` get +instance Serialize Text1024 where put (Text1024 t) = put $ encodeUtf8 t + get = (Text1024 . decodeUtf8) `fmap` get +instance Serialize Text2048 where put (Text2048 t) = put $ encodeUtf8 t + get = (Text2048 . decodeUtf8) `fmap` get +instance Serialize Text4096 where put (Text4096 t) = put $ encodeUtf8 t + get = (Text4096 . decodeUtf8) `fmap` get + +instance SafeCopy Text128 where putCopy (Text128 t) = putCopy t + getCopy = contain $ Text128 `fmap` safeGet +instance SafeCopy Text256 where putCopy (Text256 t) = putCopy t + getCopy = contain $ Text256 `fmap` safeGet +instance SafeCopy Text512 where putCopy (Text512 t) = putCopy t + getCopy = contain $ Text512 `fmap` safeGet +instance SafeCopy Text1024 where putCopy (Text1024 t) = putCopy t + getCopy = contain $ Text1024 `fmap` safeGet +instance SafeCopy Text2048 where putCopy (Text2048 t) = putCopy t + getCopy = contain $ Text2048 `fmap` safeGet +instance SafeCopy Text4096 where putCopy (Text4096 t) = putCopy t + getCopy = contain $ Text4096 `fmap` safeGet + +instance FromJSON Text128 where parseJSON (Aeson.String s) = return $ t128 s + parseJSON _ = mzero +instance FromJSON Text256 where parseJSON (Aeson.String s) = return $ t256 s + parseJSON _ = mzero +instance FromJSON Text512 where parseJSON (Aeson.String s) = return $ t512 s + parseJSON _ = mzero +instance FromJSON Text1024 where parseJSON (Aeson.String s) = return $ t1024 s + parseJSON _ = mzero +instance FromJSON Text2048 where parseJSON (Aeson.String s) = return $ t2048 s + parseJSON _ = mzero +instance FromJSON Text4096 where parseJSON (Aeson.String s) = return $ t4096 s + parseJSON _ = mzero +instance ToJSON Text128 where toJSON s = Aeson.String (getTxt s) +instance ToJSON Text256 where toJSON s = Aeson.String (getTxt s) +instance ToJSON Text512 where toJSON s = Aeson.String (getTxt s) +instance ToJSON Text1024 where toJSON s = Aeson.String (getTxt s) +instance ToJSON Text2048 where toJSON s = Aeson.String (getTxt s) +instance ToJSON Text4096 where toJSON s = Aeson.String (getTxt s) + +t128 :: T.Text -> Text128 +t128 = Text128 . T.take 128 + +t256 :: T.Text -> Text256 +t256 = Text256 . T.take 256 + +t512 :: T.Text -> Text512 +t512 = Text512 . T.take 512 + +t1024 :: T.Text -> Text1024 +t1024 = Text1024 . T.take 1024 + +t2048 :: T.Text -> Text2048 +t2048 = Text2048 . T.take 2048 + +t4096 :: T.Text -> Text4096 +t4096 = Text4096 . T.take 4096 + diff --git a/Data/Indexation/NormalIx.hs b/Data/Indexation/NormalIx.hs new file mode 100644 --- /dev/null +++ b/Data/Indexation/NormalIx.hs @@ -0,0 +1,561 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Indexation.NormalIx +( SimpleIx(..) +, Indexed(..) +, createIndexed +, withUnique1 +, withUnique2 +, withIndex1 +, withIndex2 +, withIndex3 +, withIndex4 +, withFilters +, insertGetIx +, insert +, deleteIndex +, deleteU1 +, deleteU2 +, getU1 +, getU2 +, getI1 +, getI2 +, getI3 +, getI4 +, getFilter +, adjust +, adjustWithU1 +, adjustWithU2 +, update +, updateWithU1 +, updateWithU2 +) where + +import Data.HBlock (HBlock) +import qualified Data.HBlock as HB +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as V +import Data.SafeCopy +import Data.Hashable +import qualified Data.Foldable as Fold +-- import Data.Indexation.IxData (IxData(ixDataPos, ixData)) +import Data.Maybe (fromMaybe) + +data Indexed a u1 u2 i1 i2 i3 i4 + = Indexed !(HBlock a) + -- ^ Where all the data is + !(Maybe (IndexU a u1 u2)) + -- ^ Unique indexation structures + !(Maybe (IndexI a i1 i2 i3 i4)) + -- ^ Indexation structures + !(Vector (a -> Bool)) + -- ^ Filters (i.e. >= 30) + !(Vector IntSet) + -- ^ Filters results + +-- | IndexCore is the index structures for a given data +data IndexU a u1 u2 + = IxHasU1 !(HashMap u1 Int) !(a -> u1) + | IxHasU2 !(HashMap u1 Int) !(a -> u1) + !(HashMap u2 Int) !(a -> u2) +data IndexI a i1 i2 i3 i4 + = IxHasI1 !(HashMap i1 IntSet) !(a -> i1) + | IxHasI2 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + | IxHasI3 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + !(HashMap i3 IntSet) !(a -> i3) + | IxHasI4 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + !(HashMap i3 IntSet) !(a -> i3) + !(HashMap i4 IntSet) !(a -> i4) + +-- * +-- * Creation functions +-- * +class SimpleIx a where + -- | Creates your indexed dataype + type U1 a + type U2 a + type I1 a + type I2 a + type I3 a + type I4 a + create :: Indexed a (U1 a) (U2 a) (I1 a) (I2 a) (I3 a) (I4 a) + +defSlots :: Int +defSlots = 4096 +defBlockLen :: Int +defBlockLen = 4096 + +-- | createIndexed is a helper function to create the base Indexed datatype +-- it is used in the "createdUxIx" functions to avoid repetition +createIndexed :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4) + => a -> Indexed a u1 u2 i1 i2 i3 i4 +createIndexed e = Indexed (HB.empty defSlots defBlockLen e) + Nothing Nothing V.empty V.empty + +withUnique1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> u1) + -> Indexed a u1 u2 i1 i2 i3 i4 +withUnique1 i@(Indexed v uis iis vf vs) f = + case uis of + Nothing -> Indexed v (Just $ IxHasU1 HM.empty f) iis vf vs + _ -> i + +withUnique2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> u2) + -> Indexed a u1 u2 i1 i2 i3 i4 +withUnique2 i@(Indexed v uis iis vf vs) f = + case uis of + Just (IxHasU1 m1 f1) -> + Indexed v (Just $ IxHasU2 m1 f1 HM.empty f) iis vf vs + _ -> i + +withIndex1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i1) + -> Indexed a u1 u2 i1 i2 i3 i4 +withIndex1 i@(Indexed v uis iis vf vs) f = + case iis of + Nothing -> Indexed v uis (Just $ IxHasI1 HM.empty f) vf vs + _ -> i + +withIndex2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i2) + -> Indexed a u1 u2 i1 i2 i3 i4 +withIndex2 i@(Indexed v uis iis vf vs) f = + case iis of + Just (IxHasI1 m1 f1) -> + let niis = Just $ IxHasI2 m1 f1 HM.empty f in + Indexed v uis niis vf vs + _ -> i + + +withIndex3 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i3) + -> Indexed a u1 u2 i1 i2 i3 i4 +withIndex3 i@(Indexed v uis iis vf vs) f = + case iis of + Just (IxHasI2 m1 f1 m2 f2) -> + let niis = Just $ IxHasI3 m1 f1 m2 f2 HM.empty f in + Indexed v uis niis vf vs + _ -> i + + +withIndex4 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> (a -> i4) + -> Indexed a u1 u2 i1 i2 i3 i4 +withIndex4 i@(Indexed v uis iis vf vs) f = + case iis of + Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> + let niis = Just $ IxHasI4 m1 f1 m2 f2 m3 f3 HM.empty f in + Indexed v uis niis vf vs + _ -> i + +withFilters :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> [(a -> Bool)] + -> Indexed a u1 u2 i1 i2 i3 i4 +withFilters (Indexed v uis iis _ _) lst = + Indexed v uis iis flst vlst + where + flst = V.fromList lst + vlst = V.replicate (V.length flst) IS.empty + + +-- * +-- * Insertion functions +-- * +insertGetIx :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> a + -> (Int, Indexed a u1 u2 i1 i2 i3 i4) +insertGetIx (Indexed hb uis iis vf vi) item = + (pos, Indexed newhb newuis newiis vf newvi) + where + (pos, newhb) = HB.insertGetIx item hb + newuis = + case uis of + Nothing -> Nothing + Just (IxHasU1 m1 f1) -> Just $ + IxHasU1 (HM.insert (f1 item) pos m1) f1 + Just (IxHasU2 m1 f1 m2 f2) -> Just $ + IxHasU2 (HM.insert (f1 item) pos m1) f1 + (HM.insert (f2 item) pos m2) f2 + newiis = + case iis of + Nothing -> Nothing + Just (IxHasI1 m1 f1) -> Just $ + IxHasI1 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + Just (IxHasI2 m1 f1 m2 f2) -> Just $ + IxHasI2 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> Just $ + IxHasI3 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + (HM.adjust (IS.insert pos) (f3 item) m3) f3 + Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4) -> Just $ + IxHasI4 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + (HM.adjust (IS.insert pos) (f3 item) m3) f3 + (HM.adjust (IS.insert pos) (f4 item) m4) f4 + newvi = V.imap fvi vi + -- check if the filter applies to this element, if it applies insert + -- the element index into the intset + fvi i e = if V.unsafeIndex vf i $ item then IS.insert pos e else e +{-# INLINABLE insertGetIx #-} + +insert :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> a -> Indexed a u1 u2 i1 i2 i3 i4 +insert i item = snd $ insertGetIx i item +{-# INLINE insert #-} + +-- * +-- * Deletion functions +-- * +deleteIndex :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> Indexed a u1 u2 i1 i2 i3 i4 +deleteIndex (Indexed hb uis iis vf vi) ix = + Indexed (HB.delete ix hb) uis iis vf vi +{-# INLINE deleteIndex #-} + -- ^ TODO: delete from the indices and vi ? + +deleteU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +deleteU1 i@(Indexed hb uis _ _ _) u1 = do + u <- uis + pos <- f u + return $ deleteIndex i pos + where + f (IxHasU1 m _) = HM.lookup u1 m + f (IxHasU2 m _ _ _) = HM.lookup u1 m + +deleteU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +deleteU2 i@(Indexed hb uis _ _ _) u2 = do + u <- uis + pos <- f u + return $ deleteIndex i pos + where + f (IxHasU1 _ _) = Nothing + f (IxHasU2 _ _ m _) = HM.lookup u2 m + + + +-- deleteIxData +{- +delete :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> a -> Indexed a u1 u2 i1 i2 i3 i4 +delete (Indexed hb uis iis vf vi) a = +-} + +-- * +-- * Accessor (getters) functions +-- * +getU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> Maybe a +getU1 (Indexed hb uis _ _ _) u1 = do + u <- uis + pos <- f u + HB.getPos hb pos + where + f (IxHasU1 m _) = HM.lookup u1 m + f (IxHasU2 m _ _ _) = HM.lookup u1 m +{-# INLINABLE getU1 #-} + +getU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> Maybe a +getU2 (Indexed hb uis _ _ _) u2 = do + u <- uis + pos <- f u + HB.getPos hb pos + where + f (IxHasU1 _ _) = Nothing + f (IxHasU2 _ _ m _) = HM.lookup u2 m +{-# INLINABLE getU2 #-} + +getI1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> i1 -> Maybe (HBlock a) +getI1 (Indexed hb _ iis _ _) i = do + iis' <- iis + set <- f iis' + return $ HB.getSet hb set + where + f (IxHasI1 m _) = HM.lookup i m + f (IxHasI2 m _ _ _) = HM.lookup i m + f (IxHasI3 m _ _ _ _ _) = HM.lookup i m + f (IxHasI4 m _ _ _ _ _ _ _) = HM.lookup i m +{-# INLINABLE getI1 #-} + +getI2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> i2 -> Maybe (HBlock a) +getI2 (Indexed hb _ iis _ _) i = do + iis' <- iis + set <- f iis' + return $ HB.getSet hb set + where + f (IxHasI2 _ _ m _) = HM.lookup i m + f (IxHasI3 _ _ m _ _ _) = HM.lookup i m + f (IxHasI4 _ _ m _ _ _ _ _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI2 #-} + +getI3 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> i3 -> Maybe (HBlock a) +getI3 (Indexed hb _ iis _ _) i = do + iis' <- iis + set <- f iis' + return $ HB.getSet hb set + where + f (IxHasI3 _ _ _ _ m _) = HM.lookup i m + f (IxHasI4 _ _ _ _ m _ _ _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI3 #-} + +getI4 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> i4 -> Maybe (HBlock a) +getI4 (Indexed hb _ iis _ _) i = do + iis' <- iis + set <- f iis' + return $ HB.getSet hb set + where + f (IxHasI4 _ _ _ _ _ _ m _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI4 #-} + +getFilter :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> Maybe (HBlock a) +getFilter (Indexed hb _ _ _ vi) filterPos = do + set <- vi !? filterPos + return $ HB.getSet hb set +{-# INLINABLE getFilter #-} + +-- * +-- * Setter functions +-- * + +-- | helper function, updates the hash of a unique index +_updateUHash :: (Eq u, Hashable u) => HashMap u Int -> Int -> u -> u + -> HashMap u Int +_updateUHash m val old new = HM.insert new val $ HM.delete old m + +_updateIHash :: (Eq u, Hashable u) => HashMap u IntSet -> Int -> u -> u + -> HashMap u IntSet +_updateIHash m val old new = + HM.insertWith insSet new valSet $ HM.adjust (IS.delete val) old m + where + insSet _ o = IS.insert val o + valSet = IS.singleton val +-- | helper function, updates the unique indices +_updateU :: (Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2) + => Maybe (IndexU a u1 u2) -> Int -> a -> a -> Maybe (IndexU a u1 u2) +_updateU (Just (IxHasU1 m f)) val old new = + Just $ IxHasU1 (_updateUHash m val (f old) (f new)) f +_updateU (Just (IxHasU2 m1 f1 m2 f2)) val old new = + Just $ IxHasU2 (_updateUHash m1 val (f1 old) (f1 new)) f1 + (_updateUHash m2 val (f2 old) (f2 new)) f2 +_updateU Nothing _ _ _ = Nothing + +-- | helper function, updates the normal indices +_updateI :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2 + , Eq i3, Hashable i3, Eq i4, Hashable i4) + => Maybe (IndexI a i1 i2 i3 i4) -> Int -> a -> a + -> Maybe (IndexI a i1 i2 i3 i4) +_updateI (Just (IxHasI1 m f)) val old new = + Just $ IxHasI1 (_updateIHash m val (f old) (f new)) f +_updateI (Just (IxHasI2 m1 f1 m2 f2)) val old new = + Just $ IxHasI2 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 +_updateI (Just (IxHasI3 m1 f1 m2 f2 m3 f3)) val old new = + Just $ IxHasI3 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 + (_updateIHash m3 val (f3 old) (f3 new)) f3 +_updateI (Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4)) val old new = + Just $ IxHasI4 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 + (_updateIHash m3 val (f3 old) (f3 new)) f3 + (_updateIHash m4 val (f4 old) (f4 new)) f4 +_updateI Nothing _ _ _ = Nothing + +-- | helper function, updates the normal indices +_updateF :: Vector (a -> Bool) -> Vector IntSet -> Int -> a -> a + -> Vector IntSet +_updateF vf v value old new = V.imap applyF vf + -- map the vf, apply the function to the old and the new, if diff, change the v + -- because it is faster to check for indexation in a vector than to check + -- membership in a intset + where + applyF pos f = let f1 = f old + f2 = f new + iset = V.unsafeIndex v pos + in if f1 == f2 + then iset + else if f2 then IS.insert value iset + else IS.delete value iset + +adjust :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> (a -> a) + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +adjust i@(Indexed hb ius iis vf vi) pos f = do + e <- HB.getPos hb pos + let newe = f e + return $ Indexed (HB.update newe pos hb) + (_updateU ius pos e newe) + (_updateI iis pos e newe) + vf (_updateF vf vi pos e newe) +{-# INLINABLE adjust #-} + +adjustWithU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> (a -> a) + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +adjustWithU1 i@(Indexed hb uis iis vf vi) u1 af = do + u <- uis + pos <- f u + e <- HB.getPos hb pos + let newe = af e + return $ Indexed (HB.update newe pos hb) + (_updateU uis pos e newe) + (_updateI iis pos e newe) + vf (_updateF vf vi pos e newe) + where + f (IxHasU1 m _) = HM.lookup u1 m + f (IxHasU2 m _ _ _) = HM.lookup u1 m +{-# INLINABLE adjustWithU1 #-} + +adjustWithU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> (a -> a) + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +adjustWithU2 i@(Indexed hb uis iis vf vi) u2 af = do + u <- uis + pos <- f u + e <- HB.getPos hb pos + let newe = af e + return $ Indexed (HB.update newe pos hb) + (_updateU uis pos e newe) + (_updateI iis pos e newe) + vf (_updateF vf vi pos e newe) + where + f (IxHasU1 _ _) = Nothing + f (IxHasU2 _ _ m _) = HM.lookup u2 m +{-# INLINABLE adjustWithU2 #-} + +update :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> Int -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +update i p a = adjust i p (const a) +{-# INLINABLE update #-} + +updateWithU1 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u1 -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +updateWithU1 i u1 a = adjustWithU1 i u1 (const a) +{-# INLINABLE updateWithU1 #-} + +updateWithU2 :: ( Eq a, Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a u1 u2 i1 i2 i3 i4 -> u2 -> a + -> Maybe (Indexed a u1 u2 i1 i2 i3 i4) +updateWithU2 i u2 a = adjustWithU2 i u2 (const a) +{-# INLINABLE updateWithU2 #-} + +instance ( SafeCopy a, Eq a, SimpleIx a + , Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + , u1 ~ U1 a, u2 ~ U2 a, i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a, i4 ~ I4 a + ) => SafeCopy (Indexed a u1 u2 i1 i2 i3 i4) where + version = 0 + kind = base + putCopy (Indexed hb _ _ _ _) = contain $ safePut hb + getCopy = contain $ fmap withData safeGet + where + withData :: (SafeCopy a, Eq a, SimpleIx a + , Eq u1, Hashable u1, Eq u2, Hashable u2 + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3 + , Hashable i3, Eq i4, Hashable i4 + , u1 ~ U1 a, u2 ~ U2 a, i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a + , i4 ~ I4 a) => HBlock a -> Indexed a u1 u2 i1 i2 i3 i4 + withData h = Fold.foldl insert create h + diff --git a/Data/Indexation/SimpleIx.hs b/Data/Indexation/SimpleIx.hs new file mode 100644 --- /dev/null +++ b/Data/Indexation/SimpleIx.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Indexation.SimpleIx +( SimpleIx(..) +, Indexed(..) +, createIndexed +, withFunction +, withIndex1 +, withIndex2 +, withIndex3 +, withIndex4 +, withFilters +, insert +, deleteIndex +, delete +, size +, getPos +, getI1 +, getI2 +, getI3 +, getI4 +, getFilter +, member +, adjust +, update +) where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +import Data.IntSet (IntSet) +import qualified Data.IntSet as IS +import Data.IntMap.Strict (IntMap, (!)) +import qualified Data.IntMap.Strict as IM +import Data.Vector (Vector, (!?)) +import qualified Data.Vector as V +import Data.SafeCopy +import Data.Hashable +-- import Data.Indexation.IxData (IxData(ixDataPos, ixData)) + +data Indexed a i1 i2 i3 i4 + = Indexed !(IntMap a) + -- ^ Where all the data is + !(a -> Int) + -- ^ How to access the data + !(Maybe (IndexI a i1 i2 i3 i4)) + -- ^ Indexation structures + !(Vector (a -> Bool)) + -- ^ Filters (i.e. >= 30, == "foo") + !(Vector IntSet) + -- ^ Filters results + !IntSet + -- ^ helper set to speed index lookup + !Int + -- ^ Number of items + +-- TODO: the function should be (a -> b), where b is Hashable +-- this should be the "ID" function, and it should be used to check if +-- the id was changed in "adjust" and update it + +data IndexI a i1 i2 i3 i4 + = IxHasI1 !(HashMap i1 IntSet) !(a -> i1) + | IxHasI2 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + | IxHasI3 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + !(HashMap i3 IntSet) !(a -> i3) + | IxHasI4 !(HashMap i1 IntSet) !(a -> i1) + !(HashMap i2 IntSet) !(a -> i2) + !(HashMap i3 IntSet) !(a -> i3) + !(HashMap i4 IntSet) !(a -> i4) + +-- * +-- * Creation functions +-- * +class SimpleIx a where + -- | Creates your indexed dataype + type I1 a + type I2 a + type I3 a + type I4 a + create :: Indexed a (I1 a) (I2 a) (I3 a) (I4 a) + +-- | createIndexed is a helper function to create the base Indexed datatype +-- it is used in the "createdUxIx" functions to avoid repetition +createIndexed :: ( Eq a, Eq i1, Hashable i1, Eq i2, Hashable i2 + , Eq i3, Hashable i3, Eq i4, Hashable i4) + => Indexed a i1 i2 i3 i4 +createIndexed = Indexed IM.empty (const 0) Nothing V.empty V.empty IS.empty 0 + +withFunction :: ( Eq a, Eq i1, Hashable i1, Eq i2, Hashable i2 + , Eq i3, Hashable i3, Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> (a -> Int) + -> Indexed a i1 i2 i3 i4 +withFunction (Indexed d _ iis vf vs is s) f = Indexed d f iis vf vs is s + +withIndex1 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> (a -> i1) + -> Indexed a i1 i2 i3 i4 +withIndex1 i@(Indexed d a iis vf vs is s) f = + case iis of + Nothing -> Indexed d a (Just $ IxHasI1 HM.empty f) vf vs is s + _ -> i + +withIndex2 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> (a -> i2) + -> Indexed a i1 i2 i3 i4 +withIndex2 i@(Indexed d a iis vf vs is s) f = + case iis of + Just (IxHasI1 m1 f1) -> + let niis = Just $ IxHasI2 m1 f1 HM.empty f in + Indexed d a niis vf vs is s + _ -> i + + +withIndex3 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> (a -> i3) + -> Indexed a i1 i2 i3 i4 +withIndex3 i@(Indexed d a iis vf vs is s) f = + case iis of + Just (IxHasI2 m1 f1 m2 f2) -> + let niis = Just $ IxHasI3 m1 f1 m2 f2 HM.empty f in + Indexed d a niis vf vs is s + _ -> i + + +withIndex4 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> (a -> i4) + -> Indexed a i1 i2 i3 i4 +withIndex4 i@(Indexed d a iis vf vs is s) f = + case iis of + Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> + let niis = Just $ IxHasI4 m1 f1 m2 f2 m3 f3 HM.empty f in + Indexed d a niis vf vs is s + _ -> i + +withFilters :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> [(a -> Bool)] + -> Indexed a i1 i2 i3 i4 +withFilters (Indexed d f iis _ _ is s) lst = + Indexed d f iis flst vlst is s + where + flst = V.fromList lst + vlst = V.replicate (V.length flst) IS.empty + +-- * +-- * Insertion functions +-- * +insert :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> a + -> Indexed a i1 i2 i3 i4 +insert (Indexed d f iis vf vi is s) item = + Indexed newd f newiis vf newvi newis (s + 1) + where + pos = f item + newd = IM.insert pos item d + newis = IS.insert pos is + newiis = + case iis of + Nothing -> Nothing + Just (IxHasI1 m1 f1) -> Just $ + IxHasI1 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + Just (IxHasI2 m1 f1 m2 f2) -> Just $ + IxHasI2 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + Just (IxHasI3 m1 f1 m2 f2 m3 f3) -> Just $ + IxHasI3 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + (HM.adjust (IS.insert pos) (f3 item) m3) f3 + Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4) -> Just $ + IxHasI4 (HM.adjust (IS.insert pos) (f1 item) m1) f1 + (HM.adjust (IS.insert pos) (f2 item) m2) f2 + (HM.adjust (IS.insert pos) (f3 item) m3) f3 + (HM.adjust (IS.insert pos) (f4 item) m4) f4 + newvi = V.imap fvi vi + -- check if the filter applies to this element, if it applies insert + -- the element index into the intset + fvi i e = if V.unsafeIndex vf i $ item then IS.insert pos e else e +{-# INLINABLE insert #-} + +-- * +-- * Deletion functions +-- * +deleteIndex :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int -> Indexed a i1 i2 i3 i4 +deleteIndex i@(Indexed d a iis vf vi is s) ix = + case old of + Nothing -> i + Just _ -> Indexed newd a iis vf vi (IS.delete ix is) (s - 1) + where + deleteKey _ _ = Nothing + (old, newd) = IM.updateLookupWithKey deleteKey ix d + + +{-# INLINE deleteIndex #-} + -- ^ TODO: delete from the indices and vi ? + +delete :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> a -> Indexed a i1 i2 i3 i4 +delete i@(Indexed _ f _ _ _ _ _) item = deleteIndex i (f item) +{-# INLINE delete #-} + +-- * +-- * Accessor (getters) functions +-- * +size :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int +size (Indexed _ _ _ _ _ _ s) = s +{-# INLINE size #-} + +getPos :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int -> Maybe a +getPos (Indexed d _ _ _ _ _ _) pos = IM.lookup pos d +{-# INLINE getPos #-} + +getSet :: IntMap a -> IntSet -> IntSet -> IntMap a +getSet im imkis is = IM.fromSet (\k -> im ! k) (IS.intersection imkis is) +{-# INLINE getSet #-} + +getI1 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> i1 -> Maybe (IntMap a) +getI1 (Indexed d _ iis _ _ is _) i = do + iis' <- iis + set <- f iis' + return $ getSet d is set + where + f (IxHasI1 m _) = HM.lookup i m + f (IxHasI2 m _ _ _) = HM.lookup i m + f (IxHasI3 m _ _ _ _ _) = HM.lookup i m + f (IxHasI4 m _ _ _ _ _ _ _) = HM.lookup i m +{-# INLINABLE getI1 #-} + +getI2 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> i2 -> Maybe (IntMap a) +getI2 (Indexed d _ iis _ _ is _) i = do + iis' <- iis + set <- f iis' + return $ getSet d is set + where + f (IxHasI2 _ _ m _) = HM.lookup i m + f (IxHasI3 _ _ m _ _ _) = HM.lookup i m + f (IxHasI4 _ _ m _ _ _ _ _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI2 #-} + +getI3 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> i3 -> Maybe (IntMap a) +getI3 (Indexed d _ iis _ _ is _) i = do + iis' <- iis + set <- f iis' + return $ getSet d is set + where + f (IxHasI3 _ _ _ _ m _) = HM.lookup i m + f (IxHasI4 _ _ _ _ m _ _ _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI3 #-} + +getI4 :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> i4 -> Maybe (IntMap a) +getI4 (Indexed d _ iis _ _ is _) i = do + iis' <- iis + set <- f iis' + return $ getSet d is set + where + f (IxHasI4 _ _ _ _ _ _ m _) = HM.lookup i m + f _ = Nothing +{-# INLINABLE getI4 #-} + +getFilter :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int -> Maybe (IntMap a) +getFilter (Indexed d _ _ _ vi is _) filterPos = do + set <- vi !? filterPos + return $ getSet d is set +{-# INLINABLE getFilter #-} + +member :: ( Eq a, Hashable b + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> b -> Bool +member (Indexed _ _ _ _ _ is _) b = IS.member (hash b) is +{-# INLINE member #-} + +-- * +-- * Setter functions +-- * + +-- | helper function, updates the normal indices +_updateIHash :: (Eq u, Hashable u) => HashMap u IntSet -> Int -> u -> u + -> HashMap u IntSet +_updateIHash m val old new = + HM.insertWith insSet new valSet $ HM.adjust (IS.delete val) old m + where + insSet _ o = IS.insert val o + valSet = IS.singleton val +-- | helper function, updates the normal indices +_updateI :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2 + , Eq i3, Hashable i3, Eq i4, Hashable i4) + => Maybe (IndexI a i1 i2 i3 i4) -> Int -> a -> a + -> Maybe (IndexI a i1 i2 i3 i4) +_updateI (Just (IxHasI1 m f)) val old new = + Just $ IxHasI1 (_updateIHash m val (f old) (f new)) f +_updateI (Just (IxHasI2 m1 f1 m2 f2)) val old new = + Just $ IxHasI2 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 +_updateI (Just (IxHasI3 m1 f1 m2 f2 m3 f3)) val old new = + Just $ IxHasI3 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 + (_updateIHash m3 val (f3 old) (f3 new)) f3 +_updateI (Just (IxHasI4 m1 f1 m2 f2 m3 f3 m4 f4)) val old new = + Just $ IxHasI4 (_updateIHash m1 val (f1 old) (f1 new)) f1 + (_updateIHash m2 val (f2 old) (f2 new)) f2 + (_updateIHash m3 val (f3 old) (f3 new)) f3 + (_updateIHash m4 val (f4 old) (f4 new)) f4 +_updateI Nothing _ _ _ = Nothing + +-- | helper function, updates the normal indices +_updateF :: Vector (a -> Bool) -> Vector IntSet -> Int -> a -> a + -> Vector IntSet +_updateF vf v value old new = V.imap applyF vf + -- map the vf, apply the function to the old and the new, if diff, change + -- the v because it is faster to check for indexation in a vector than + -- to check membership in a intset + where + applyF pos f = let f1 = f old + f2 = f new + iset = V.unsafeIndex v pos + in if f1 == f2 + then iset + else if f2 then IS.insert value iset + else IS.delete value iset + +adjust :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int -> (a -> a) + -> Maybe (Indexed a i1 i2 i3 i4) +adjust (Indexed d a iis vf vi is s) pos f = do + e <- me + let newe = f e + return $ Indexed newdata a + (_updateI iis pos e newe) + vf (_updateF vf vi pos e newe) + is s + where + (me, newdata) = IM.updateLookupWithKey (\_ v -> Just $ f v) pos d +{-# INLINABLE adjust #-} + +update :: ( Eq a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + ) + => Indexed a i1 i2 i3 i4 -> Int -> a + -> Maybe (Indexed a i1 i2 i3 i4) +update i p a = adjust i p (const a) +{-# INLINABLE update #-} + +instance ( SafeCopy a, Eq a, SimpleIx a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3, Hashable i3 + , Eq i4, Hashable i4 + , i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a, i4 ~ I4 a + ) => SafeCopy (Indexed a i1 i2 i3 i4) where + version = 0 + kind = base + putCopy (Indexed d _ _ _ _ _ _) = contain $ safePut $ IM.elems d + getCopy = contain $ fmap withData safeGet + where + withData :: (SafeCopy a, Eq a, SimpleIx a + , Eq i1, Hashable i1, Eq i2, Hashable i2, Eq i3 + , Hashable i3, Eq i4, Hashable i4 + , i1 ~ I1 a, i2 ~ I2 a, i3 ~ I3 a + , i4 ~ I4 a) => IntMap a -> Indexed a i1 i2 i3 i4 + withData h = IM.foldl insert create h + diff --git a/Data/Indexation/UUID.hs b/Data/Indexation/UUID.hs new file mode 100644 --- /dev/null +++ b/Data/Indexation/UUID.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, TypeFamilies, GeneralizedNewtypeDeriving #-} +module Data.Indexation.UUID where + +import Data.UUID (fromString) +import Data.UUID.V4 (nextRandom) +import qualified Data.UUID as U +import Data.SafeCopy +import Data.Text (unpack, Text) +import qualified Data.Text as T +import Control.Applicative ((<$>)) +import Web.PathPieces +import Data.Aeson +import qualified Data.Aeson as Aeson +import Text.Blaze(ToMarkup(..)) +import Data.Bits (shiftR, (.&.), (.|.), shiftL) +import Control.Monad (mzero) +import Data.Char (intToDigit, isHexDigit, digitToInt) +import Data.Word(Word32) +-- Imports for deriving +import Data.Data +import Data.Hashable +import Control.DeepSeq (NFData(..)) +import Foreign.Storable +import Data.Serialize +import Data.ByteString.Lazy (ByteString) + +newtype UUID = UUID U.UUID + deriving(Ord, Eq, Data, Typeable, Storable, NFData, Show, Read) + +rndUUID :: IO UUID +rndUUID = nextRandom >>= return . UUID + +unUUID :: UUID -> U.UUID +unUUID (UUID u) = u + +nil :: UUID +nil = UUID U.nil + +fromLazyASCIIBytes :: ByteString -> Maybe UUID +fromLazyASCIIBytes bs = UUID `fmap` U.fromLazyASCIIBytes bs + +toLazyASCIIBytes :: UUID -> ByteString +toLazyASCIIBytes (UUID u) = U.toLazyASCIIBytes u + +toText :: UUID -> Text +toText = txtUUID + +fromText :: Text -> Maybe UUID +fromText = uuidTxt + +fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID +fromWords w1 w2 w3 w4 = UUID (U.fromWords w1 w2 w3 w4) + +toWords :: UUID -> (Word32, Word32, Word32, Word32) +toWords (UUID u) = U.toWords u + +txtUUID :: UUID -> Text +txtUUID (UUID u) = uuidToText (U.toWords u) + where + uuidToText :: (Word32, Word32, Word32, Word32) -> Text + uuidToText (w0, w1, w2, w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 T.empty + hexw :: Word32 -> Text -> Text + hexw w s = hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16 + `T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s + + hexw' :: Word32 -> Text -> Text + hexw' w s = '-' `T.cons` hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16 + `T.cons` '-' `T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s + + hexn :: Word32 -> Int -> Char + hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf) + +uuidTxt :: Text -> Maybe UUID +uuidTxt t0 = do + (w0, t1) <- hexWord t0 + (w1, t2) <- hexWord t1 + (w2, t3) <- hexWord t2 + (w3, t4) <- hexWord t3 + if T.null t4 + then Just $ UUID $ U.fromWords w0 w1 w2 w3 + else Nothing + where hexWord :: Text -> Maybe (Word32, Text) + hexWord s = Just (0, s) >>= hexByte >>= hexByte + >>= hexByte >>= hexByte + + hexByte :: (Word32, Text) -> Maybe (Word32, Text) + hexByte (w, txt) = if T.null txt then Nothing else + if T.head txt == '-' + then hexByte (w, T.tail txt) + else let hi = T.head txt + lo = T.head $ T.tail txt + ds = T.tail $ T.tail txt + bothHex = isHexDigit hi && isHexDigit lo + octet = fromIntegral (16 * digitToInt hi + digitToInt lo) + in if bothHex then Just ((w `shiftL` 8) .|. octet, ds) + else Nothing + +instance Hashable UUID where + hash (UUID u) = hash u + hashWithSalt s (UUID u) = hashWithSalt s u + +instance SafeCopy UUID where + putCopy (UUID u) = contain $ safePut $ U.toWords u + getCopy = contain $ (UUID . (\(a,b,c,d) -> U.fromWords a b c d) <$> safeGet) + +instance PathPiece UUID where + fromPathPiece t = UUID <$> (fromString $ unpack t) + toPathPiece = txtUUID + +instance ToMarkup UUID where + toMarkup u = toMarkup $ txtUUID u + +instance ToJSON UUID where + toJSON u = Aeson.String (txtUUID u) +instance FromJSON UUID where + parseJSON (Aeson.String s) = case fromString (T.unpack s) of + Just u -> return $ UUID u + Nothing -> mzero + parseJSON _ = mzero + +instance Serialize UUID where + put (UUID u) = put $ U.toWords u + get = (UUID . (\(w1,w2,w3,w4) -> U.fromWords w1 w2 w3 w4)) `fmap` get + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, HugoDaniel + +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 HugoDaniel 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/hblock.cabal b/hblock.cabal new file mode 100644 --- /dev/null +++ b/hblock.cabal @@ -0,0 +1,46 @@ +-- Initial hblock.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hblock +version: 0.1.0.0 +synopsis: A mutable vector that provides indexation on the datatype fields it stores +-- description: +license: BSD3 +license-file: LICENSE +author: HugoDaniel +maintainer: mr.hugo.gomes@gmail.com +-- copyright: +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.HBlock + , Data.Indexation.SimpleIx + , Data.Indexation.NormalIx + , Data.Indexation.Constraints + , Data.Indexation.UUID + -- other-modules: + other-extensions: BangPatterns + , TypeFamilies + , RankNTypes + , DeriveDataTypeable + , GeneralizedNewtypeDeriving + ghc-options: -Wall -O2 + build-depends: base >=4.6 && <4.7 + , vector >=0.10 && <0.11 + , containers >=0.5 && <0.6 + , safecopy >=0.8 && <0.9 + , unordered-containers >=0.2 && <0.3 + , hashable >=1.2 && <1.3 + , uuid >=1.3.3 + , blaze-markup + , path-pieces + , text + , aeson + , deepseq + , cereal + , bytestring + -- hs-source-dirs: + default-language: Haskell2010