packages feed

PrimitiveArray 0.6.1.0 → 0.10.1.1

raw patch · 32 files changed

Files

Data/PrimitiveArray.hs view
@@ -1,13 +1,11 @@ -module Data.PrimitiveArray +module Data.PrimitiveArray   ( module Data.PrimitiveArray.Class   , module Data.PrimitiveArray.Dense-  , module Data.PrimitiveArray.FillTables   , module Data.PrimitiveArray.Index   ) where  import Data.PrimitiveArray.Class import Data.PrimitiveArray.Dense-import Data.PrimitiveArray.FillTables import Data.PrimitiveArray.Index
+ Data/PrimitiveArray/Checked.hs view
@@ -0,0 +1,29 @@++-- | This module exports everything that @Data.PrimitiveArray@ exports, but+-- it will do some bounds-checking on certain operations.+--+-- Checked are: @(!)@++module Data.PrimitiveArray.Checked+  ( module Data.PrimitiveArray+  , (!)+  ) where++import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray hiding ((!))++-- | Bounds-checked version of indexing.+--+-- First, we check via @inBounds@, second we check if the linear index is+-- outside of the allocated area.++--(!) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> elm+(!) arr@(Dense h v) idx+  | not (inBounds (upperBound arr) idx) = error $ "(!) / inBounds: out of bounds! " ++ show (h,idx)+  | li < 0 || li >= len = error $ "(!) / linearIndex: out of bounds! " ++ show (h,li,len,idx)+  | otherwise = unsafeIndex arr idx+  where li  = linearIndex h idx+        len = VG.length v+{-# Inline (!) #-}+
Data/PrimitiveArray/Class.hs view
@@ -1,22 +1,29 @@ --- | Vastly extended primitive arrays. Some basic ideas are now modeled after--- the vector package, especially the monadic mutable / pure immutable array--- system.+-- | Vastly extended primitive arrays. Some basic ideas are now modeled after the vector package,+-- especially the monadic mutable / pure immutable array system. ----- NOTE all operations in MPrimArrayOps and PrimArrayOps are highly unsafe. No--- bounds-checking is performed at all.+-- Note that in general only bulk operations should error out, error handling for index/read/write+-- is too costly. General usage should be to create data structures and run the DP code within an+-- error monad, but keep error handling to high-level operations.  module Data.PrimitiveArray.Class where  import           Control.Applicative (Applicative, pure, (<$>), (<*>)) import           Control.Exception (assert)+import           Control.Monad.Except import           Control.Monad (forM_)-import           Control.Monad.Primitive (PrimMonad)+import           Control.Monad.Primitive (PrimMonad, liftPrim) import           Control.Monad.ST (runST)+import           Data.Proxy+import           Data.Vector.Fusion.Util+import           Debug.Trace+import           GHC.Generics (Generic) import           Prelude as P-import qualified Data.Vector.Fusion.Stream as S+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import           GHC.Stack+import           Data.Kind (Constraint) -import Data.PrimitiveArray.Index+import           Data.PrimitiveArray.Index.Class   @@ -24,87 +31,123 @@  data family MutArr (m :: * -> *) (arr :: *) :: * +-- | Associate a fill structure with each type of array (dense, sparse, ...).+--+-- Example: @type instance FillStruc (Sparse w v sh e) = (w sh)@ associates the type @(w sh)@, which+-- is of the same type as the underlying @w@ structure holding index information for a sparse array. --- | The core set of operations for monadic arrays.+type family FillStruc arr :: * -class (Index sh) => MPrimArrayOps arr sh elm where -  -- | Return the bounds of the array. All bounds are inclusive, as in-  -- @[lb..ub]@ -  boundsM :: MutArr m (arr sh elm) -> (sh,sh)+-- | The core set of operations for pure and monadic arrays. -  -- | Given lower and upper bounds and a list of /all/ elements, produce a-  -- mutable array.+class (Index sh) => PrimArrayOps arr sh elm where -  fromListM :: PrimMonad m => sh -> sh -> [elm] -> m (MutArr m (arr sh elm))+  -- ** Pure operations -  -- | Creates a new array with the given bounds with each element within the-  -- array being in an undefined state.+  -- | Returns the bounds of an immutable array, again inclusive bounds: @ [lb..ub] @.+  upperBound :: arr sh elm -> LimitType sh -  newM :: PrimMonad m => sh -> sh -> m (MutArr m (arr sh elm))+  -- | Extract a single element from the array. Generally unsafe as not bounds-checking is+  -- performed.+  unsafeIndex :: arr sh elm -> sh -> elm -  -- | Creates a new array with all elements being equal to 'elm'.+  -- | Index into immutable array, but safe in case @sh@ is not part of the array.+  safeIndex :: arr sh elm -> sh -> Maybe elm -  newWithM :: PrimMonad m => sh -> sh -> elm -> m (MutArr m (arr sh elm))+  -- | Savely transform the shape space of a table.+  transformShape :: Index sh' => (LimitType sh -> LimitType sh') -> arr sh elm -> arr sh' elm -  -- | Reads a single element in the array.+  -- ** Monadic operations -  readM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> m elm+  -- | Return the bounds of the array. All bounds are inclusive, as in @[lb..ub]@. Technically not+  -- monadic, but rather working on a monadic array.+  upperBoundM :: MutArr m (arr sh elm) -> LimitType sh -  -- | Writes a single element in the array.+  -- | Given lower and upper bounds and a list of /all/ elements, produce a mutable array.+  fromListM :: PrimMonad m => LimitType sh -> [elm] -> m (MutArr m (arr sh elm)) -  writeM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> elm -> m ()+  -- | Creates a new array with the given bounds with each element within the array being in an+  -- undefined state.+  newM :: PrimMonad m => LimitType sh -> m (MutArr m (arr sh elm)) +  -- | Variant of 'newM' that requires a fill structure. Mostly for special / sparse structures+  -- (hence the @S@, also to be interpreted as "safe", since these functions won't fail with sparse+  -- structures).+  newSM :: (Monad m, PrimMonad m) => LimitType sh -> FillStruc (arr sh elm) -> m (MutArr m (arr sh elm)) +  -- | Creates a new array with all elements being equal to 'elm'.+  newWithM :: PrimMonad m => LimitType sh -> elm -> m (MutArr m (arr sh elm)) --- | The core set of functions on immutable arrays.+  -- | Variant of 'newWithM'+  newWithSM :: (Monad m, PrimMonad m) => LimitType sh -> FillStruc (arr sh elm) -> elm -> m (MutArr m (arr sh elm)) -class (Index sh) => PrimArrayOps arr sh elm where+  -- | Reads a single element in the array.+  readM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> m elm -  -- | Returns the bounds of an immutable array, again inclusive bounds: @ [lb..ub] @.+  -- | Read from the mutable array, but return @Nothing@ in case @sh@ does not exist. This will+  -- allow streaming DP combinators to "jump" over missing elements.+  --+  -- Should be used with @Stream.Monadic.mapMaybe@ to get efficient code.+  safeReadM :: (Monad m, PrimMonad m) => MutArr m (arr sh elm) -> sh -> m (Maybe elm) -  bounds :: arr sh elm -> (sh,sh)+  -- | Writes a single element in the array.+  writeM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> elm -> m () -  -- | Freezes a mutable array an returns its immutable version. This operation-  -- is /O(1)/ and both arrays share the same memory. Do not use the mutable-  -- array afterwards.+  -- | Write into the mutable array, but if the index @sh@ does not exist, silently continue.+  safeWriteM :: (Monad m, PrimMonad m) => MutArr m (arr sh elm) -> sh -> elm -> m () -  unsafeFreeze :: PrimMonad m => MutArr m (arr sh elm) -> m (arr sh elm)+  -- | Freezes a mutable array an returns its immutable version. This operation is /O(1)/ and both+  -- arrays share the same memory. Do not use the mutable array afterwards.+  unsafeFreezeM :: PrimMonad m => MutArr m (arr sh elm) -> m (arr sh elm) -  -- | Thaw an immutable array into a mutable one. Both versions share-  -- memory.+  -- | Thaw an immutable array into a mutable one. Both versions share memory.+  unsafeThawM :: PrimMonad m => arr sh elm -> m (MutArr m (arr sh elm)) -  unsafeThaw :: PrimMonad m => arr sh elm -> m (MutArr m (arr sh elm)) -  -- | Extract a single element from the array. Generally unsafe as not-  -- bounds-checking is performed.+class PrimArrayMap arr sh e e' where+  -- -- | Map a function of type @elm -> e@ over the primitive array, returning another primitive array+  -- -- of same type and shape but different element.+  mapArray :: (e -> e') -> arr sh e -> arr sh e' -  unsafeIndex :: arr sh elm -> sh -> elm -  -- | Savely transform the shape space of a table.+-- | Sum type of errors that can happen when using primitive arrays. -  transformShape :: (Index sh') => (sh -> sh') -> arr sh elm -> arr sh' elm+data PAErrors+  = PAEUpperBound+  deriving stock (Eq,Generic) -class (Index sh) => PrimArrayMap arr sh e e' where+instance Show PAErrors where+  show (PAEUpperBound) = "Upper bound is too large for @Int@ size!" -  -- | Map a function over each element, keeping the shape intact. -  map :: (e -> e') -> arr sh e -> arr sh e' +-- | Infix index operator. Performs minimal bounds-checking using assert in non-optimized code.+--+-- @(!)@ is rewritten from phase @[1]@ onwards into an optimized form. Before, it uses a very slow+-- form, that does bounds checking. +--(!) :: (HasCallStack, PrimArrayOps arr sh elm) => arr sh elm -> sh -> elm+(!) :: (PrimArrayOps arr sh elm) => arr sh elm -> sh -> elm+{-# Inline [1] (!) #-}+{-# Rules "unsafeIndex" [2] (!) = unsafeIndex #-}+(!) = \arr idx -> case safeIndex arr idx of+          Nothing -> error $ show (showBound (upperBound arr), showIndex idx)+          Just v  -> v --- | Infix index operator. Performs minimal bounds-checking using assert in--- non-optimized code. -(!) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> elm-(!) arr idx = assert (uncurry inBounds (bounds arr) idx) $ unsafeIndex arr idx-{-# INLINE (!) #-} +-- | Return value at an index that might not exist.++(!?) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> Maybe elm+{-# Inline (!?) #-}+(!?) = safeIndex+ -- | Returns true if the index is valid for the array. -inBoundsM :: (Monad m, MPrimArrayOps arr sh elm) => MutArr m (arr sh elm) -> sh -> Bool-inBoundsM marr idx = let (lb,ub) = boundsM marr in inBounds lb ub idx+inBoundsM :: (Monad m, PrimArrayOps arr sh elm) => MutArr m (arr sh elm) -> sh -> Bool+inBoundsM marr idx = inBounds (upperBoundM marr) idx {-# INLINE inBoundsM #-}  -- -- | Given two arrays with the same dimensionality, their respective starting@@ -125,33 +168,83 @@ -- default element, and a list of associations.  fromAssocsM-  :: (PrimMonad m, MPrimArrayOps arr sh elm)-  => sh -> sh -> elm -> [(sh,elm)] -> m (MutArr m (arr sh elm))-fromAssocsM lb ub def xs = do-  ma <- newWithM lb ub def+  :: (PrimMonad m, PrimArrayOps arr sh elm)+  => LimitType sh -> elm -> [(sh,elm)] -> m (MutArr m (arr sh elm))+fromAssocsM ub def xs = do+  ma <- newWithM ub def+--  let s = size ub+--  traceShow (s,length xs) $ when (s < length xs) $ error "bang"   forM_ xs $ \(k,v) -> writeM ma k v   return ma {-# INLINE fromAssocsM #-} +-- | Initialize an immutable array but stay within the primitive monad @m@.++newWithPA+  :: (PrimMonad m, PrimArrayOps arr sh elm)+  => LimitType sh+  -> elm+  -> m (arr sh elm)+newWithPA ub def = do+  ma ← newWithM ub def+  unsafeFreezeM ma+{-# Inlinable newWithPA #-}++-- | Initialize an immutable array with a fill structure.++newWithSPA+  ∷ (PrimMonad m, PrimArrayOps arr sh elm)+  ⇒ LimitType sh+  -> FillStruc (arr sh elm)+  → elm+  → m (arr sh elm)+{-# Inlinable newWithSPA #-}+newWithSPA ub xs def = do+  ma ← newWithSM ub xs def+  unsafeFreezeM ma++-- | Safely prepare a primitive array.+--+-- TODO Check if having a 'MonadError' instance degrades performance. (We+-- should see this once the test with NeedlemanWunsch is under way).++safeNewWithPA+  :: forall m arr sh elm+  . (PrimMonad m, MonadError PAErrors m, PrimArrayOps arr sh elm)+  => LimitType sh+  -> elm+  -> m (arr sh elm)+safeNewWithPA ub def = do+  case runExcept $ sizeIsValid maxBound [totalSize ub] of+    Left  (SizeError _) -> throwError PAEUpperBound+    Right (CellSize  _) -> newWithPA ub def+{-# Inlinable safeNewWithPA #-}++ -- | Return all associations from an array. -assocs :: (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [(sh,elm)]-assocs arr = P.map (\k -> (k,unsafeIndex arr k)) . S.toList $ streamUp lb ub where-  (lb,ub) = bounds arr+assocs :: forall arr sh elm . (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [(sh,elm)]+assocs arr = unId . SM.toList $ assocsS arr {-# INLINE assocs #-} +-- | Return all associations from an array.++assocsS :: forall m arr sh elm . (Monad m, IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> SM.Stream m (sh,elm)+assocsS arr = SM.map (\k -> (k,unsafeIndex arr k)) $ streamUp zeroBound' (upperBound arr)+{-# INLINE assocsS #-}+ -- | Creates an immutable array from lower and upper bounds and a complete list -- of elements. -fromList :: (PrimArrayOps arr sh elm, MPrimArrayOps arr sh elm) => sh -> sh -> [elm] -> arr sh elm-fromList lb ub xs = runST $ fromListM lb ub xs >>= unsafeFreeze+fromList :: (PrimArrayOps arr sh elm) => LimitType sh -> [elm] -> arr sh elm+fromList ub xs = runST $ fromListM ub xs >>= unsafeFreezeM {-# INLINE fromList #-}  -- | Creates an immutable array from lower and upper bounds, a default element, -- and a list of associations. -fromAssocs :: (PrimArrayOps arr sh elm, MPrimArrayOps arr sh elm) => sh -> sh -> elm -> [(sh,elm)] -> arr sh elm-fromAssocs lb ub def xs = runST $ fromAssocsM lb ub def xs >>= unsafeFreeze+fromAssocs :: (PrimArrayOps arr sh elm) => LimitType sh -> elm -> [(sh,elm)] -> arr sh elm+fromAssocs ub def xs = runST $ fromAssocsM ub def xs >>= unsafeFreezeM {-# INLINE fromAssocs #-}  -- -- | Determines if an index is valid for a given immutable array.@@ -162,12 +255,14 @@  -- | Returns all elements of an immutable array as a list. -toList :: (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [elm]-toList arr = let (lb,ub) = bounds arr in P.map ((!) arr) . S.toList $ streamUp lb ub+toList :: forall arr sh elm . (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [elm]+toList arr = let ub = upperBound arr in P.map ((!) arr) . unId . SM.toList $ streamUp zeroBound' ub {-# INLINE toList #-}   +{-+ -- * Freeze an inductive stack of tables with a 'Z' at the bottom.  -- | 'freezeTables' freezes a stack of tables.@@ -183,6 +278,8 @@  instance (Functor m, Applicative m, Monad m, PrimMonad m, FreezeTables m ts, PrimArrayOps arr sh elm) => FreezeTables m (ts:.MutArr m (arr sh elm)) where     type Frozen (ts:.MutArr m (arr sh elm)) = Frozen ts :. arr sh elm-    freezeTables (ts:.t) = (:.) <$> freezeTables ts <*> unsafeFreeze t+    freezeTables (ts:.t) = (:.) <$> freezeTables ts <*> unsafeFreezeM t     {-# INLINE freezeTables #-}++-}
Data/PrimitiveArray/Dense.hs view
@@ -10,150 +10,157 @@ -- TODO consider if we want to force the lower index to be zero, or allow -- non-zero lower indices. Will have to be considered together with the -- @Index.Class@ module!+--+-- TODO while @Unboxed@ is, in princile, @Hashable@, we'd need the+-- corresponding @VU.Vector@ instances ...+--+-- TODO rename to Dense.Vector, since there are other possibilities to store,+-- without basing on vector.  module Data.PrimitiveArray.Dense where +import           Control.Lens (makeLenses) import           Control.DeepSeq import           Control.Exception (assert)-import           Control.Monad (liftM, forM_, zipWithM_)+import           Control.Monad (liftM, forM_, zipWithM_, when) import           Control.Monad.Primitive (PrimState) import           Data.Aeson (ToJSON,FromJSON) import           Data.Binary (Binary)+import           Data.Data+import           Data.Hashable (Hashable) import           Data.Serialize (Serialize)+import           Data.Typeable (Typeable) import           Data.Vector.Binary-import           Data.Vector.Cereal import           Data.Vector.Generic.Mutable as GM hiding (length)-import           Data.Vector.Unboxed.Mutable (Unbox)+import           Data.Vector.Serialize+import           Debug.Trace import           GHC.Generics (Generic)-import qualified Data.Vector as V hiding (forM_, length, zipWithM_)-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed as VU hiding (forM_, length, zipWithM_)-+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU  import           Data.PrimitiveArray.Class-import           Data.PrimitiveArray.Index+import           Data.PrimitiveArray.Index.Class   --- * Unboxed, multidimensional arrays.+data Dense v sh e = Dense { _denseLimit :: !(LimitType sh), _denseV :: !(v e) }+makeLenses ''Dense -data Unboxed sh e = Unboxed !sh !sh !(VU.Vector e)-  deriving (Read,Show,Eq,Generic)+type Unboxed sh e = Dense VU.Vector sh e -instance (Binary    sh, Binary    e, Unbox e) => Binary    (Unboxed sh e)-instance (Serialize sh, Serialize e, Unbox e) => Serialize (Unboxed sh e)-instance (ToJSON    sh, ToJSON    e, Unbox e) => ToJSON    (Unboxed sh e)-instance (FromJSON  sh, FromJSON  e, Unbox e) => FromJSON  (Unboxed sh e)+type Storable sh e = Dense VS.Vector sh e -instance (NFData sh) => NFData (Unboxed sh e) where-  rnf (Unboxed l h xs) = rnf l `seq` rnf h `seq` rnf xs-  {-# Inline rnf #-}+type Boxed sh e = Dense V.Vector sh e -data instance MutArr m (Unboxed sh e) = MUnboxed !sh !sh !(VU.MVector (PrimState m) e) -instance (NFData sh) => NFData (MutArr m (Unboxed sh e)) where-  rnf (MUnboxed l h xs) = rnf l `seq` rnf h `seq` rnf xs-  {-# Inline rnf #-} -instance (Index sh, Unbox elm) => MPrimArrayOps Unboxed sh elm where-  boundsM (MUnboxed l h _) = (l,h)-  fromListM l h xs = do-    ma <- newM l h-    let (MUnboxed _ _ mba) = ma-    zipWithM_ (\k x -> assert (length xs == size l h) $ unsafeWrite mba k x) [0.. size l h -1] xs-    return ma-  newM l h = MUnboxed l h `liftM` new (size l h)-  newWithM l h def = do-    ma <- newM l h-    let (MUnboxed _ _ mba) = ma-    forM_ [0 .. size l h -1] $ \k -> unsafeWrite mba k def-    return ma-  readM  (MUnboxed l h mba) idx     = assert (inBounds l h idx) $ unsafeRead  mba (linearIndex l h idx)-  writeM (MUnboxed l h mba) idx elm = write mba (linearIndex l h idx) elm-  {-# INLINE boundsM #-}-  {-# INLINE fromListM #-}-  {-# INLINE newM #-}-  {-# INLINE newWithM #-}-  {-# INLINE readM #-}-  {-# INLINE writeM #-}+deriving instance (Eq      (LimitType sh), Eq (v e)     ) => Eq      (Dense v sh e)+deriving instance (Generic (LimitType sh), Generic (v e)) => Generic (Dense v sh e)+deriving instance (Read    (LimitType sh), Read (v e)   ) => Read    (Dense v sh e)+deriving instance (Show    (LimitType sh), Show (v e)   ) => Show    (Dense v sh e)+deriving instance (Functor v)                             => Functor (Dense v sh) -instance (Index sh, Unbox elm) => PrimArrayOps Unboxed sh elm where-  bounds (Unboxed l h _) = (l,h)-  unsafeFreeze (MUnboxed l h mba) = Unboxed l h `liftM` G.unsafeFreeze mba-  unsafeThaw   (Unboxed  l h ba) = MUnboxed l h `liftM` G.unsafeThaw ba-  unsafeIndex  (Unboxed  l h ba) idx = {- assert (inShape exUb idx) $ -} G.unsafeIndex ba (linearIndex l h idx)-  transformShape tr (Unboxed l h ba) = Unboxed (tr l) (tr h) ba-  {-# INLINE bounds #-}-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw #-}-  {-# INLINE unsafeIndex #-}-  {-# INLINE transformShape #-}+deriving instance Typeable (Dense v sh e) -instance (Index sh, Unbox e, Unbox e') => PrimArrayMap Unboxed sh e e' where-  map f (Unboxed l h xs) = Unboxed l h (VU.map f xs)-  {-# INLINE map #-}+deriving instance (Data (v e), Data (LimitType sh), Data e, Data sh, Typeable sh, Typeable e, Typeable v) => Data (Dense v sh e) +instance (Binary    (LimitType sh), Binary    (v e), Generic (LimitType sh), Generic (v e)) => Binary    (Dense v sh e)+instance (Serialize (LimitType sh), Serialize (v e), Generic (LimitType sh), Generic (v e)) => Serialize (Dense v sh e)+instance (ToJSON    (LimitType sh), ToJSON    (v e), Generic (LimitType sh), Generic (v e)) => ToJSON    (Dense v sh e)+instance (FromJSON  (LimitType sh), FromJSON  (v e), Generic (LimitType sh), Generic (v e)) => FromJSON  (Dense v sh e)+instance (Hashable  (LimitType sh), Hashable  (v e), Generic (LimitType sh), Generic (v e)) => Hashable  (Dense v sh e) +instance (NFData (LimitType sh), NFData (v e)) ⇒ NFData (Dense v sh e) where+  rnf (Dense h xs) = rnf h `seq` rnf xs+  {-# Inline rnf #-} --- * Boxed, multidimensional arrays. -data Boxed sh e = Boxed !sh !sh !(V.Vector e)-  deriving (Read,Show,Eq,Generic) -instance (Binary    sh, Binary    e)  => Binary    (Boxed sh e)-instance (Serialize sh, Serialize e)  => Serialize (Boxed sh e)-instance (ToJSON    sh, ToJSON    e)  => ToJSON    (Boxed sh e)-instance (FromJSON  sh, FromJSON  e)  => FromJSON  (Boxed sh e)+data instance MutArr m (Dense v sh e) = MDense !(LimitType sh) !(VG.Mutable v (PrimState m) e)+  deriving (Generic,Typeable) -instance (NFData sh, NFData e) => NFData (Boxed sh e) where-  rnf (Boxed l h xs) = rnf l `seq` rnf h `seq` rnf xs+instance (Show (LimitType sh), Show (VG.Mutable v (PrimState m) e), VG.Mutable v (PrimState m) e ~ mv) ⇒ Show (MutArr m (Dense v sh e)) where+  show (MDense sh mv) = show (sh,mv)++instance (NFData (LimitType sh), NFData (VG.Mutable v (PrimState m) e), VG.Mutable v (PrimState m) e ~ mv) ⇒ NFData (MutArr m (Dense v sh e)) where+  rnf (MDense h xs) = rnf h `seq` rnf xs   {-# Inline rnf #-} -data instance MutArr m (Boxed sh e) = MBoxed !sh !sh !(V.MVector (PrimState m) e)+{-+instance+  ( Index sh, MutArr m (Dense v sh e) ~ mv+  , GM.MVector (VG.Mutable v) e+#if ADPFUSION_DEBUGOUTPUT+  , Show sh, Show (LimitType sh), Show e+#endif+  ) ⇒ MPrimArrayOps (Dense v) sh e where+-} -instance (NFData sh) => NFData (MutArr m (Boxed sh e)) where-  rnf (MBoxed l h _) = rnf l `seq` rnf h -- no rnf for the data !-  {-# Inline rnf #-}+instance+  ( Index sh, VG.Vector v e+#if ADPFUSION_DEBUGOUTPUT+  , Show sh, Show (LimitType sh), Show e+#endif+  ) ⇒ PrimArrayOps (Dense v) sh e where -instance (Index sh) => MPrimArrayOps Boxed sh elm where-  boundsM (MBoxed l h _) = (l,h)-  fromListM l h xs = do-    ma <- newM l h-    let (MBoxed _ _ mba) = ma-    zipWithM_ (\k x -> assert (length xs == size l h) $ unsafeWrite mba k x) [0 .. size l h - 1] xs-    return ma-  newM l h =-    MBoxed l h `liftM` new (size l h)-  newWithM l h def = do-    ma <- newM l h-    let (MBoxed _ _ mba) = ma-    forM_ [0 .. size l h -1] $ \k -> unsafeWrite mba k def-    return ma-  readM  (MBoxed l h mba) idx     = assert (inBounds l h idx) $ GM.unsafeRead mba (linearIndex l h idx)-  writeM (MBoxed l h mba) idx elm = assert (inBounds l h idx) $ GM.write mba (linearIndex l h idx) elm-  {-# INLINE boundsM #-}-  {-# INLINE fromListM #-}-  {-# INLINE newM #-}-  {-# INLINE newWithM #-}-  {-# INLINE readM #-}-  {-# INLINE writeM #-}+  -- ** pure operations -instance (Index sh, Unbox elm) => PrimArrayOps Boxed sh elm where-  bounds (Boxed l h _) = (l,h)-  unsafeFreeze (MBoxed l h mba) = Boxed l h `liftM` G.unsafeFreeze mba-  unsafeThaw   (Boxed l h ba) = MBoxed l h `liftM` G.unsafeThaw ba-  unsafeIndex (Boxed l h ba) idx = {- assert (inShape exUb idx) $ -} G.unsafeIndex ba (linearIndex l h idx)-  transformShape tr (Boxed l h ba) = Boxed (tr l) (tr h) ba-  {-# INLINE bounds #-}-  {-# INLINE unsafeFreeze #-}-  {-# INLINE unsafeThaw #-}-  {-# INLINE unsafeIndex #-}-  {-# INLINE transformShape #-}+  {-# Inline upperBound #-}+  upperBound (Dense h _) = h+  {-# Inline unsafeFreezeM #-}+  unsafeFreezeM (MDense h mba) = Dense h `liftM` VG.unsafeFreeze mba+  {-# Inline unsafeThawM #-}+  unsafeThawM   (Dense h ba) = MDense h `liftM` VG.unsafeThaw ba+  {-# Inline unsafeIndex #-}+  unsafeIndex  (Dense h ba) idx = VG.unsafeIndex ba (linearIndex h idx)+  {-# Inline safeIndex #-}+  safeIndex (Dense h ba) idx = if inBounds h idx then Just $ unsafeIndex (Dense h ba) idx else Nothing+  {-# Inline transformShape #-}+  transformShape tr (Dense h ba) = Dense (tr h) ba -instance (Index sh) => PrimArrayMap Boxed sh e e' where-  map f (Boxed l h xs) = Boxed l h (V.map f xs)-  {-# INLINE map #-}+  -- ** monadic operations +  {-# Inline upperBoundM #-}+  upperBoundM (MDense h _) = h+  {-# Inline fromListM #-}+  fromListM h xs = do+    ma ← newM h+    let (MDense _ mba) = ma+    -- there need to be at least as many elements, as we want to fill. There could be more, in debug+    -- tests, we like to do @[0..]@ and this should not trigger the assert.+    SM.zipWithM_ (\k x → assert (length (Prelude.take (size h) xs) == size h) $ unsafeWrite mba k x) (SM.enumFromTo 0 (size h -1)) (SM.fromList xs)+    return ma+  {-# Inline newM #-}     -- TODO was NoInline, check if anything breaks!+  newM h = MDense h `liftM` new (size h)+  {-# Inline newSM #-}+  newSM = error "not implemented, use newM for dense arrays"+  {-# Inline newWithM #-}+  newWithM h def = do+    ma ← newM h+    let (MDense _ mba) = ma+    GM.set mba def+    return ma+  {-# Inline newWithSM #-}+  newWithSM = error "not implemented, use newWithSM for dense arrays"+  {-# Inline readM #-}+  readM  (MDense h mba) idx     = assert (inBounds h idx) $ unsafeRead  mba (linearIndex h idx)+  {-# Inline safeReadM #-}+  safeReadM dense idx = if inBoundsM dense idx then Just <$> readM dense idx else undefined+  {-# Inline writeM #-}+  writeM (MDense h mba) idx elm =+#if ADPFUSION_DEBUGOUTPUT+    (if inBounds h idx then id else traceShow ("writeM", h, idx, elm, size h, linearIndex h idx, inBounds h idx))+#endif+    assert (inBounds h idx) $ unsafeWrite mba (linearIndex h idx) elm+  {-# Inline safeWriteM #-}+  safeWriteM dense idx elm = when (inBoundsM dense idx) $ writeM dense idx elm++instance (Index sh, VG.Vector v e, VG.Vector v e') ⇒ PrimArrayMap (Dense v) sh e e' where+  {-# Inline mapArray #-}+  mapArray f (Dense h xs) = Dense h (VG.map f xs)   {-
− Data/PrimitiveArray/FillTables.hs 
@@ -1,64 +0,0 @@---- | Operations to fill primitive arrays. Arrays are combined just like--- indices using 'Z' and '(:.)'. This allows filling an unlimited number of--- tables. 'ExtShape' provides the 'rangeStream' function with generates--- a stream of indices in (generally) the right order.--module Data.PrimitiveArray.FillTables where--import Control.Monad.Primitive-import Control.Monad (when)-import Data.Vector.Fusion.Stream as S-import Data.Vector.Fusion.Stream.Monadic as M-import Data.Vector.Fusion.Stream.Size--import Data.PrimitiveArray.Class-import Data.PrimitiveArray.Index------ * High-level table filling system.---- | Run the forward phase of algorithms. Is *really* unsafe for now if--- tables have different sizes, as in its broken.------ TODO Need to run min/max on the bounds for all tables, not just the last--- table. Otherwise we don't really need the distinction between save and--- unsafe. This will have to be in @runFillTables@.--unsafeRunFillTables-  :: ( Index sh, IndexStream sh-     , WriteCell m (tail :. (MutArr m (arr sh elm), t)) sh-     , MPrimArrayOps arr sh elm-     , Monad m-     , PrimMonad m-     )-  => (tail :. (MutArr m (arr sh elm), t)) -> m ()--unsafeRunFillTables (ts:.(t,f)) = M.mapM_ (unsafeWriteCell (ts:.(t,f))) $ streamUp from to where -- generateIndices from to where-  (from,to) = boundsM t -- TODO min/max over all tables [for the safe version, the unsafe version *always* assumes equal-size tables; we still should check this during runtime]-{-# INLINE unsafeRunFillTables #-}------ * Write to individuel cells.---- | 'WriteCell' provides methods to fill all cells with a specific index--- @sh@ in a stack of non-terminal tables @c@.--class (Monad m) => WriteCell m c sh where-    unsafeWriteCell :: c -> sh -> m ()-    writeCell       :: c -> sh -> m ()--instance (Monad m) => WriteCell m Z sh where-    unsafeWriteCell _ _ = return ()-    writeCell _ _ = return ()-    {-# INLINE unsafeWriteCell #-}-    {-# INLINE writeCell #-}--instance (WriteCell m cs sh, Monad m, MPrimArrayOps arr sh a, PrimMonad m) => WriteCell m (cs:.(MutArr m (arr sh a), sh -> m a)) sh where-    unsafeWriteCell (cs:.(t,f)) sh = unsafeWriteCell cs sh >> (f sh >>= writeM t sh)-    writeCell (cs:.(t,f)) sh = writeCell cs sh >> (when (inBoundsM t sh) (f sh >>= writeM t sh))-    {-# INLINE unsafeWriteCell #-}-    {-# INLINE writeCell #-}-
+ Data/PrimitiveArray/HashTable.hs view
@@ -0,0 +1,64 @@++-- | A table representation that internally uses a hashtable from the @hashtables@ library. The+-- implementation is currently a testbed on which idea makes the most sense.+--+-- In particular, once a hashtable has been created with, say, @newWithPA@, it will be completely+-- void of any entries. To prime the system, call @setValidKeys@ which will setup all keys that are+-- vaild, as well as setup an additional data structure to help with @streamUp@ and @streamDown@.+--+-- This table does not store default values, since it is assumed that lookups are only done on valid+-- keys, and @ADPfusion@ as the default consumer should have rules "jump over" missing keys.+--+-- Currently the idea is that any write to an undeclared key will just fail SILENTLY!+--+-- TODO this also forces rethinking @inBounds@, as this will now depend on the internal structure+-- given via @setValidKeys@.++module Data.PrimitiveArray.HashTable where++import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad.ST.Unsafe+import Data.HashTable.Class as HT+import Data.HashTable.IO as HTIO+import Unsafe.Coerce++import Data.PrimitiveArray.Class+import Data.PrimitiveArray.Index.Class++++data Hashed ht sh e = Hashed+  { _hashedUpperBound :: !(LimitType sh)+    -- ^ Explicitly store the upper bound.+  , _hashedTable      :: !(IOHashTable ht sh e)+    -- ^ The hashtable to be updated / used.+  , _hashedUpDown     :: !()+    -- ^ Helper structure for the @streamUp@ / @streamDown@ functionality.+    --+    -- TODO this should be a recursively constructed hashtable, based on the shape of @sh@.+  }++++-- | Sets valid keys, working within a primitive Monad. The valid keys should be a hashtable with+-- all correct keys, but values set to something resembling a default value. A good choice will be+-- akin to @mzero@.+--+-- Internally, this function uses @unsafeCoerce@ to change the @PrimState@ token held by the hash+-- table to @RealWord@, from whatever it is.+--+-- TODO setup the @hashedUpDown@ part, once it is clear what to do.++setValidKeys+  :: (PrimMonad m, HashTable h)+  => LimitType sh+  -> h (PrimState m) k v+  -> m (Hashed ht sh e)+{-# Inline setValidKeys #-}+setValidKeys ub ks = return $ Hashed+    { _hashedUpperBound = ub+    , _hashedTable      = unsafeCoerce ks+    , _hashedUpDown     = ()+    }+
Data/PrimitiveArray/Index.hs view
@@ -1,21 +1,29 @@  module Data.PrimitiveArray.Index   ( module Data.PrimitiveArray.Index.Class-  , module Data.PrimitiveArray.Index.Complement+  , module Data.PrimitiveArray.Index.BitSet0+  , module Data.PrimitiveArray.Index.BitSet1+  , module Data.PrimitiveArray.Index.BitSetClasses+--  , module Data.PrimitiveArray.Index.EdgeBoundary   , module Data.PrimitiveArray.Index.Int-  , module Data.PrimitiveArray.Index.Outside+  , module Data.PrimitiveArray.Index.IOC   , module Data.PrimitiveArray.Index.PhantomInt   , module Data.PrimitiveArray.Index.Point-  , module Data.PrimitiveArray.Index.Set+--  , module Data.PrimitiveArray.Index.Set   , module Data.PrimitiveArray.Index.Subword+  , module Data.PrimitiveArray.Index.Unit   ) where  import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Index.Complement+--import Data.PrimitiveArray.Index.EdgeBoundary hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep) import Data.PrimitiveArray.Index.Int-import Data.PrimitiveArray.Index.Outside-import Data.PrimitiveArray.Index.PhantomInt-import Data.PrimitiveArray.Index.Point-import Data.PrimitiveArray.Index.Set-import Data.PrimitiveArray.Index.Subword+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.PhantomInt hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+import Data.PrimitiveArray.Index.Point hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+--import Data.PrimitiveArray.Index.Set hiding (streamUpBsMk, streamUpBsStep, streamDownBsMk, StreamDownBsStep, streamUpBsIMk, streamUpBsIStep, streamDownBsIMk, StreamDownBsIStep, streamUpBsIiMk, streamUpBsIiStep, streamDownBsIiMk, StreamDownBsIiStep)+import Data.PrimitiveArray.Index.BitSet1 hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+import Data.PrimitiveArray.Index.BitSet0 hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+import Data.PrimitiveArray.Index.BitSetClasses+import Data.PrimitiveArray.Index.Subword hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+import Data.PrimitiveArray.Index.Unit
+ Data/PrimitiveArray/Index/BitSet0.hs view
@@ -0,0 +1,144 @@++-- | The most basic bitset structure. Alone, not particularly useful, because+-- two sets @{u,v},{v',w}@ have no way of annotating the connection between the+-- sets. Together with boundaries this yields sets for useful DP algorithms.++module Data.PrimitiveArray.Index.BitSet0 where++import           Control.DeepSeq (NFData(..))+import           Control.Lens (makeLenses)+import           Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey)+import           Data.Binary (Binary)+import           Data.Bits+import           Data.Bits.Extras+import           Data.Hashable (Hashable)+import           Data.Serialize (Serialize)+import           Data.Vector.Unboxed.Deriving+import           Data.Vector.Unboxed (Unbox(..))+import           Debug.Trace+import           GHC.Generics (Generic)+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import           Test.QuickCheck++import           Data.Bits.Ordered+import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.IOC+import           Data.PrimitiveArray.Index.BitSetClasses++++-- | Newtype for a bitset.+--+-- @Int@ integrates better with the rest of the framework. But we should+-- consider moving to @Word@-based indexing, if possible.++newtype BitSet t = BitSet { _bitSet :: Int }+  deriving stock (Eq,Ord,Generic)+  deriving newtype (FiniteBits,Ranked,Num,Bits)+makeLenses ''BitSet++instance FromJSON     (BitSet t)+instance FromJSONKey  (BitSet t)+instance ToJSON       (BitSet t)+instance ToJSONKey    (BitSet t)+instance Binary       (BitSet t)+instance Serialize    (BitSet t)+instance Hashable     (BitSet t)++derivingUnbox "BitSet"+  [t| forall t . BitSet t → Int |]+  [| \(BitSet s) → s            |]+  [| BitSet                     |]++instance Show (BitSet t) where+  show (BitSet s) = "<" ++ (show $ activeBitsL s) ++ ">(" ++ show s ++ ")"++instance NFData (BitSet t) where+  rnf (BitSet s) = rnf s+  {-# Inline rnf #-}++instance Index (BitSet t) where+  newtype LimitType (BitSet t) = LtBitSet Int+  linearIndex _ (BitSet z) = z+  {-# Inline linearIndex #-}+  size (LtBitSet pc) = 2 ^ pc -- 2 ^ popCount h - 2 ^ popCount l + 1+  {-# Inline size #-}+  inBounds (LtBitSet h) z = popCount z <= h+  {-# Inline inBounds #-}+  zeroBound = BitSet 0+  {-# Inline zeroBound #-}+  zeroBound' = LtBitSet 0+  {-# Inline zeroBound' #-}+  totalSize (LtBitSet n) = [2 ^ fromIntegral n]+  {-# Inline totalSize #-}+  fromLinearIndex _ = BitSet+  {-# Inline [0] fromLinearIndex #-}+  showBound (LtBitSet b) = ["LtBitSet " ++ show b]+  showIndex (BitSet b) = ["BitSet " ++ show b]++instance SetPredSucc (BitSet t) where+  setSucc l h s+    | cs > ch                        = Nothing+    | Just s' <- popPermutation ch s = Just s'+    | cs >= ch                       = Nothing+    | cs < ch                        = Just . BitSet $ 2^(cs+1) -1+    where ch = popCount h+          cs = popCount s+  {-# Inline setSucc #-}+  setPred l h s+    | cs < cl                        = Nothing+    | Just s' <- popPermutation ch s = Just s'+    | cs <= cl                       = Nothing+    | cs > cl                        = Just . BitSet $ 2^(cs-1) -1+    where cl = popCount l+          ch = popCount h+          cs = popCount s+  {-# Inline setPred #-}++instance IndexStream z => IndexStream (z:.BitSet I) where+  streamUp   (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream z ⇒ IndexStream (z:.BitSet O) where+  streamUp   (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamUp   ls hs+  streamDown (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream z ⇒ IndexStream (z:.BitSet C) where+  streamUp   (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtBitSet l) (hs:..LtBitSet h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream (Z:.BitSet t) ⇒ IndexStream (BitSet t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# Inline streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# Inline streamDown #-}++streamUpMk ∷ Monad m ⇒ Int → Int → t → m (t, Maybe (BitSet ioc))+streamUpMk l h z = return (z, if l <= h then Just (BitSet $ 2^l-1) else Nothing)+{-# Inline [0] streamUpMk #-}++streamUpStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet ioc)) → m (SM.Step (t, Maybe (BitSet ioc)) (t:.BitSet ioc))+streamUpStep l h (z , Nothing) = return $ SM.Done+streamUpStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z, setSucc (2^l-1) (2^h-1) t)+{-# Inline [0] streamUpStep #-}++streamDownMk ∷ Monad m ⇒ Int → Int → t → m (t, Maybe (BitSet ioc))+streamDownMk l h z = return (z, if l <=h then Just (BitSet $ 2^l-1) else Nothing)+{-# Inline [0] streamDownMk #-}++streamDownStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet ioc)) → m (SM.Step (t, Maybe (BitSet ioc)) (t:.BitSet ioc))+streamDownStep l h (z , Nothing) = return $ SM.Done+streamDownStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred (2^l-1) (2^h-1) t)+{-# Inline [0] streamDownStep #-}++instance Arbitrary (BitSet t) where+  arbitrary = BitSet <$> choose (0,2^arbitraryBitSetMax-1)+  shrink s = let s' = [ s `clearBit` a | a <- activeBitsL s ]+             in  s' ++ concatMap shrink s'+
+ Data/PrimitiveArray/Index/BitSet1.hs view
@@ -0,0 +1,172 @@++-- | A bitset with one interface. This includes the often-encountered case+-- where @{u,v},{v}@, or sets with a single edge between the old set and a new+-- singleton set are required. Uses are Hamiltonian path problems, and TSP,+-- among others.++module Data.PrimitiveArray.Index.BitSet1 where++import           Control.DeepSeq (NFData(..))+import           Control.Lens (makeLenses)+import           Control.Monad.Except+import           Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey)+import           Data.Binary (Binary)+import           Data.Bits+import           Data.Bits.Extras+import           Data.Hashable (Hashable)+import           Data.Serialize (Serialize)+import           Data.Vector.Unboxed.Deriving+import           Data.Vector.Unboxed (Unbox(..))+import           Debug.Trace+import           GHC.Generics (Generic)+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import           Test.QuickCheck++import           Data.Bits.Ordered+import           Data.PrimitiveArray.Index.BitSet0 (BitSet(..),LimitType(..))+import           Data.PrimitiveArray.Index.BitSetClasses+import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.IOC++++-- | The bitset with one interface or boundary.++data BitSet1 i ioc = BitSet1 { _bitset ∷ !(BitSet ioc), _boundary ∷ !(Boundary i ioc) }+  deriving (Eq,Ord,Generic,Show)+makeLenses ''BitSet1++derivingUnbox "BitSet1"+  [t| forall i ioc . BitSet1 i ioc → (Int,Int)           |]+  [| \ (BitSet1 (BitSet set) (Boundary bnd)) → (set,bnd) |]+  [| \ (set,bnd) → BitSet1 (BitSet set) (Boundary bnd)   |]+++-- |+--+-- NOTE We linearize a bitset as follows: we need @2^number-of-bits *+-- number-of-bits@ elements. The first is due to having a binary set structure.+-- The second is due to pointing to each of those elements as being the+-- boundary. This overcommits on memory since only those bits can be a boundary+-- bits that are actually set. Furthermore, in case no bit is set at all, then+-- there should be no boundary. This is currently rather awkwardly done by+-- restricting enumeration and mapping the 0-set to boundary 0.+--+-- | TODO The size calculations are off by a factor of two, exactly. Each+-- bitset (say) @00110@ has a mirror image @11001@, whose elements do not have+-- to be indexed. It has to be investigated if a version with exact memory+-- bounds is slower in indexing.++instance Index (BitSet1 bnd ioc) where+  -- This is the number of bits. Meaning that @LtNumBits1 3@ yields @[0,1,2]@.+  -- TODO Should we rename this to @NumberOfBits1@? Or have a newtype @NumBits@?+  newtype LimitType (BitSet1 bnd ioc) = LtNumBits1 Int+  -- Calculate the linear index for a set. Spread out by the possible number of+  -- bits to fit the actual boundary results. Add the boundary index.+  linearIndex (LtNumBits1 pc) (BitSet1 set (Boundary bnd))+    = linearIndex (LtBitSet pc) set * pc + bnd+  {-# Inline linearIndex #-}+  size (LtNumBits1 pc) = 2^pc * pc + 1+  {-# Inline size #-}+  inBounds (LtNumBits1 pc) (BitSet1 set bnd) = popCount set <= pc && 0 <= bnd && getBoundary bnd <= pc+  {-# Inline inBounds #-}+  zeroBound = BitSet1 zeroBound zeroBound+  {-# Inline zeroBound #-}+  zeroBound' = LtNumBits1 0+  {-# Inline zeroBound' #-}+  totalSize (LtNumBits1 pc) =+    let z = fromIntegral pc+    in  [z * 2 ^ z]+  fromLinearIndex (LtNumBits1 pc) z = error "implement me"+  showBound = error "implement me"+  showIndex = error "implement me"++deriving instance Show (LimitType (BitSet1 bnd ioc))++instance IndexStream z ⇒ IndexStream (z:.BitSet1 i I) where+  streamUp   (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++instance IndexStream z ⇒ IndexStream (z:.BitSet1 i O) where+  streamUp   (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamDownMk l h) (streamDownStep l h) $ streamUp   ls hs+  streamDown (ls:..LtNumBits1 l) (hs:..LtNumBits1 h) = SM.flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++--instance IndexStream z => IndexStream (z:.BS1 i C) where+--  streamUp   (ls:..l) (hs:..h) = flatten (streamUpBsIMk   l h) (streamUpBsIStep   l h) $ streamUp   ls hs+--  streamDown (ls:..l) (hs:..h) = flatten (streamDownBsIMk l h) (streamDownBsIStep l h) $ streamDown ls hs+--  {-# Inline streamUp #-}+--  {-# Inline streamDown #-}++instance IndexStream (Z:.BitSet1 i t) ⇒ IndexStream (BitSet1 i t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# Inline streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# Inline streamDown #-}++streamUpMk ∷ Monad m ⇒ Int → Int → z → m (z, Maybe (BitSet1 c ioc))+streamUpMk l h z =+  let set = BitSet $ 2^l-1+      -- lsbZ set == 0, or no active bits in which case we use 0+      bnd = UndefBoundary+  in  return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)+{-# Inline [0] streamUpMk #-}++streamUpStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))+streamUpStep l h (z, Nothing) = return $ SM.Done+streamUpStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)+{-# Inline [0] streamUpStep #-}++streamDownMk ∷ Monad m ⇒ Int → Int → z → m (z, Maybe (BitSet1 c ioc))+streamDownMk l h z =+  let set = BitSet $ 2^h-1+      bnd = Boundary 0 -- this is the actual boundary at zero+  in  return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)+{-# Inline [0] streamDownMk #-}++streamDownStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))+streamDownStep l h (z, Nothing) = return $ SM.Done+streamDownStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)+{-# Inline [0] streamDownStep #-}++instance SetPredSucc (BitSet1 t ioc) where+  setSucc pcl pch (BitSet1 s (Boundary is))+    | cs > pch                         = Nothing+    | Just is' <- maybeNextActive is s = Just $ BitSet1 s  (Boundary is')+    | Just s'  <- popPermutation pch s = Just $ BitSet1 s' (Boundary $ lsbZ s')+    | cs >= pch                        = Nothing+    | cs < pch                         = let s' = BitSet $ 2^(cs+1)-1+                                         in  Just (BitSet1 s' (Boundary (lsbZ s')))+    where cs = popCount s+  {-# Inline setSucc #-}+  setPred pcl pch (BitSet1 s (Boundary is))+    | cs < pcl                          = Nothing+    | Just is' <- maybeNextActive is s  = Just $ BitSet1 s  (Boundary is')+    | Just s'  <- popPermutation pch s  = Just $ BitSet1 s' (Boundary $ lsbZ s')+    | cs <= pcl                         = Nothing+    | cs > pcl                          = let s' = BitSet $ 2^(cs-1)-1+                                          in  Just (BitSet1 s' (Boundary (max 0 $ lsbZ s')))+    where cs = popCount s+  {-# Inline setPred #-}++instance SetPredSucc (FixedMask (BitSet1 t ioc)) where+  setPred = error "implement me"+  setSucc pcl pch (FixedMask mask bs1) = undefined++instance Arbitrary (BitSet1 t ioc) where+  arbitrary = do+    s <- arbitrary+    if s==0+      then return (BitSet1 s 0)+      else do i <- elements $ activeBitsL s+              return (BitSet1 s $ Boundary i)+  shrink (BitSet1 s i) =+    let s' = [ BitSet1 (s `clearBit` a) i+             | a <- activeBitsL s+             , Boundary a /= i ]+             ++ [ BitSet1 0 0 | popCount s == 1 ]+    in  s' ++ concatMap shrink s'+
+ Data/PrimitiveArray/Index/BitSetClasses.hs view
@@ -0,0 +1,175 @@++-- | A collection of a number of data types and type classes shared by all+-- bitset variants.++module Data.PrimitiveArray.Index.BitSetClasses where++import           Control.DeepSeq (NFData(..))+import           Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey)+import           Data.Binary (Binary)+import           Data.Hashable (Hashable)+import           Data.Serialize (Serialize)+import           Data.Vector.Unboxed.Deriving+import           GHC.Generics (Generic)+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU++import           Data.Bits.Ordered+import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.IOC++++-- * Boundaries, the interface(s) for bitsets.++-- | Certain sets have an interface, a particular element with special+-- meaning. In this module, certain ``meanings'' are already provided.+-- These include a @First@ element and a @Last@ element. We phantom-type+-- these to reduce programming overhead.++newtype Boundary boundaryType ioc = Boundary { getBoundary ∷ Int }+  deriving stock (Eq,Ord,Generic)+  deriving newtype (Num)++-- | Whenever we can not set the boundary we should have for a set, we use this+-- pattern. All legal boundaries are @>=0@. We also need to set the undefined+-- boundary to @0@, since the @linearIndex@ will use this value to add, which+-- for empty sets would reduce to @0 - UndefBoundary === 0@.++pattern UndefBoundary ∷ Boundary boundaryType ioc+pattern UndefBoundary = Boundary 0++instance Show (Boundary i t) where+  show (Boundary i) = "(I:" ++ show i ++ ")"++derivingUnbox "Boundary"+  [t| forall i t . Boundary i t → Int |]+  [| \(Boundary i) → i                |]+  [| Boundary                         |]++instance Binary    (Boundary i t)+instance Serialize (Boundary i t)+instance ToJSON    (Boundary i t)+instance FromJSON  (Boundary i t)+instance Hashable  (Boundary i t)++instance NFData (Boundary i t) where+  rnf (Boundary i) = rnf i+  {-# Inline rnf #-}++instance Index (Boundary i t) where+  newtype LimitType (Boundary i t) = LtBoundary Int+  linearIndex _ (Boundary z) = z+  {-# INLINE linearIndex #-}+  size (LtBoundary h) = h + 1+  {-# INLINE size #-}+  inBounds (LtBoundary h) z = 0 <= z && getBoundary z <= h+  {-# INLINE inBounds #-}+  zeroBound = Boundary 0+  {-# Inline zeroBound #-}+  zeroBound' = LtBoundary 0+  {-# Inline zeroBound' #-}+  totalSize (LtBoundary n) = [fromIntegral n]+  {-# Inline totalSize #-}+  fromLinearIndex _ = Boundary+  {-# Inline fromLinearIndex #-}+  showBound (LtBoundary b) = ["LtBoundary " ++ show b]+  showIndex (Boundary b) = ["Boundary " ++ show b]++instance IndexStream z ⇒ IndexStream (z:.Boundary k I) where+  streamUp   (ls:..LtBoundary l) (hs:..LtBoundary h) = SM.flatten (streamUpBndMk   l h) (streamUpBndStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtBoundary l) (hs:..LtBoundary h) = SM.flatten (streamDownBndMk l h) (streamDownBndStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream (Z:.Boundary k I) ⇒ IndexStream (Boundary k I) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# Inline streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# Inline streamDown #-}++streamUpBndMk l h z = return (z, l)+{-# Inline [0] streamUpBndMk #-}++streamUpBndStep l h (z , k)+  | k > h     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.Boundary k) (z, k+1)+{-# Inline [0] streamUpBndStep #-}++streamDownBndMk l h z = return (z, h)+{-# Inline [0] streamDownBndMk #-}++streamDownBndStep l h (z , k)+  | k < l     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.Boundary k) (z,k-1)+{-# Inline [0] streamDownBndStep #-}++-- | Declare the interface to be the start of a path.++data First++-- | Declare the interface to be the end of a path.++data Last++-- | Declare the interface to match anything.+--+-- TODO needed? want to use later in ADPfusion++data Any++++-- * Moving indices within sets.++-- | Successor and Predecessor for sets. Designed as a class to accomodate+-- sets with interfaces and without interfaces with one function.+--+-- The functions are not written recursively, as we currently only have+-- three cases, and we do not want to "reset" while generating successors+-- and predecessors.+--+-- Note that sets have a partial order. Within the group of element with+-- the same @popCount@, we use @popPermutation@ which has the same stepping+-- order for both, @setSucc@ and @setPred@.++class SetPredSucc s where+  -- | Set successor. The first argument is the lower set limit, the second+  -- the upper set limit, the third the current set.+  setSucc ∷ Int → Int → s → Maybe s+  -- | Set predecessor. The first argument is the lower set limit, the+  -- second the upper set limit, the third the current set.+  setPred ∷ Int → Int → s → Maybe s++-- | Masks are used quite often for different types of bitsets. We liberate+-- them as a type family.++type family Mask s ∷ *++-- | @Fixed@ allows us to fix some or all bits of a bitset, thereby+-- providing @succ/pred@ operations which are only partially free.+--+-- @f = getFixedMask .&. getFixed@ are the fixed bits.+-- @n = getFixed .&. complement getFixedMask@ are the free bits.+-- @to = complement getFixed@ is the to move mask+-- @n' = popShiftR to n@ yields the population after the move+-- @p = popPermutation undefined n'@ yields the new population permutation+-- @p' = popShiftL to p@ yields the population moved back+-- @final = p' .|. f@++data FixedMask t = FixedMask { getMask ∷ (Mask t) , getFixed ∷ !t }++-- | Assuming a bitset on bits @[0 .. highbit]@, we can apply a mask that+-- stretches out those bits over @[0 .. higherBit]@ with @highbit <=+-- higherBit@. Any active interfaces are correctly set as well.++class ApplyMask s where+  applyMask :: Mask s → s → s++++-- | for 'Test.QuickCheck.Arbitrary'++arbitraryBitSetMax ∷ Int+arbitraryBitSetMax = 6+
Data/PrimitiveArray/Index/Class.hs view
@@ -3,16 +3,26 @@  import           Control.Applicative import           Control.DeepSeq (NFData(..))+import           Control.Lens hiding (Index, (:>))+import           Control.Monad.Except import           Control.Monad (liftM2) import           Data.Aeson import           Data.Binary+import           Data.Data+import           Data.Hashable (Hashable)+import           Data.Proxy import           Data.Serialize+import           Data.Typeable import           Data.Vector.Fusion.Stream.Monadic (Stream) import           Data.Vector.Unboxed.Deriving import           Data.Vector.Unboxed (Unbox(..))+import           GHC.Base (quotRemInt) import           GHC.Generics+import           GHC.TypeNats import qualified Data.Vector.Fusion.Stream.Monadic as SM import           Test.QuickCheck+import           Text.Printf+import           Data.Type.Equality   @@ -21,7 +31,7 @@ -- | Strict pairs -- as in @repa@.  data a :. b = !a :. !b-  deriving (Eq,Ord,Show,Generic)+  deriving (Eq,Ord,Show,Generic,Data,Typeable)  derivingUnbox "StrictPair"   [t| forall a b . (Unbox a, Unbox b) => (a:.b) -> (a,b) |]@@ -32,7 +42,11 @@ instance (Serialize a, Serialize b) => Serialize (a:.b) instance (ToJSON    a, ToJSON    b) => ToJSON    (a:.b) instance (FromJSON  a, FromJSON  b) => FromJSON  (a:.b)+instance (Hashable  a, Hashable  b) => Hashable  (a:.b) +instance (ToJSON a  , ToJSONKey   a, ToJSON b  , ToJSONKey   b) => ToJSONKey   (a:.b)+instance (FromJSON a, FromJSONKey a, FromJSON b, FromJSONKey b) => FromJSONKey (a:.b)+ deriving instance (Read a, Read b) => Read (a:.b)  instance (NFData a, NFData b) => NFData (a:.b) where@@ -43,16 +57,18 @@   arbitrary     = liftM2 (:.) arbitrary arbitrary   shrink (a:.b) = [ (a':.b) | a' <- shrink a ] ++ [ (a:.b') | b' <- shrink b ] ---infixl 3 :>+infixr 3 :>  -- | A different version of strict pairs. Makes for simpler type inference in -- multi-tape grammars. We use @:>@ when we have special needs, like -- non-recursive instances on inductives tuples, as used for set indices.+--+-- This one is @infixr@ so that in @a :> b@ we can have the main type in+-- @a@ and the specializing types in @b@ and then dispatch on @a :> ts@+-- with @ts@ maybe a chain of @:>@.  data a :> b = !a :> !b-  deriving (Eq,Ord,Show,Generic)+  deriving (Eq,Ord,Show,Generic,Data,Typeable)  derivingUnbox "StrictIxPair"   [t| forall a b . (Unbox a, Unbox b) => (a:>b) -> (a,b) |]@@ -63,6 +79,7 @@ instance (Serialize a, Serialize b) => Serialize (a:>b) instance (ToJSON    a, ToJSON    b) => ToJSON    (a:>b) instance (FromJSON  a, FromJSON  b) => FromJSON  (a:>b)+instance (Hashable  a, Hashable  b) => Hashable  (a:>b)  deriving instance (Read a, Read b) => Read (a:>b) @@ -79,7 +96,7 @@ -- | Base data constructor for multi-dimensional indices.  data Z = Z-  deriving (Eq,Ord,Read,Show,Generic)+  deriving (Eq,Ord,Read,Show,Generic,Data,Typeable,Bounded)  derivingUnbox "Z"   [t| Z -> () |]@@ -90,6 +107,7 @@ instance Serialize Z instance ToJSON    Z instance FromJSON  Z+instance Hashable  Z  instance Arbitrary Z where   arbitrary = return Z@@ -105,30 +123,58 @@ -- grammars on one or more tapes, for strings, sets, later on tree structures.  class Index i where--  -- | Given a minimal size, a maximal size, and a current index, calculate+  -- | Data structure encoding the upper limit for each array.+  data LimitType i :: *+  -- | Given a maximal size, and a current index, calculate   -- the linear index.--  linearIndex :: i -> i -> i -> Int--  -- | Given an index element from the smallest subset, calculate the-  -- highest linear index that is *not* stored.--  smallestLinearIndex :: i -> Int -- LH i+  linearIndex :: LimitType i -> i -> Int+  -- | Given a maximal size and a valid @Int@, return the index.+  fromLinearIndex :: LimitType i -> Int -> i+  -- | Given the 'LimitType', return the number of cells required for storage.+  size :: LimitType i -> Int+  -- | Check if an index is within the bounds.+  inBounds :: LimitType i -> i -> Bool+  -- | A lower bound of @zero@+  zeroBound :: i+  -- | A lower bound of @zero@ but for a @LimitType i@.+  zeroBound' :: LimitType i+  -- | The list of cell sizes for each dimension. its product yields the total+  -- size.+  totalSize :: LimitType i -> [Integer]+  -- | Pretty-print all upper bounds+  showBound :: LimitType i -> [String]+  -- | Pretty-print all indices+  showIndex :: i -> [String] -  -- | Given an index element from the largest subset, calculate the-  -- highest linear index that *is* stored.+-- | Given the maximal number of cells (@Word@, because this is the pointer+-- limit for the machine), and the list of sizes, will check if this is still+-- legal. Consider dividing the @Word@ by the actual memory requirements for+-- each cell, to get better exception handling for too large arrays.+--+-- One list should be given for each array. -  largestLinearIndex :: i -> Int -- LH i+sizeIsValid :: Monad m => Word -> [[Integer]] -> ExceptT SizeError m CellSize+sizeIsValid maxCells cells = do+  let ps = map product cells+      s  = sum ps+  when (fromIntegral maxCells <= s) $+    throwError . SizeError+               $ printf "PrimitiveArrays would be larger than maximal cell size. The given limit is %d, but the requested size is %d, with size %s for each array. (Debug hint: %s)"+                  maxCells s (show ps) (show s)+  return . CellSize $ fromIntegral s+{-# Inlinable sizeIsValid #-} -  -- | Given smallest and largest index, return the number of cells-  -- required for storage.+-- | In case @totalSize@ or variants thereof produce a size that is too big to+-- handle. -  size :: i -> i -> Int+newtype SizeError = SizeError String+  deriving (Eq,Ord,Show) -  -- | Check if an index is within the bounds.+-- | The total number of cells that are allocated. -  inBounds :: i -> i -> i -> Bool+newtype CellSize = CellSize Word+  deriving stock (Eq,Ord,Show)+  deriving newtype (Num,Bounded,Integral,Real,Enum)   @@ -136,69 +182,163 @@ -- Since the stream generators require @concatMap@ / @flatten@ we have to -- write more specialized code for @(z:.IX)@ stuff. -class IndexStream i where--  -- | This generates an index stream suitable for @forward@ structure filling.+class (Index i) => IndexStream i where+  -- | Generate an index stream using 'LimitType's. This prevents having to+  -- figure out how the actual limits for complicated index types (like @Set@)+  -- would look like, since for @Set@, for example, the @LimitType Set == Int@+  -- provides just the number of bits.+  --+  -- This generates an index stream suitable for @forward@ structure filling.   -- The first index is the smallest (or the first indices considered are all   -- equally small in partially ordered sets). Larger indices follow up until   -- the largest one.--  streamUp   :: Monad m => i -> i -> Stream m i-  default streamUp :: (Monad m, IndexStream (Z:.i)) => i -> i -> Stream m i-  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (Z:.l) (Z:.h)-  {-# INLINE streamUp #-}-+  streamUp :: Monad m => LimitType i -> LimitType i -> Stream m i   -- | If 'streamUp' generates indices from smallest to largest, then   -- 'streamDown' generates indices from largest to smallest. Outside grammars   -- make implicit use of this. Asking for an axiom in backtracking requests   -- the first element from this stream.--  streamDown :: Monad m => i -> i -> Stream m i-  default streamDown :: (Monad m, IndexStream (Z:.i)) => i -> i -> Stream m i-  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (Z:.l) (Z:.h)-  {-# INLINE streamDown #-}+  streamDown :: Monad m => LimitType i -> LimitType i -> Stream m i    instance Index Z where-  linearIndex _ _ _ = 0+  data LimitType Z = ZZ+  linearIndex _ _ = 0   {-# INLINE linearIndex #-}-  smallestLinearIndex _ = 0-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex _ = 0-  {-# INLINE largestLinearIndex #-}-  size _ _ = 1+  fromLinearIndex _ _ = Z+  {-# Inline fromLinearIndex #-}+  size _ = 1   {-# INLINE size #-}-  inBounds _ _ _ = True+  inBounds _ _ = True   {-# INLINE inBounds #-}+  zeroBound = Z+  {-# Inline zeroBound #-}+  zeroBound' = ZZ+  {-# Inline zeroBound' #-}+  totalSize ZZ = [1]+  {-# Inline [1] totalSize #-}+  showBound ZZ = [show ZZ]+  showIndex Z = [show Z]  instance IndexStream Z where-  streamUp   Z Z = SM.singleton Z-  {-# INLINE streamUp #-}-  streamDown Z Z = SM.singleton Z-  {-# INLINE streamDown #-}+  streamUp ZZ ZZ = SM.singleton Z+  {-# Inline streamUp #-}+  streamDown ZZ ZZ = SM.singleton Z+  {-# Inline streamDown #-} +deriving instance Eq       (LimitType Z)+deriving instance Generic  (LimitType Z)+deriving instance Read     (LimitType Z)+deriving instance Show     (LimitType Z)+deriving instance Data     (LimitType Z)+deriving instance Typeable (LimitType Z)+deriving instance Bounded  (LimitType Z)+ instance (Index zs, Index z) => Index (zs:.z) where-  linearIndex (ls:.l) (hs:.h) (zs:.z) = linearIndex ls hs zs * (largestLinearIndex h + 1) + linearIndex l h z+  data LimitType (zs:.z) = !(LimitType zs) :.. !(LimitType z)+  linearIndex (hs:..h) (zs:.z) = linearIndex hs zs * size h + linearIndex h z   {-# INLINE linearIndex #-}-  smallestLinearIndex (ls:.l) = smallestLinearIndex ls * smallestLinearIndex l-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (hs:.h) = largestLinearIndex hs * largestLinearIndex h-  {-# INLINE largestLinearIndex #-}-  size (ls:.l) (hs:.h) = size ls hs * (size l h)+  fromLinearIndex (hs:..h) k = let (l , r) = quotRemInt k (size h)+    in  fromLinearIndex hs l :. fromLinearIndex h r+  {-# Inline fromLinearIndex #-}+  size (hs:..h) = size hs * size h   {-# INLINE size #-}-  inBounds (ls:.l) (hs:.h) (zs:.z) = inBounds ls hs zs && inBounds l h z+  inBounds (hs:..h) (zs:.z) = inBounds hs zs && inBounds h z   {-# INLINE inBounds #-}+  zeroBound = zeroBound :. zeroBound+  {-# Inline zeroBound #-}+  zeroBound' = zeroBound' :.. zeroBound'+  {-# Inline zeroBound' #-}+  totalSize (hs:..h) =+    let tshs = totalSize hs+        tsh  = totalSize h+    in tshs ++ tsh+  {-# Inline totalSize #-}+  showBound (zs:..z) = showBound zs ++ showBound z+  showIndex (zs:.z) = showIndex zs ++ showIndex z -instance (Index zs, Index z) => Index (zs:>z) where-  linearIndex (ls:>l) (hs:>h) (zs:>z) = linearIndex ls hs zs * (largestLinearIndex h + 1) + linearIndex l h z-  {-# INLINE linearIndex #-}-  smallestLinearIndex (ls:>l) = smallestLinearIndex ls * smallestLinearIndex l-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (hs:>h) = largestLinearIndex hs * largestLinearIndex h-  {-# INLINE largestLinearIndex #-}-  size (ls:>l) (hs:>h) = size ls hs * (size l h)-  {-# INLINE size #-}-  inBounds (ls:>l) (hs:>h) (zs:>z) = inBounds ls hs zs && inBounds l h z-  {-# INLINE inBounds #-}+deriving instance (Eq (LimitType zs)     , Eq (LimitType z)     ) => Eq      (LimitType (zs:.z))+deriving instance (Generic (LimitType zs), Generic (LimitType z)) => Generic (LimitType (zs:.z))+deriving instance (Read (LimitType zs)   , Read (LimitType z)   ) => Read    (LimitType (zs:.z))+deriving instance (Show (LimitType zs)   , Show (LimitType z)   ) => Show    (LimitType (zs:.z))+deriving instance+  ( Data zs, Data (LimitType zs), Typeable zs+  , Data z , Data (LimitType z) , Typeable z+  ) => Data    (LimitType (zs:.z))+deriving instance (Bounded (LimitType zs), Bounded (LimitType z)) => Bounded (LimitType (zs:.z))++--instance (Index zs, Index z) => Index (zs:>z) where+--  type LimitType (zs:>z) = LimitType zs:>LimitType z+--  linearIndex (hs:>h) (zs:>z) = linearIndex hs zs * (size (Proxy :: Proxy z) h) + linearIndex h z+--  {-# INLINE linearIndex #-}+--  size Proxy (ss:>s) = size (Proxy :: Proxy zs) ss * (size (Proxy :: Proxy z) s)+--  {-# INLINE size #-}+--  inBounds (hs:>h) (zs:>z) = inBounds hs zs && inBounds h z+--  {-# INLINE inBounds #-}++++-- * Somewhat experimental lens support.+--+-- The problem here is that tuples are n-ary, while inductive tuples are+-- binary, recursive.++instance Field1 (Z:.a) (Z:.a') a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a) -> a) (\(Z:._) a -> (Z:.a))++instance Field1 (Z:.a:.b) (Z:.a':.b) a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a:.b) -> a) (\(Z:._:.b) a -> (Z:.a:.b))++instance Field1 (Z:.a:.b:.c) (Z:.a':.b:.c) a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a:.b:.c) -> a) (\(Z:._:.b:.c) a -> (Z:.a:.b:.c))+++instance Field2 (Z:.a:.b) (Z:.a:.b') b b' where+  {-# Inline _2 #-}+  _2 = lens (\(Z:.a:.b) -> b) (\(Z:.a:._) b -> (Z:.a:.b))++instance Field2 (Z:.a:.b:.c) (Z:.a:.b':.c) b b' where+  {-# Inline _2 #-}+  _2 = lens (\(Z:.a:.b:.c) -> b) (\(Z:.a:._:.c) b -> (Z:.a:.b:.c))+++instance Field3 (Z:.a:.b:.c) (Z:.a:.b:.c') c c' where+  {-# Inline _3 #-}+  _3 = lens (\(Z:.a:.b:.c) -> c) (\(Z:.a:.b:._) c -> (Z:.a:.b:.c))++++-- * Operations for sparsity.++-- | @manhattan@ turns an index @sh@ into a starting point within 'sparseIndices' of the 'Sparse'+-- data structure. This should reduce the time required to search @sparseIndices@, because+-- @manhattanStart[manhattan sh]@ yields a left bound, while @manhattanStart[manhattan sh +1]@ will+-- yield an excluded right bound.+--+-- Uses the @Manhattan@ distance.+--+-- TODO This should probably be moved into the @Index@ module.++class SparseBucket sh where+  -- | The manhattan distance for an index.+  manhattan :: LimitType sh -> sh -> Int+  -- | The maximal possible manhattan distance.+  manhattanMax :: LimitType sh -> Int++instance SparseBucket Z where+  {-# Inline manhattan #-}+  manhattan ZZ Z = 0+  {-# Inline manhattanMax #-}+  manhattanMax ZZ = 1++-- | Manhattan distances add up.++instance (SparseBucket i, SparseBucket is) => SparseBucket (is:.i) where+  {-# Inline manhattan #-}+  manhattan (zz:..z) (is:.i) = manhattan zz is + manhattan z i+  {-# Inline manhattanMax #-}+  manhattanMax (zz:..z) = manhattanMax zz + manhattanMax z
− Data/PrimitiveArray/Index/Complement.hs 
@@ -1,60 +0,0 @@--module Data.PrimitiveArray.Index.Complement where--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.Binary-import Data.Serialize-import Data.Vector.Unboxed.Deriving-import Data.Vector.Unboxed (Unbox(..))-import GHC.Generics-import Test.QuickCheck--import Data.PrimitiveArray.Index.Class------ | A special index wrapper -- like @Outside@. @Complement@ allows combining--- inside and outside symbols which complement each other. This then yields--- ensemble results for each index (you need @ADPfusion@ for this).--newtype Complement z = C { unC :: z }-  deriving (Eq,Ord,Read,Show,Generic)--derivingUnbox "Complement"-  [t| forall z . Unbox z => Complement z -> z |]-  [| unC |]-  [| C   |]--instance Binary    z => Binary    (Complement z)-instance Serialize z => Serialize (Complement z)-instance ToJSON    z => ToJSON    (Complement z)-instance FromJSON  z => FromJSON  (Complement z)--instance NFData z => NFData (Complement z) where-  rnf (C z) = rnf z-  {-# Inline rnf #-}--instance Index i => Index (Complement i) where-  linearIndex (C l) (C h) (C i) = linearIndex l h i-  {-# INLINE linearIndex #-}-  smallestLinearIndex (C i) = smallestLinearIndex i-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (C i) = largestLinearIndex i-  {-# INLINE largestLinearIndex #-}-  size (C l) (C h) = size l h-  {-# INLINE size #-}-  inBounds (C l) (C h) (C z) = inBounds l h z-  {-# INLINE inBounds #-}--instance IndexStream i => IndexStream (Complement i) where-  streamUp   (C l) (C h) = fmap C $ streamUp l h-  {-# INLINE streamUp #-}-  streamDown (C l) (C h) = fmap C $ streamDown l h-  {-# INLINE streamDown #-}--instance Arbitrary z => Arbitrary (Complement z) where-  arbitrary    = C <$> arbitrary-  shrink (C z) = C <$> shrink z-
+ Data/PrimitiveArray/Index/IOC.hs view
@@ -0,0 +1,17 @@++module Data.PrimitiveArray.Index.IOC where++++-- | Phantom type for @Inside@ indices.++data I++-- | Phantom type for @Outside@ indices.++data O++-- | Phantom type for @Complement@ indices.++data C+
Data/PrimitiveArray/Index/Int.hs view
@@ -1,47 +1,54 @@  module Data.PrimitiveArray.Index.Int where -import Data.Vector.Fusion.Stream.Monadic (flatten,map,Step(..))-import Data.Vector.Fusion.Stream.Size-import Prelude hiding (map)+import qualified Data.Vector.Fusion.Stream.Monadic as SM -import Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.Class    instance Index Int where-  linearIndex _ _ k = k+  newtype LimitType Int = LtInt Int+  linearIndex _ k = k   {-# Inline linearIndex #-}-  smallestLinearIndex _ = error "still needed?"-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex h = h-  {-# Inline largestLinearIndex #-}-  size _ h = h+1+  size (LtInt h) = h+1   {-# Inline size #-}-  inBounds l h k = l <= k && k <= h+  inBounds (LtInt h) k = 0 <= k && k <= h   {-# Inline inBounds #-}+  zeroBound = 0+  {-# Inline [0] zeroBound #-}+  zeroBound' = LtInt 0+  {-# Inline [0] zeroBound' #-}+  totalSize (LtInt h) = [fromIntegral $ h+1]+  {-# Inline [0] totalSize #-}+  fromLinearIndex _ = id+  {-# Inline [0] fromLinearIndex #-}+  showBound (LtInt b) = ["LtInt " ++ show b]+  showIndex i = ["Int " ++ show i] +deriving instance Show (LimitType Int)+ instance IndexStream z => IndexStream (z:.Int) where-  streamUp (ls:.l) (hs:.h) = flatten mk step Unknown $ streamUp ls hs+  streamUp (ls:.. LtInt l) (hs:.. LtInt h) = SM.flatten mk step $ streamUp ls hs     where mk z = return (z,l)           step (z,k)-            | k > h     = return $ Done-            | otherwise = return $ Yield (z:.k) (z,k+1)+            | k > h     = return $ SM.Done+            | otherwise = return $ SM.Yield (z:.k) (z,k+1)           {-# Inline [0] mk   #-}           {-# Inline [0] step #-}   {-# Inline streamUp #-}-  streamDown (ls:.l) (hs:.h) = flatten mk step Unknown $ streamDown ls hs+  streamDown (ls:..LtInt l) (hs:..LtInt h) = SM.flatten mk step $ streamDown ls hs     where mk z = return (z,h)           step (z,k)-            | k < l     = return $ Done-            | otherwise = return $ Yield (z:.k) (z,k-1)+            | k < l     = return $ SM.Done+            | otherwise = return $ SM.Yield (z:.k) (z,k-1)           {-# Inline [0] mk   #-}           {-# Inline [0] step #-}   {-# Inline streamDown #-}  instance IndexStream Int where-  streamUp l h = map (\(Z:.k) -> k) $ streamUp (Z:.l) (Z:.h)+  streamUp l h = SM.map (\(Z:.k) -> k) $ streamUp (ZZ:..l) (ZZ:..h)   {-# Inline streamUp #-}-  streamDown l h = map (\(Z:.k) -> k) $ streamDown (Z:.l) (Z:.h)+  streamDown l h = SM.map (\(Z:.k) -> k) $ streamDown (ZZ:..l) (ZZ:..h)   {-# Inline streamDown #-}
− Data/PrimitiveArray/Index/Outside.hs 
@@ -1,62 +0,0 @@--module Data.PrimitiveArray.Index.Outside where--import Control.Applicative-import Control.DeepSeq (NFData(..))-import Data.Aeson-import Data.Binary-import Data.Serialize-import Data.Vector.Unboxed.Deriving-import Data.Vector.Unboxed (Unbox(..))-import GHC.Generics-import Test.QuickCheck--import Data.PrimitiveArray.Index.Class------ | The 'Outside' wrapper takes an index structure, and provides--- 'IndexStream' functions 'streamUp' and 'streamDown' that work the other--- way around. In particular, for @Outside z@ @streamUp (Outside z) = fmap--- Outside $ streamDown z@ and vice versa. @Index@ functions are unwrapped--- but otherwise work as before.--newtype Outside z = O { unO :: z }-  deriving (Eq,Ord,Read,Show,Generic)--derivingUnbox "Outside"-  [t| forall z . Unbox z => Outside z -> z |]-  [| unO |]-  [| O   |]--instance Binary    z => Binary    (Outside z)-instance Serialize z => Serialize (Outside z)-instance ToJSON    z => ToJSON    (Outside z)-instance FromJSON  z => FromJSON  (Outside z)--instance NFData z => NFData (Outside z) where-  rnf (O z) = rnf z-  {-# Inline rnf #-}--instance Index i => Index (Outside i) where-  linearIndex (O l) (O h) (O i) = linearIndex l h i-  {-# INLINE linearIndex #-}-  smallestLinearIndex (O i) = smallestLinearIndex i-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (O i) = largestLinearIndex i-  {-# INLINE largestLinearIndex #-}-  size (O l) (O h) = size l h-  {-# INLINE size #-}-  inBounds (O l) (O h) (O z) = inBounds l h z-  {-# INLINE inBounds #-}--instance IndexStream i => IndexStream (Outside i) where-  streamUp (O l) (O h) = fmap O $ streamDown l h-  {-# INLINE streamUp #-}-  streamDown (O l) (O h) = fmap O $ streamUp l h-  {-# INLINE streamDown #-}--instance Arbitrary z => Arbitrary (Outside z) where-  arbitrary = O <$> arbitrary-  shrink (O z) = O <$> shrink z-
Data/PrimitiveArray/Index/PhantomInt.hs view
@@ -4,19 +4,20 @@ module Data.PrimitiveArray.Index.PhantomInt where  import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey) import Data.Binary (Binary) import Data.Data+import Data.Hashable (Hashable) import Data.Ix(Ix) import Data.Serialize (Serialize) import Data.Typeable-import Data.Vector.Fusion.Stream.Monadic (flatten,map,Step(..))-import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Stream.Monadic (map,Step(..),flatten) import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import Prelude hiding (map)  import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.IOC   @@ -24,53 +25,91 @@ -- type @p@. In particular, the @Index@ and @IndexStream@ instances are the -- same as for raw @Int@s. -newtype PInt p = PInt { getPInt :: Int }-  deriving (Read,Show,Eq,Ord,Enum,Num,Integral,Real,Generic,Data,Typeable,Ix)+newtype PInt (ioc ∷ k) (p ∷ k) = PInt { getPInt :: Int }+  deriving stock (Read,Show,Eq,Ord,Generic,Data,Typeable,Ix)+  deriving newtype (Real,Num,Enum,Integral) +pIntI :: Int -> PInt I p+pIntI = PInt+{-# Inline pIntI #-} -derivingUnbox "PInt"-  [t| forall p . PInt p -> Int |]  [| getPInt |]  [| PInt |]+pIntO :: Int -> PInt O p+pIntO = PInt+{-# Inline pIntO #-} -instance Binary    (PInt p)-instance Serialize (PInt p)-instance FromJSON  (PInt p)-instance ToJSON    (PInt p)+pIntC :: Int -> PInt C p+pIntC = PInt+{-# Inline pIntC #-} -instance NFData (PInt p)+derivingUnbox "PInt"+  [t| forall t p . PInt t p -> Int |]  [| getPInt |]  [| PInt |] -instance Index (PInt p) where-  linearIndex _ _ (PInt k) = k+instance Binary       (PInt t p)+instance Serialize    (PInt t p)+instance FromJSON     (PInt t p)+instance FromJSONKey  (PInt t p)+instance ToJSON       (PInt t p)+instance ToJSONKey    (PInt t p)+instance Hashable     (PInt t p)+instance NFData       (PInt t p)++instance Index (PInt t p) where+  newtype LimitType (PInt t p) = LtPInt Int+  linearIndex _ (PInt k) = k   {-# Inline linearIndex #-}-  smallestLinearIndex _ = error "still needed?"-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex (PInt h) = h-  {-# Inline largestLinearIndex #-}-  size _ (PInt h) = h+1+  size (LtPInt h) = h+1   {-# Inline size #-}-  inBounds l h k = l <= k && k <= h+  inBounds (LtPInt h) (PInt k) = 0 <= k && k <= h   {-# Inline inBounds #-}+  fromLinearIndex = error "implement me"+  zeroBound = error "implement me"+  zeroBound' = error "implement me"+  totalSize = error "implement me"+  showBound = error "implement me"+  showIndex = error "implement me" -instance IndexStream z => IndexStream (z:.(PInt p)) where-  streamUp (ls:.l) (hs:.h) = flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z,l)-          step (z,k)-            | k > h     = return $ Done-            | otherwise = return $ Yield (z:.k) (z,k+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.l) (hs:.h) = flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z,h)-          step (z,k)-            | k < l     = return $ Done-            | otherwise = return $ Yield (z:.k) (z,k-1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}+deriving instance Show    (LimitType (PInt t p))+deriving instance Read    (LimitType (PInt t p))+deriving instance Eq      (LimitType (PInt t p))+deriving instance Generic (LimitType (PInt t p))++instance IndexStream z => IndexStream (z:.PInt I p) where+  streamUp   (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs+  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}   {-# Inline streamDown #-} -instance IndexStream (PInt p) where-  streamUp l h = map (\(Z:.k) -> k) $ streamUp (Z:.l) (Z:.h)-  {-# Inline streamUp #-}-  streamDown l h = map (\(Z:.k) -> k) $ streamDown (Z:.l) (Z:.h)+instance IndexStream z => IndexStream (z:.PInt O p) where+  streamUp   (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamUp ls hs+  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs+  {-# Inline streamUp   #-}   {-# Inline streamDown #-}++instance IndexStream z => IndexStream (z:.PInt C p) where+  streamUp   (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs+  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream (Z:.PInt ioc p) => IndexStream (PInt ioc p) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++streamUpMk l h z = return (z,l)+{-# Inline [0] streamUpMk #-}++streamUpStep l h (z,k)+  | k > h     = return $ Done+  | otherwise = return $ Yield (z:.PInt k) (z,k+1)+{-# Inline [0] streamUpStep #-}++streamDownMk l h z = return (z,h)+{-# Inline [0] streamDownMk #-}++streamDownStep l h (z,k)+  | k < l     = return $ Done+  | otherwise = return $ Yield (z:.PInt k) (z,k-1)+{-# Inline [0] streamDownStep #-}
Data/PrimitiveArray/Index/Point.hs view
@@ -1,4 +1,6 @@ +{-# Language MagicHash #-}+ -- | @Point@ index structures are used for left- and right-linear grammars. -- Such grammars have at most one syntactic symbol on each r.h.s. of a rule. -- The syntactic symbol needs to be in an outermost position.@@ -11,79 +13,128 @@ import           Data.Binary import           Data.Bits import           Data.Bits.Extras (Ranked)+import           Data.Hashable (Hashable) import           Data.Serialize-import           Data.Vector.Fusion.Stream.Size import           Data.Vector.Unboxed.Deriving import           Data.Vector.Unboxed (Unbox(..))-import           GHC.Generics+import           GHC.Exts+import           GHC.Generics (Generic) import qualified Data.Vector.Fusion.Stream.Monadic as SM import qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck+import           Test.QuickCheck as TQ+import           Test.SmallCheck.Series as TS  import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.IOC    -- | A point in a left-linear grammar. The syntactic symbol is in left-most -- position. -newtype PointL = PointL {fromPointL :: Int}-  deriving (Eq,Read,Show,Generic)+newtype PointL t = PointL {fromPointL :: Int}+  deriving stock (Eq,Ord,Read,Show,Generic)+  deriving newtype (Num) --- | A point in a right-linear grammars.+pointLI :: Int -> PointL I+pointLI = PointL+{-# Inline pointLI #-} -newtype PointR = PointR {fromPointR :: Int}-  deriving (Eq,Read,Show,Generic)+pointLO :: Int -> PointL O+pointLO = PointL+{-# Inline pointLO #-} +pointLC :: Int -> PointL C+pointLC = PointL+{-# Inline pointLC #-}  + derivingUnbox "PointL"-  [t| PointL -> Int    |]+  [t| forall t . PointL t -> Int    |]   [| \ (PointL i) -> i |]   [| \ i -> PointL i   |] -instance Binary    PointL-instance Serialize PointL-instance FromJSON  PointL-instance ToJSON    PointL+instance Binary       (PointL t)+instance Serialize    (PointL t)+instance FromJSON     (PointL t)+instance FromJSONKey  (PointL t)+instance ToJSON       (PointL t)+instance ToJSONKey    (PointL t)+instance Hashable     (PointL t) -instance NFData PointL where+instance NFData (PointL t) where   rnf (PointL l) = rnf l   {-# Inline rnf #-} -instance Index PointL where-  linearIndex _ _ (PointL z) = z+instance Index (PointL t) where+  newtype LimitType (PointL t) = LtPointL Int+  linearIndex _ (PointL z) = z   {-# INLINE linearIndex #-}-  smallestLinearIndex (PointL l) = error "still needed?"-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (PointL h) = h-  {-# INLINE largestLinearIndex #-}-  size (_) (PointL h) = h + 1+  fromLinearIndex (LtPointL h) k = (PointL k)+  {-# Inline fromLinearIndex #-}+  size (LtPointL h) = h + 1   {-# INLINE size #-}-  inBounds (_) (PointL h) (PointL x) = 0<=x && x<=h+  inBounds (LtPointL h) (PointL x) = 0<=x && x<=h   {-# INLINE inBounds #-}+  zeroBound = PointL 0+  {-# Inline [0] zeroBound #-}+  zeroBound' = LtPointL 0+  {-# Inline [0] zeroBound' #-}+  totalSize (LtPointL h) = [fromIntegral $ h + 1]+  {-# Inline [0] totalSize #-}+  showBound (LtPointL h) = ["LtPointL " ++ show h]+  showIndex (PointL i) = ["PointL " ++ show i] -instance IndexStream z => IndexStream (z:.PointL) where-  streamUp (ls:.PointL lf) (hs:.PointL ht) = SM.flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z,lf)-          step (z,k)-            | k > ht    = return $ SM.Done-            | otherwise = return $ SM.Yield (z:.PointL k) (z,k+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.PointL lf) (hs:.PointL ht) = SM.flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z,ht)-          step (z,k)-            | k < lf    = return $ SM.Done-            | otherwise = return $ SM.Yield (z:.PointL k) (z,k-1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}+deriving instance Eq      (LimitType (PointL t))+deriving instance Generic (LimitType (PointL t))+deriving instance Read    (LimitType (PointL t))+deriving instance Show    (LimitType (PointL t)) -instance IndexStream PointL+instance IndexStream z => IndexStream (z:.PointL I) where+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-} -instance Arbitrary PointL where+instance IndexStream z => IndexStream (z:.PointL O) where+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamUp   ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++instance IndexStream z => IndexStream (z:.PointL C) where+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++data SP z = SP !z !Int#++streamUpMk (I# lf) z = return $ SP z lf+{-# Inline [0] streamUpMk #-}++streamUpStep wrapper (I# ht) (SP z k)+  | 1# <- k ># ht = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k +# 1#))+{-# Inline [0] streamUpStep #-}++streamDownMk (I# ht) z = return $ SP z ht+{-# Inline [0] streamDownMk #-}++streamDownStep wrapper (I# lf) (SP z k)+  | 1# <- k <# lf = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k -# 1#))+{-# Inline [0] streamDownStep #-}++instance IndexStream (Z:.PointL t) => IndexStream (PointL t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}+++instance Arbitrary (PointL t) where   arbitrary = do     b <- choose (0,100)     return $ PointL b@@ -91,29 +142,117 @@     | 0<j = [PointL $ j-1]     | otherwise = [] +instance Monad m => Serial m (PointL t) where+  series = PointL . TS.getNonNegative <$> series  ++-- * @PointR@++-- | A point in a right-linear grammars.++newtype PointR t = PointR {fromPointR :: Int}+  deriving stock (Eq,Ord,Read,Show,Generic)+  deriving newtype (Num)+++ derivingUnbox "PointR"-  [t| PointR -> Int    |]+  [t| forall t . PointR t -> Int    |]   [| \ (PointR i) -> i |]   [| \ i -> PointR i   |] -instance Binary    PointR-instance Serialize PointR-instance FromJSON  PointR-instance ToJSON    PointR+instance Binary       (PointR t)+instance Serialize    (PointR t)+instance FromJSON     (PointR t)+instance FromJSONKey  (PointR t)+instance ToJSON       (PointR t)+instance ToJSONKey    (PointR t)+instance Hashable     (PointR t) -instance NFData PointR where+instance NFData (PointR t) where   rnf (PointR l) = rnf l   {-# Inline rnf #-} -instance Index PointR where-  linearIndex l _ (PointR z) = undefined+instance Index (PointR t) where+  newtype LimitType (PointR t) = LtPointR Int+  linearIndex _ (PointR z) = z   {-# INLINE linearIndex #-}-  smallestLinearIndex = undefined-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex = undefined-  {-# INLINE largestLinearIndex #-}-  size = undefined+  size (LtPointR h) = h + 1   {-# INLINE size #-}+  inBounds (LtPointR h) (PointR x) = 0<=x && x<=h+  {-# INLINE inBounds #-}+  zeroBound = PointR 0+  {-# Inline [0] zeroBound #-}+  zeroBound' = LtPointR 0+  {-# Inline [0] zeroBound' #-}+  totalSize (LtPointR h) = [fromIntegral $ h + 1]+  {-# Inline [0] totalSize #-}+  fromLinearIndex _ = PointR+  {-# Inline [0] fromLinearIndex #-}+  showBound (LtPointR b) = ["LtPointR " ++ show b]+  showIndex (PointR p) = ["PointR " ++ show p]++deriving instance Eq      (LimitType (PointR t))+deriving instance Generic (LimitType (PointR t))+deriving instance Read    (LimitType (PointR t))+deriving instance Show    (LimitType (PointR t))++instance IndexStream z => IndexStream (z:.PointR I) where+  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamUp ls hs+  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++instance IndexStream z => IndexStream (z:.PointR O) where+  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamUp   ls hs+  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++--instance IndexStream z => IndexStream (z:.PointR C) where+--  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMkR   lf) (streamUpStepR   ht) $ streamUp ls hs+--  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMkR ht) (streamDownStepR lf) $ streamDown ls hs+--  {-# Inline [0] streamUp #-}+--  {-# Inline [0] streamDown #-}++instance IndexStream (Z:.PointR t) => IndexStream (PointR t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++-- arbitrarily set maximum here to++arbMaxPointR = 100++instance Arbitrary (PointR t) where+  arbitrary = do+    b <- choose (0,arbMaxPointR)+    return $ PointR b+  shrink (PointR j)+    | j<arbMaxPointR = [PointR $ j+1]+    | otherwise = []++--instance Monad m => Serial m (PointR t) where+--  series = PointR . TS.getNonNegative <$> series++++instance SparseBucket (PointL I) where+  {-# Inline manhattan #-}+  manhattan (LtPointL u) (PointL i) = i+  {-# Inline manhattanMax #-}+  manhattanMax (LtPointL u) = u+++-- |+--+-- TODO Is this instance correct? Outside indices shrink?++instance SparseBucket (PointL O) where+  {-# Inline manhattan #-}+  manhattan (LtPointL u) (PointL i) = u-i+  {-# Inline manhattanMax #-}+  manhattanMax (LtPointL u) = u
− Data/PrimitiveArray/Index/Set.hs 
@@ -1,508 +0,0 @@---- | Set with and without interfaces. We provide instances for sets, and--- sets with one or two interfaces. The @First@ and @Last@ annotation is--- purely cosmetical (apart from introducing type safety).--module Data.PrimitiveArray.Index.Set where--import           Control.Applicative ((<$>),(<*>))-import           Control.DeepSeq (NFData(..))-import           Data.Aeson (FromJSON,ToJSON)-import           Data.Binary (Binary)-import           Data.Bits-import           Data.Bits.Extras-import           Data.Serialize (Serialize)-import           Data.Vector.Fusion.Stream.Size-import           Data.Vector.Unboxed.Deriving-import           Data.Vector.Unboxed (Unbox(..))-import           Debug.Trace-import           GHC.Generics-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck (Arbitrary(..), choose, elements)--import           Data.Bits.Ordered-import           Data.PrimitiveArray.Index.Class------ * @newtype@s, @data@ types, @class@es.------ | Certain sets have an interface, a particular element with special--- meaning. In this module, certain ``meanings'' are already provided.--- These include a @First@ element and a @Last@ element. We phantom-type--- these to reduce programming overhead.--newtype Interface t = Iter { getIter :: Int }-  deriving (Eq,Ord,Read,Show,Generic,Num)---- | Declare the interface to be the start of a path.--data First---- | Declare the interface to be the end of a path.--data Last---- | Declare the interface to match anything.------ TODO needed? want to use later in ADPfusion--data Any---- | Newtype for a bitset. We'd use @Word@s but that requires more shape--- instances.------ TODO can we use @Word@s now?--newtype BitSet = BitSet { getBitSet :: Int }-  deriving (Eq,Ord,Read,Generic,FiniteBits,Ranked,Num,Bits)---- | A bitset with one interface.--type BS1I i = BitSet:>Interface i---- | A bitset with two interfaces.--type BS2I i j = BitSet:>Interface i:>Interface j---- | Successor and Predecessor for sets. Designed as a class to accomodate--- sets with interfaces and without interfaces with one function.------ The functions are not written recursively, as we currently only have--- three cases, and we do not want to "reset" while generating successors--- and predecessors.------ Note that sets have a partial order. Within the group of element with--- the same @popCount@, we use @popPermutation@ which has the same stepping--- order for both, @setSucc@ and @setPred@.--class SetPredSucc s where-  -- | Set successor. The first argument is the lower set limit, the second-  -- the upper set limit, the third the current set.-  setSucc :: s -> s -> s -> Maybe s-  -- | Set predecessor. The first argument is the lower set limit, the-  -- second the upper set limit, the third the current set.-  setPred :: s -> s -> s -> Maybe s---- | Masks are used quite often for different types of bitsets. We liberate--- them as a type family.--type family Mask s :: *---- | @Fixed@ allows us to fix some or all bits of a bitset, thereby--- providing @succ/pred@ operations which are only partially free.------ The mask is lazy, this allows us to have @undefined@ for @l@ and @h@.------ @f = getFixedMask .&. getFixed@ are the fixed bits.--- @n = getFixed .&. complement getFixedMask@ are the free bits.--- @to = complement getFixed@ is the to move mask--- @n' = popShiftR to n@ yields the population after the move--- @p = popPermutation undefined n'@ yields the new population permutation--- @p' = popShiftL to p@ yields the population moved back--- @final = p' .|. f@--data Fixed t = Fixed { getFixedMask :: (Mask t) , getFixed :: !t }---- | Assuming a bitset on bits @[0 .. highbit]@, we can apply a mask that--- stretches out those bits over @[0 .. higherBit]@ with @highbit <=--- higherBit@. Any active interfaces are correctly set as well.--class ApplyMask s where-  applyMask :: Mask s -> s -> s------ * Instances----derivingUnbox "Interface"-  [t| forall t . Interface t -> Int |]-  [| \(Iter i) -> i            |]-  [| Iter                      |]--instance Binary    (Interface t)-instance Serialize (Interface t)-instance ToJSON    (Interface t)-instance FromJSON  (Interface t)--instance NFData (Interface t) where-  rnf (Iter i) = rnf i-  {-# Inline rnf #-}--instance Index (Interface i) where-  linearIndex l _ (Iter z) = z - smallestLinearIndex l-  {-# INLINE linearIndex #-}-  smallestLinearIndex (Iter l) = l-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (Iter h) = h-  {-# INLINE largestLinearIndex #-}-  size (Iter l) (Iter h) = h - l + 1-  {-# INLINE size #-}-  inBounds l h z = l <= z && z <= h-  {-# INLINE inBounds #-}----derivingUnbox "BitSet"-  [t| BitSet     -> Int |]-  [| \(BitSet s) -> s   |]-  [| BitSet             |]--instance Show BitSet where-  show (BitSet s) = "<" ++ (show $ activeBitsL s) ++ ">(" ++ show s ++ ")"--instance Binary    BitSet-instance Serialize BitSet-instance ToJSON    BitSet-instance FromJSON  BitSet--instance NFData BitSet where-  rnf (BitSet s) = rnf s-  {-# Inline rnf #-}--instance Index BitSet where-  linearIndex l _ (BitSet z) = z - smallestLinearIndex l -- (2 ^ popCount l - 1)-  {-# INLINE linearIndex #-}-  smallestLinearIndex l = 2 ^ popCount l - 1-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex h = 2 ^ popCount h - 1-  {-# INLINE largestLinearIndex #-}-  size l h = 2 ^ popCount h - 2 ^ popCount l + 1-  {-# INLINE size #-}-  inBounds l h z = popCount l <= popCount z && popCount z <= popCount h-  {-# INLINE inBounds #-}----instance IndexStream z => IndexStream (z:.BitSet) where-  streamUp (ls:.l) (hs:.h) = SM.flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z , (if l <= h then Just l else Nothing))-          step (z , Nothing) = return $ SM.Done-          step (z , Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp   #-}-  streamDown (ls:.l) (hs:.h) = SM.flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z :. (if l <= h then Just h else Nothing))-          step (z :. Nothing) = return $ SM.Done-          step (z :. Just t ) = return $ SM.Yield (z:.t) (z :. setPred l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.(BitSet:>Interface i)) where-  streamUp (ls:.l@(sl:>_)) (hs:.h@(sh:>_)) = SM.flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z, (if sl<=sh then Just (sl:>(Iter . max 0 $ lsbZ sl)) else Nothing))-          step (z , Nothing) = return $ SM.Done-          step (z,  Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.l@(sl:>_)) (hs:.h@(sh:>_)) = SM.flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z, (if sl<=sh then Just (sh:>(Iter . max 0 $ lsbZ sh)) else Nothing))-          step (z , Nothing) = return $ SM.Done-          step (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.(BitSet:>Interface i:>Interface j)) where-  streamUp (ls:.l@(sl:>_:>_)) (hs:.h@(sh:>_:>_)) = SM.flatten mk step Unknown $ streamUp ls hs-    where mk z | sl > sh   = return (z , Nothing)-               | cl == 0   = return (z , Just (0:>0:>0))-               | cl == 1   = let i = lsbZ sl-                             in  return (z , Just (sl :> Iter i :> Iter i))-               | otherwise = let i = lsbZ sl; j = lsbZ (sl `clearBit` i)-                             in  return (z , Just (sl :> Iter i :> Iter j))-               where cl = popCount sl-          step (z , Nothing) = return $ SM.Done-          step (z , Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.l@(sl:>_:>_)) (hs:.h@(sh:>_:>_)) = SM.flatten mk step Unknown $ streamDown ls hs-    where mk z | sl > sh   = return (z , Nothing)-               | ch == 0   = return (z , Just (0:>0:>0))-               | ch == 1   = let i = lsbZ sh-                             in  return (z , Just (sh :> Iter i :> Iter i))-               | otherwise = let i = lsbZ sh; j = lsbZ sh-                             in  return (z , Just (sh :> Iter i :> Iter j))-               where ch = popCount sh-          step (z , Nothing) = return $ SM.Done-          step (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamDown #-}----instance SetPredSucc BitSet where-  setSucc l h s-    | cs > ch                        = Nothing-    | Just s' <- popPermutation ch s = Just s'-    | cs >= ch                       = Nothing-    | cs < ch                        = Just . BitSet $ 2^(cs+1) -1-    where ch = popCount h-          cs = popCount s-  {-# Inline setSucc #-}-  setPred l h s-    | cs < cl                        = Nothing-    | Just s' <- popPermutation ch s = Just s'-    | cs <= cl                       = Nothing-    | cs > cl                        = Just . BitSet $ 2^(cs-1) -1-    where cl = popCount l-          ch = popCount h-          cs = popCount s-  {-# Inline setPred #-}--instance SetPredSucc (BitSet:>Interface i) where-  setSucc (l:>il) (h:>ih) (s:>Iter is)-    | cs > ch                         = Nothing-    | Just is' <- maybeNextActive is s     = Just (s:>Iter is')-    | Just s'  <- popPermutation ch s = Just (s':>Iter (lsbZ s'))-    | cs >= ch                        = Nothing-    | cs < ch                         = let s' = BitSet $ 2^(cs+1)-1 in Just (s' :> Iter (lsbZ s'))-    where ch = popCount h-          cs = popCount s-  {-# Inline setSucc #-}-  setPred (l:>il) (h:>ih) (s:>Iter is)-    | cs < cl                         = Nothing-    | Just is' <- maybeNextActive is s     = Just (s:>Iter is')-    | Just s'  <- popPermutation ch s = Just (s':>Iter (lsbZ s'))-    | cs <= cl                        = Nothing-    | cs > cl                         = let s' = BitSet $ 2^(cs-1)-1 in Just (s' :> Iter (max 0 $ lsbZ s'))-    where cl = popCount l-          ch = popCount h-          cs = popCount s-  {-# Inline setPred #-}--instance SetPredSucc (BitSet:>Interface i:>Interface j) where-  setSucc (l:>il:>jl) (h:>ih:>jh) (s:>Iter is:>Iter js)-    -- early termination-    | cs > ch                         = Nothing-    -- in case nothing was set, set initial set @1@ with both interfaces-    -- pointing to the same element-    | cs == 0                         = Just (1:>0:>0)-    -- when only a single element is set, we just permute the population-    -- and set the single interface-    | cs == 1-    , Just s'  <- popPermutation ch s-    , let is' = lsbZ s'          = Just (s':>Iter is':>Iter is')-    -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (s:>Iter is:>Iter js')-    -- advance other interface, -    | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (s:>Iter is':>Iter js')-    -- find another permutation of the population-    | Just s'  <- popPermutation ch s-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (s':>Iter is':>Iter js')-    -- increasing the population forbidden by upper limit-    | cs >= ch                        = Nothing-    -- increase population-    | cs < ch-    , let s' = BitSet $ 2^(cs+1)-1-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (s':>Iter is':>Iter js')-    where ch = popCount h-          cs = popCount s-  {-# Inline setSucc #-}-  setPred (l:>il:>jl) (h:>ih:>jh) (s:>Iter is:>Iter js)-    -- early termination-    | cs < cl                         = Nothing-    -- in case nothing was set, set initial set @1@ with both interfaces-    -- pointing to the same element-    | cs == 0                         = Nothing-    -- when only a single element is set, we just permute the population-    -- and set the single interface-    | cs == 1-    , Just s'  <- popPermutation ch s-    , let is' = lsbZ s'          = Just (s':>Iter is':>Iter is')-    -- return the single @0@ set-    | cs == 1                         = Just (0:>0:>0)-    -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (s:>Iter is:>Iter js')-    -- advance other interface, -    | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (s:>Iter is':>Iter js')-    -- find another permutation of the population-    | Just s'  <- popPermutation ch s-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (s':>Iter is':>Iter js')-    -- decreasing the population forbidden by upper limit-    | cs <= cl                        = Nothing-    -- decrease population-    | cs > cl && cs > 2-    , let s' = BitSet $ 2^(cs-1)-1-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (s':>Iter is':>Iter js')-    -- decrease population to single-element sets-    | cs > cl && cs == 2              = Just (1:>0:>0)-    where cl = popCount l-          ch = popCount h-          cs = popCount s-  {-# Inline setPred #-}----type instance Mask BitSet = BitSet--type instance Mask (BitSet :> Interface i) = BitSet--type instance Mask (BitSet :> Interface i :> Interface j) = BitSet----derivingUnbox "Fixed"-  [t| forall t . (Unbox t, Unbox (Mask t)) => Fixed t -> (Mask t, t) |]-  [| \(Fixed m s) -> (m,s)              |]-  [| uncurry Fixed                      |]--deriving instance (Eq t     , Eq      (Mask t)) => Eq      (Fixed t)-deriving instance (Ord t    , Ord     (Mask t)) => Ord     (Fixed t)-deriving instance (Read t   , Read    (Mask t)) => Read    (Fixed t)-deriving instance (Show t   , Show    (Mask t)) => Show    (Fixed t)-deriving instance (Generic t, Generic (Mask t)) => Generic (Fixed t)--instance (Generic t, Generic (Mask t), Binary t   , Binary    (Mask t)) => Binary    (Fixed t)-instance (Generic t, Generic (Mask t), Serialize t, Serialize (Mask t)) => Serialize (Fixed t)-{- -- TODO do json instances work automatically here?-instance ToJSON    (Interface t)-instance FromJSON  (Interface t)--}--instance NFData (Fixed t) where-  rnf (Fixed m s) = m `seq` s `seq` ()---- TODO we need to be careful here, that we actually fix all bits that are--- fixed AND that during permutations / increases in popCount we do not set--- an already fixed bit -- as otherwise we lose one in popCount.--testBsS :: BitSet -> Maybe (Fixed BitSet)-testBsS k = setSucc (Fixed 0 0) (Fixed 0 7) (Fixed 4 k)-{-# NoInline testBsS #-}--instance SetPredSucc (Fixed BitSet) where-  setPred (Fixed _ l) (Fixed _ h) (Fixed !m s) = Fixed m <$> setPred l h (s .&. complement m)-  {-# Inline setPred #-}-  --setSucc (Fixed _ l) (Fixed _ h) (Fixed !m s) = Fixed m <$> setSucc l h (s .&. complement m)-  --setSucc (Fixed _ l) (Fixed _ h) (Fixed !m' s) = (Fixed m . (.|. f)) <$> p -- return population, now again including the fixed part @f@-  --  where m = m' .&. h            -- constrain the mask to just the bits until @h@-  --        f = s .&. m             -- these bits are fixed to @1@-  --        n = s .&. complement m  -- these bits are free to be @0@ or @1@ and may move around; this means that @n `subset` complement m@-  --        to = complement m       -- once we have calculated our permutation, we move it to the correct places via @to@-  --        n' = popShiftR to n     -- population without holes. all primes denote that we are in hole-free space.-  --        p' = popPermutation (popCount $ h .&. to) n'  -- permutate the shifted population-  --        p  = popShiftL to <$> p'  -- undo the shift-  setSucc (Fixed _ l) (Fixed _ h) (Fixed !m' s) = traceShow (h,m,s,' ',fb0,fb1,' ',p',p'',p) $ (Fixed m . (.|. fb1)) <$> p-    where m   = m' .&. h-          fb0 = m  .&. complement s-          fb1 = m  .&. s-          p'  = popShiftR m s-          p'' = setSucc (popShiftR m l) (popShiftR m h) p'-          p   = popShiftL m <$> p''-  {-# Inline setSucc #-}--instance SetPredSucc (Fixed (BitSet:>Interface i)) where-  setPred (Fixed _ (l:>li)) (Fixed _ (h:>hi)) (Fixed !m (s:>i))-    | s `testBit` getIter i = (Fixed m . (:> i) . ( `setBit` getIter i)) <$> setPred l h (s .&. complement m)-    | otherwise             = (Fixed m) <$> setPred (l:>li) (h:>hi) ((s .&. complement m):>i)-  {-# Inline setPred #-}-  setSucc (Fixed _ (l:>li)) (Fixed _ (h:>hi)) (Fixed !m (s:>i))-    | s `testBit` getIter i = (Fixed m . (:> i) . ( `setBit` getIter i)) <$> setSucc l h (s .&. complement m)-    | otherwise             = (Fixed m) <$> setSucc (l:>li) (h:>hi) ((s .&. complement m):>i)-  {-# Inline setSucc #-}--instance SetPredSucc (Fixed (BitSet:>Interface i:>Interface j)) where-  setPred (Fixed _ (l:>li:>lj)) (Fixed _ (h:>hi:>hj)) (Fixed !m (s:>i:>j))-    | s `testBit` getIter i && s `testBit` getIter j-    = (Fixed m . (\z       -> (z `setBit` getIter i `setBit` getIter j:>i:>j ))) <$> setPred l h (s .&. complement m)-    | s `testBit` getIter i-    = (Fixed m . (\(z:>j') -> (z `setBit` getIter i                   :>i:>j'))) <$> setPred (l:>lj) (h:>hj) (s .&. complement m :>j)-    | s `testBit` getIter j-    = (Fixed m . (\(z:>i') -> (z `setBit` getIter j                   :>i':>j))) <$> setPred (l:>li) (h:>hi) (s .&. complement m :>i)-  {-# Inline setPred #-}-  setSucc (Fixed _ (l:>li:>lj)) (Fixed _ (h:>hi:>hj)) (Fixed !m (s:>i:>j))-    | s `testBit` getIter i && s `testBit` getIter j-    = (Fixed m . (\z       -> (z `setBit` getIter i `setBit` getIter j:>i:>j ))) <$> setSucc l h (s .&. complement m)-    | s `testBit` getIter i-    = (Fixed m . (\(z:>j') -> (z `setBit` getIter i                   :>i:>j'))) <$> setSucc (l:>lj) (h:>hj) (s .&. complement m :>j)-    | s `testBit` getIter j-    = (Fixed m . (\(z:>i') -> (z `setBit` getIter j                   :>i':>j))) <$> setSucc (l:>li) (h:>hi) (s .&. complement m :>i)-  {-# Inline setSucc #-}----instance ApplyMask BitSet where-  applyMask = popShiftL-  {-# Inline applyMask #-}--instance ApplyMask (BitSet :> Interface i) where-  applyMask m (s:>i)-    | popCount s == 0 = 0:>0-    | otherwise       = popShiftL m s :> (Iter . getBitSet . popShiftL m . BitSet $ 2 ^ getIter i)-  {-# Inline applyMask #-}--instance ApplyMask (BitSet :> Interface i :> Interface j) where-  applyMask m (s:>i:>j)-    | popCount s == 0 = 0:>0:>0-    | popCount s == 1 = s' :> i' :> Iter (getIter i')-    | otherwise       = s' :> i' :> j'-    where s' = popShiftL m s-          i' = Iter . getBitSet . popShiftL m . BitSet $ 2 ^ getIter i-          j' = Iter . getBitSet . popShiftL m . BitSet $ 2 ^ getIter j-  {-# Inline applyMask #-}----arbitraryBitSetMax = 6--instance (Arbitrary t, Arbitrary (Mask t)) => Arbitrary (Fixed t) where-  arbitrary = Fixed <$> arbitrary <*> arbitrary-  shrink (Fixed m s) = [ Fixed m' s' | m' <- shrink m, s' <- shrink s ]--instance Arbitrary BitSet where-  arbitrary = BitSet <$> choose (0,2^arbitraryBitSetMax-1)-  shrink s = let s' = [ s `clearBit` a | a <- activeBitsL s ]-             in  s' ++ concatMap shrink s'--instance Arbitrary (BitSet:>Interface i) where-  arbitrary = do-    s <- arbitrary-    if s==0-      then return (s:>Iter 0)-      else do i <- elements $ activeBitsL s-              return (s:>Iter i)-  shrink (s:>i) =-    let s' = [ (s `clearBit` a:>i)-             | a <- activeBitsL s-             , Iter a /= i ]-             ++ [ 0 :> Iter 0 | popCount s == 1 ]-    in  s' ++ concatMap shrink s'--instance Arbitrary (BitSet:>Interface i:>Interface j) where-  arbitrary = do-    s <- arbitrary-    case (popCount s) of-      0 -> return (s:>Iter 0:>Iter 0)-      1 -> do i <- elements $ activeBitsL s-              return (s:>Iter i:>Iter i)-      _ -> do i <- elements $ activeBitsL s-              j <- elements $ activeBitsL (s `clearBit` i)-              return (s:>Iter i:>Iter j)-  shrink (s:>i:>j) =-    let s' = [ (s `clearBit` a:>i:>j)-             | a <- activeBitsL s-             , Iter a /= i, Iter a /= j ]-             ++ [ 0 `setBit` a :> Iter a :> Iter a-                | popCount s == 2-                , a <- activeBitsL s ]-             ++ [ 0 :> Iter 0 :> Iter 0-                | popCount s == 1 ]-    in  s' ++ concatMap shrink s'-
Data/PrimitiveArray/Index/Subword.hs view
@@ -4,18 +4,24 @@  module Data.PrimitiveArray.Index.Subword where +import Control.Applicative ((<$>)) import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Control.Monad (filterM, guard)+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey) import Data.Binary (Binary)+import Data.Hashable (Hashable) import Data.Serialize (Serialize)-import Data.Vector.Fusion.Stream.Monadic (Step(..), flatten, map)-import Data.Vector.Fusion.Stream.Size+import Data.Vector.Fusion.Stream.Monadic (Step(..), map,flatten) import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic)-import Test.QuickCheck (Arbitrary(..), choose) import Prelude hiding (map)+import Test.QuickCheck (Arbitrary(..), choose)+import Test.SmallCheck.Series as TS +import Math.TriangularNumbers+ import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.IOC   @@ -27,106 +33,149 @@ -- the smallest. We do, however, use (0,0) as the smallest as (0,k) gives -- successively smaller upper triangular parts. -newtype Subword = Subword {fromSubword :: (Int:.Int)}+newtype Subword t = Subword {fromSubword :: (Int:.Int)}   deriving (Eq,Ord,Show,Generic,Read) +fromSubwordFst :: Subword t -> Int+fromSubwordFst (Subword (i:._)) = i+{-# Inline fromSubwordFst #-}++fromSubwordSnd :: Subword t -> Int+fromSubwordSnd (Subword (_:.j)) = j+{-# Inline fromSubwordSnd #-}+ derivingUnbox "Subword"-  [t| Subword -> (Int,Int) |]+  [t| forall t . Subword t -> (Int,Int) |]   [| \ (Subword (i:.j)) -> (i,j) |]   [| \ (i,j) -> Subword (i:.j) |] -instance Binary    Subword-instance Serialize Subword-instance FromJSON  Subword-instance ToJSON    Subword+instance Binary       (Subword t)+instance Serialize    (Subword t)+instance FromJSON     (Subword t)+instance FromJSONKey  (Subword t)+instance ToJSON       (Subword t)+instance ToJSONKey    (Subword t)+instance Hashable     (Subword t) -instance NFData Subword where+instance NFData (Subword t) where   rnf (Subword (i:.j)) = i `seq` rnf j   {-# Inline rnf #-} -subword :: Int -> Int -> Subword+-- | Create a @Subword t@ where @t@ is inferred.++subword :: Int -> Int -> Subword t subword i j = Subword (i:.j) {-# INLINE subword #-} --- | triangular numbers------ A000217+subwordI :: Int -> Int -> Subword I+subwordI i j = Subword (i:.j)+{-# INLINE subwordI #-} -triangularNumber :: Int -> Int-triangularNumber x = (x * (x+1)) `quot` 2-{-# INLINE triangularNumber #-}+subwordO :: Int -> Int -> Subword O+subwordO i j = Subword (i:.j)+{-# INLINE subwordO #-} --- | Size of an upper triangle starting at 'i' and ending at 'j'. "(0,N)" what--- be the normal thing to use.+subwordC :: Int -> Int -> Subword C+subwordC i j = Subword (i:.j)+{-# INLINE subwordC #-} -upperTri :: Subword -> Int-upperTri (Subword (i:.j)) = triangularNumber $ j-i+1-{-# INLINE upperTri #-} --- | Subword indexing. Given the longest subword and the current subword,--- calculate a linear index "[0,..]". "(l,n)" in this case means "l"ower bound,--- length "n". And "(i,j)" is the normal index.------ TODO probably doesn't work right with non-zero base ?! -subwordIndex :: Subword -> Subword -> Int-subwordIndex (Subword (l:.n)) (Subword (i:.j)) = adr n (i,j) -- - adr n (l,n)-  where-    adr n (i,j) = (n+1)*i - triangularNumber i + j-{-# INLINE subwordIndex #-}+instance Index (Subword t) where+  newtype LimitType (Subword t) = LtSubword Int+  linearIndex (LtSubword n) (Subword (i:.j)) = toLinear n (i,j)+  {-# Inline linearIndex #-}+  size (LtSubword n) = linearizeUppertri (0,n)+  {-# Inline size #-}+  inBounds (LtSubword h) (Subword (i:.j)) = 0<=i && i<=j && j<=h+  {-# Inline inBounds #-}+  zeroBound = subword 0 0+  {-# Inline zeroBound #-}+  zeroBound' = LtSubword 0+  {-# Inline zeroBound' #-}+  totalSize (LtSubword n) = [fromIntegral (n+1) ^ 2 `div` 2]+  {-# Inline totalSize #-}+  fromLinearIndex = error "implement me"+  showBound = error "implement me"+  showIndex = error "implement me" -subwordFromIndex :: Subword -> Int -> Subword-subwordFromIndex = error "subwordFromIndex not implemented"-{-# INLINE subwordFromIndex #-}+deriving instance Eq      (LimitType (Subword t))+deriving instance Generic (LimitType (Subword t))+deriving instance Read    (LimitType (Subword t))+deriving instance Show    (LimitType (Subword t)) +-- | @Subword I@ (inside) +instance IndexStream z => IndexStream (z:.Subword I) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-} -instance Index Subword where-  linearIndex _ h i = subwordIndex h i-  {-# Inline linearIndex #-}-  smallestLinearIndex _ = error "still needed?"-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex h = upperTri h -1-  {-# Inline largestLinearIndex #-}-  size _ h = upperTri h-  {-# Inline size #-}-  inBounds _ (Subword (_:.h)) (Subword (i:.j)) = 0<=i && i<=j && j<=h-  {-# Inline inBounds #-}+-- | @Subword O@ (outside).+--+-- Note: @streamUp@ really needs to use @streamDownMk@ / @streamDownStep@+-- for the right order of indices! -instance IndexStream z => IndexStream (z:.Subword) where-  streamUp (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten mk step Unknown $ streamUp ls hs-    where mk z = return (z,h,h)-          step (z,i,j)-            | i < l     = return $ Done-            | j > h     = return $ Skip (z,i-1,i-1)-            | otherwise = return $ Yield (z:.subword i j) (z,i,j+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}+instance IndexStream z => IndexStream (z:.Subword O) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamDown ls hs   {-# Inline streamUp #-}-  streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten mk step Unknown $ streamDown ls hs-    where mk z = return (z,l,h)-          step (z,i,j)-            | i > h     = return $ Done-            | j < i     = return $ Skip (z,i+1,h)-            | otherwise = return $ Yield (z:.subword i j) (z,i,j-1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}   {-# Inline streamDown #-} --- Default methods don't inline in a good way!+-- | @Subword C@ (complement) -instance IndexStream Subword where-  streamUp l h = map (\(Z:.i) -> i) $ streamUp (Z:.l) (Z:.h)+instance IndexStream z => IndexStream (z:.Subword C) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++-- | generic @mk@ for @streamUp@ / @streamDown@++streamUpMk h z = return (z,h,h)+{-# Inline [0] streamUpMk #-}++streamUpStep l h (z,i,j)+  | i < l     = return $ Done+  | j > h     = return $ Skip (z,i-1,i-1)+  | otherwise = return $ Yield (z:.subword i j) (z,i,j+1)+{-# Inline [0] streamUpStep #-}++streamDownMk l h z = return (z,l,h)+{-# Inline [0] streamDownMk #-}++streamDownStep h (z,i,j)+  | i > h     = return $ Done+  | j < i     = return $ Skip (z,i+1,h)+  | otherwise = return $ Yield (z:.subword i j) (z,i,j-1)+{-# Inline [0] streamDownStep #-}++instance (IndexStream (Z:.Subword t)) => IndexStream (Subword t) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)   {-# INLINE streamUp #-}-  streamDown l h = map (\(Z:.i) -> i) $ streamDown (Z:.l) (Z:.h)+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)   {-# INLINE streamDown #-} -instance Arbitrary Subword where+instance Arbitrary (Subword t) where   arbitrary = do-    a <- choose (0,100)-    b <- choose (0,100)+    a <- choose (0,20)+    b <- choose (0,20)     return $ Subword (min a b :. max a b)   shrink (Subword (i:.j))     | i<j       = [Subword (i:.j-1), Subword (i+1:.j)]     | otherwise = []++instance Monad m => Serial m (Subword t) where+  series = do+    i <- TS.getNonNegative <$> series+    j <- TS.getNonNegative <$> series+    guard $ i<=j+    return $ subword i j+    {-+    let nns :: Series m Int = TS.getNonNegative <$> series+    ps <- nns >< nns+    let qs = [ subword i j | (i,j) <- ps, i<=j ]+    return qs+    -}
+ Data/PrimitiveArray/Index/Unit.hs view
@@ -0,0 +1,82 @@++-- | Unit indices admit a single element to be memoized. We can't use @()@+-- because we want to attach phantom types.++module Data.PrimitiveArray.Index.Unit where++import Control.Applicative (pure)+import Control.DeepSeq (NFData(..))+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey)+import Data.Binary (Binary)+import Data.Hashable (Hashable)+import Data.Serialize (Serialize)+import Data.Vector.Fusion.Stream.Monadic (Step(..), map)+import Data.Vector.Unboxed.Deriving+import GHC.Generics (Generic)+import Prelude hiding (map)+import Test.QuickCheck (Arbitrary(..), choose)++import Data.PrimitiveArray.Index.Class++++data Unit t = Unit+  deriving (Eq,Ord,Show,Generic,Read)++derivingUnbox "Unit"+  [t| forall t . Unit t -> () |]+  [| \ Unit -> ()   |]+  [| \ ()   -> Unit |]++instance Binary       (Unit t)+instance Serialize    (Unit t)+instance FromJSON     (Unit t)+instance FromJSONKey  (Unit t)+instance ToJSON       (Unit t)+instance ToJSONKey    (Unit t)+instance Hashable     (Unit t)++instance NFData (Unit t) where+  rnf Unit = ()+  {-# Inline rnf #-}++instance Index (Unit t) where+  data LimitType (Unit t) = LtUnit+  linearIndex _ _ = 0+  {-# Inline linearIndex #-}+  size _ = 1+  {-# Inline size #-}+  inBounds _ _ = True+  {-# Inline inBounds #-}+  zeroBound = Unit+  {-# Inline zeroBound #-}+  zeroBound' = LtUnit+  {-# Inline zeroBound' #-}+  totalSize LtUnit = return 1+  {-# Inline [0] totalSize #-}+  fromLinearIndex _ _ = Unit+  {-# Inline fromLinearIndex #-}+  showBound _ = ["LtUnit"]+  showIndex _ = ["Unit"]++deriving instance Eq      (LimitType (Unit t))+deriving instance Generic (LimitType (Unit t))+deriving instance Read    (LimitType (Unit t))+deriving instance Show    (LimitType (Unit t))++instance IndexStream z => IndexStream (z:.Unit t) where+  streamUp (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamUp ls hs+  {-# Inline streamUp #-}+  streamDown (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamDown ls hs+  {-# Inline streamDown #-}++instance (IndexStream (Z:.Unit t)) => IndexStream (Unit t) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++instance Arbitrary (Unit t) where+  arbitrary = pure Unit+  shrink Unit = []+
− Data/PrimitiveArray/QuickCheck/Index/Set.hs 
@@ -1,31 +0,0 @@--module Data.PrimitiveArray.QuickCheck.Index.Set where--import Control.Applicative-import Data.Bits-import Data.Word (Word)-import Debug.Trace-import Test.QuickCheck hiding (Fixed(..), (.&.))--import Data.PrimitiveArray.Index.Set------ TODO what exactly does the mask fix? Only bits already @1@, or every bit--- as it is? The mask should actually freeze-fix those bits, where we are--- set to @1@!--prop_Fixed_BitSet_setSucc (u :: Word, Fixed m s :: Fixed BitSet) = traceShow (tgo, tsu) $ tgo == tsu-  where tgo = go s-        tsu = (getFixed <$> setSucc (Fixed 0 0) (Fixed 0 h) (Fixed m s))-        fb1 = m .&. s -- fixed bits to 1-        fb0 = m .&. complement s  -- fixed bits to 0-        h   = bit (fromIntegral $ u `mod` 8) - 1-        go x -- continue creating successors, until the mask criterion is met (again).-          | Nothing <- ssx = Nothing-          | Just x' <- ssx-          , fb0 == m .&. complement x'-          , fb1 == m .&. x' = traceShow ('j',fb0,fb1,m,x,x') $ Just x'-          | Just x' <- ssx  = traceShow ('g',fb0,fb1,m,x,x') $ go x'-          where ssx = setSucc 0 h x-
+ Data/PrimitiveArray/Sparse.hs view
@@ -0,0 +1,7 @@++module Data.PrimitiveArray.Sparse+  ( module Data.PrimitiveArray.Sparse.IntBinSearch+  ) where++import Data.PrimitiveArray.Sparse.IntBinSearch+
+ Data/PrimitiveArray/Sparse/BinSearch.hs view
@@ -0,0 +1,233 @@++-- | This solution to holding a sparse set of elements for dynamic programming. The underlying+-- representation requires @O (log n)@ access time for each read or write, where @n@ is the number+-- of elements to be stored. It uses an experimental "bucketing" system to provide better lower and+-- upper bounds than otherwise possible.+--+-- TODO @ADPfusion / FillTyLvl@ handles actually filling the tables. In case all @BigOrder@ tables+-- are dense and of the same dimensional extent, we are fine. However if at least one table is+-- dense, while others are sparse, we will have write to nothing, which should not crash. In case of+-- all-sparse tables for a BigOrder, we have to calculate the union of all indices. This all is+-- currently not happening...+--+-- TODO require @readMaybe@ and @indexMaybe@ to return @Nothing@ on missing elements. This requires+-- an extension of the @Class@ structure for tables.++module Data.PrimitiveArray.Sparse.BinSearch where++import           Control.Monad.Primitive (PrimState,PrimMonad)+import           Control.Monad.ST (ST)+import           Debug.Trace (traceShow)+import qualified Control.Monad.State.Strict as SS+import qualified Data.HashMap.Strict as HMS+import qualified Data.Vector.Algorithms.Intro as VAI+import qualified Data.Vector.Algorithms.Search as VAS+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++import           Data.PrimitiveArray.Class+import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index        -- TODO only while @SparseBucket@ is here++++-- | This is a sparse matrix, where only a subset of indices have data associated.++data Sparse w v sh e = Sparse+  { sparseUpperBound  :: !(LimitType sh)+  -- ^ The upper bound for the DP matrix. Not the upper bound of indexes in use, but the theoretical+  -- upper bound.+  , sparseData        :: !(v e)+  -- ^ Vector with actually existing data.+  , sparseIndices     :: !(w sh)+  -- ^ The index of each @sh@ is the same as of the corresponding @sparseData@ structure. Indices+  -- should be ordered as required by the @streamUp@ function, to facilitate filling @Sparse@ by+  -- going from left to right.+  , manhattanStart    :: !(VU.Vector Int)+  -- ^ Provides left/right boundaries into @sparseIndices@ to speed up index search. Should be one+  -- larger than the largest index to look up, to always provides a good excluded bound.+  }++type Unboxed  w sh e = Sparse w VU.Vector sh e++type Storable w sh e = Sparse w VS.Vector sh e++type Boxed    w sh e = Sparse w  V.Vector sh e++++-- | Currently, our mutable variant of sparse matrices will keep indices and manhattan starts+-- immutable as well.++data instance MutArr m (Sparse w v sh e) = MSparse+  { msparseUpperBound :: !(LimitType sh)+  , msparseData       :: !(VG.Mutable v (PrimState m) e)+  , msparseIndices    :: !(w sh) -- (VG.Mutable w (PrimState m) sh)+  , mmanhattanStart   :: !(VU.Vector Int) -- (VU.MVector (PrimState m) Int)+  }+--  deriving (Generic,Typeable)+++type instance FillStruc (Sparse w v sh e) = (w sh)++++instance+  ( Index sh, SparseBucket sh, Eq sh, Ord sh+  , VG.Vector w sh , VG.Vector w (Int,sh), VG.Vector w (Int,(Int,sh))+  , VG.Vector v e+#if ADPFUSION_DEBUGOUTPUT+  , Show sh, Show (LimitType sh), Show e+#endif+  ) => PrimArrayOps (Sparse w v) sh e where++  -- ** pure operations++  {-# Inline upperBound #-}+  upperBound Sparse{..} = sparseUpperBound+  {-# Inline unsafeIndex #-}+  unsafeIndex Sparse{..} idx = case manhattanIndex sparseUpperBound manhattanStart sparseIndices idx of+      Nothing -> error "unsafeIndex of non-existing index"+      Just v  -> VG.unsafeIndex sparseData v+  {-# Inline safeIndex #-}+  safeIndex Sparse{..} = fmap (VG.unsafeIndex sparseData) . manhattanIndex sparseUpperBound manhattanStart sparseIndices++  -- ** monadic operations++  {-# Inline unsafeFreezeM #-}+  unsafeFreezeM MSparse{..} = do+    let sparseUpperBound = msparseUpperBound+        sparseIndices = msparseIndices+        manhattanStart = mmanhattanStart+    sparseData <- VG.unsafeFreeze msparseData+    return Sparse{..}+  {-# Inline unsafeThawM #-}+  unsafeThawM Sparse{..} = do+    let msparseUpperBound = sparseUpperBound+        msparseIndices = sparseIndices+        mmanhattanStart = manhattanStart+    msparseData <- VG.unsafeThaw sparseData+    return MSparse{..}+  {-# Inline upperBoundM #-}+  upperBoundM MSparse{..} = msparseUpperBound+  {-# Inline newM #-}+  newM = error "not implemented, use newSM"+  {-# Inline newWithM #-}+  newWithM = error "not implemented, use newWithSM"+  {-# Inline readM #-}+  readM MSparse{..} idx = do+    case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices idx of+      Nothing -> error "read of non-existing element"+      Just v  -> VGM.unsafeRead msparseData v+  -- | Note that @writeM@ will fail loudly, because we can specialize in @FillTyLvl@ to use+  -- non-failing writes.+  {-# Inline writeM #-}+  writeM MSparse{..} idx elm = do+    case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices idx of+      Nothing -> error "read of non-existing element"+      Just v  -> VGM.unsafeWrite msparseData v elm+  {-# Inline newSM #-}+  newSM h fs' = do+    fs <- VG.thaw (VG.map (\i -> (manhattan h i, i)) fs') >>= \v -> VAI.sort v >> VG.unsafeFreeze v+    let msparseUpperBound = h+        msparseIndices = VG.force $ VG.map snd fs+        -- For any manhattan distance not found in the distances, we set to the length of the the+        -- @msparseIndices@ vector. Perform reverse-scan to update all manhattan start distances.+        go :: VU.MVector s Int -> ST s ()+        go mv = do+          VG.forM_ (VG.reverse $ VG.indexed fs) $ \(i,(mh,_)) -> VGM.write mv mh i+        mmanhattanStart = VG.modify go $ VG.replicate (manhattanMax h +1) (VG.length fs)+    msparseData <- VGM.new $ VG.length msparseIndices+    return $ MSparse {..}+  {-# Inline newWithSM #-}+  newWithSM h fs' e = do+    mv <- newSM h fs'+    VGM.set (msparseData mv) e+    return mv+  {-# Inline safeWriteM #-}+  safeWriteM MSparse{..} sh e = case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices sh of+      Nothing -> return ()+      Just v  -> VGM.unsafeWrite msparseData v e+  {-# Inline safeReadM #-}+  safeReadM MSparse{..} sh = case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices sh of+      Nothing -> return Nothing+      Just v  -> Just <$> VGM.unsafeRead msparseData v+  -- ** implement me+  transformShape = error "implement me"+  fromListM = error "implement me"++++++-- * Helper functions.++-- | Find the index with manhattan helper+--+-- TODO consider using binary search instead of a linear scan here!+-- e.g.: @k = VAS.binarySearchByBounds (==)@+--+-- NOTE running times with 100x100 DP problem "NeedlemanWunsch"+-- full findIndex of sixs:              0,050,000 cells/sec+-- using manhattan buckets, findIndex:  5,000,000 cells/sec+-- using binarySearch on slices:       11,000,000 cells/sec+--+-- On a 1000x1000 DP NeedlemanWunsch problem, binary search on slices is at 6,500,000 cells/sec.++manhattanIndex+  :: (SparseBucket sh, VG.Vector v sh, Eq sh, Ord sh)+  => LimitType sh -> Vector Int -> v sh -> sh -> Maybe Int+{-# Inline manhattanIndex #-}+manhattanIndex ub mstart sixs idx = fmap (+l) . binarySearch idx $ VG.unsafeSlice l (h-l+1) sixs+  where+    b = manhattan ub idx+    -- lower and upper bucket bounds+    l = mstart `VU.unsafeIndex` b+    h = mstart `VU.unsafeIndex` (b+1)++binarySearch :: (Eq sh, Ord sh, VG.Vector v sh) => sh -> v sh -> Maybe Int+{-# Inline binarySearch #-}+binarySearch e v = go 0 (VG.length v -1)+  where+    go :: Int -> Int -> Maybe Int+    go !l !r =+      let !m = (r+l) `div` 2+          !x = VG.unsafeIndex v m+      in  if r<l then Nothing else case compare e x of+                                    LT -> go l (m-1)+                                    EQ -> Just m+                                    GT -> go (m+1) r+++-- | Given two index vectors of the same shape, will return the correctly ordered vector of+-- the union of indices.+--+-- TODO This requires that @Ord (Shape O)@ uses the @Down@ instance of Ord! We need to fix this in+-- the @Index@ modules.+--+-- TODO Rewrite to allow fusion without intermediate vectors using uncons. This will make it+-- possible to chain applications. @stream@ should be fine for this.++mergeIndexVectors :: (Eq sh, Ord sh, VG.Vector w sh) => w sh -> w sh -> w sh+{-# Inlinable mergeIndexVectors #-}+mergeIndexVectors xs ys = VG.create $ do+  let lxs = VG.length xs+      lys = VG.length ys+  mv <- VGM.new $ lxs + lys+  let go !n !i !j+        | i>=lxs && j>=lys = return n+        | j>=lys = VG.unsafeIndexM xs i >>= VGM.unsafeWrite mv n >> go (n+1) (i+1) j+        | i>=lxs = VG.unsafeIndexM ys j >>= VGM.unsafeWrite mv n >> go (n+1) i (j+1)+        | otherwise = do+            x <- VG.unsafeIndexM xs i+            y <- VG.unsafeIndexM ys j+            if | x==y -> VGM.unsafeWrite mv n x >> go (n+1) (i+1) (j+1)+               | x< y -> VGM.unsafeWrite mv n x >> go (n+1) (i+1) j+               | x> y -> VGM.unsafeWrite mv n y >> go (n+1) i     (j+1)+  n <- go 0 0 0+  return $ VGM.unsafeTake n mv+
+ Data/PrimitiveArray/Sparse/IntBinSearch.hs view
@@ -0,0 +1,286 @@++{-# Language MagicHash #-}++-- | This solution to holding a sparse set of elements for dynamic programming. The underlying+-- representation requires @O (log n)@ access time for each read or write, where @n@ is the number+-- of elements to be stored. It uses an experimental "bucketing" system to provide better lower and+-- upper bounds than otherwise possible.+--+-- TODO @ADPfusion / FillTyLvl@ handles actually filling the tables. In case all @BigOrder@ tables+-- are dense and of the same dimensional extent, we are fine. However if at least one table is+-- dense, while others are sparse, we will have write to nothing, which should not crash. In case of+-- all-sparse tables for a BigOrder, we have to calculate the union of all indices. This all is+-- currently not happening...+--+-- This version requires working @fromLinearIndex@ but is potentially faster.++module Data.PrimitiveArray.Sparse.IntBinSearch where++import           Control.Monad.Primitive (PrimState,PrimMonad)+import           Control.Monad.ST (ST)+import           Data.Bits.Extras (msb)+import           Debug.Trace (traceShow)+import qualified Control.Monad.State.Strict as SS+import qualified Data.HashMap.Strict as HMS+import qualified Data.Vector.Algorithms.Radix as Sort+import qualified Data.Vector.Algorithms.Search as VAS+import qualified Data.Vector as V+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Generic as VG+import qualified Data.Vector.Generic.Mutable as VGM+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import           GHC.Exts ( Int(..), Int#(..), (==#), (-#), (/=#), (*#), (+#), (<=#), remInt#, quotInt#, uncheckedIShiftRA#, (<#) )++import           Data.PrimitiveArray.Class+import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index        -- TODO only while @SparseBucket@ is here++++-- | This is a sparse matrix, where only a subset of indices have data associated.++data Sparse w v sh e = Sparse+  { sparseUpperBound  :: !(LimitType sh)+  -- ^ The upper bound for the DP matrix. Not the upper bound of indexes in use, but the theoretical+  -- upper bound.+  , sparseData        :: !(v e)+  -- ^ Vector with actually existing data.+  , sparseIndices     :: !(VU.Vector Int)+  -- ^ Linearly encoded sparse indices+  , manhattanStart    :: !(VU.Vector Int)+  -- ^ Provides left/right boundaries into @sparseIndices@ to speed up index search. Should be one+  -- larger than the largest index to look up, to always provides a good excluded bound.+  }++type Unboxed  w sh e = Sparse w VU.Vector sh e++type Storable w sh e = Sparse w VS.Vector sh e++type Boxed    w sh e = Sparse w  V.Vector sh e++++-- | Currently, our mutable variant of sparse matrices will keep indices and manhattan starts+-- immutable as well.++data instance MutArr m (Sparse w v sh e) = MSparse+  { msparseUpperBound :: !(LimitType sh)+  , msparseData       :: !(VG.Mutable v (PrimState m) e)+  , msparseIndices    :: !(VU.Vector Int)+  , mmanhattanStart   :: !(VU.Vector Int)+  }+--  deriving (Generic,Typeable)+++type instance FillStruc (Sparse w v sh e) = (w sh)++++instance+  ( Index sh, SparseBucket sh, Eq sh, Ord sh+  , VG.Vector w sh , VG.Vector w (Int,sh), VG.Vector w (Int,(Int,sh)), VG.Vector w (Int,Int), VG.Vector w Int+  , VG.Vector v e+#if ADPFUSION_DEBUGOUTPUT+  , Show sh, Show (LimitType sh), Show e+#endif+  ) => PrimArrayOps (Sparse w v) sh e where++  -- ** pure operations++  {-# Inline upperBound #-}+  upperBound Sparse{..} = sparseUpperBound+  {-# Inline unsafeIndex #-}+  unsafeIndex Sparse{..} idx = case manhattanIndex sparseUpperBound manhattanStart sparseIndices idx of+      Nothing -> error "unsafeIndex of non-existing index"+      Just v  -> VG.unsafeIndex sparseData v+  {-# Inline safeIndex #-}+  safeIndex Sparse{..} = fmap (VG.unsafeIndex sparseData) . manhattanIndex sparseUpperBound manhattanStart sparseIndices++  -- ** monadic operations++  {-# Inline unsafeFreezeM #-}+  unsafeFreezeM MSparse{..} = do+    let sparseUpperBound = msparseUpperBound+        sparseIndices = msparseIndices+        manhattanStart = mmanhattanStart+    sparseData <- VG.unsafeFreeze msparseData+    return Sparse{..}+  {-# Inline unsafeThawM #-}+  unsafeThawM Sparse{..} = do+    let msparseUpperBound = sparseUpperBound+        msparseIndices = sparseIndices+        mmanhattanStart = manhattanStart+    msparseData <- VG.unsafeThaw sparseData+    return MSparse{..}+  {-# Inline upperBoundM #-}+  upperBoundM MSparse{..} = msparseUpperBound+  {-# Inline newM #-}+  newM = error "not implemented, use newSM"+  {-# Inline newWithM #-}+  newWithM = error "not implemented, use newWithSM"+  {-# Inline readM #-}+  readM MSparse{..} idx = do+    case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices idx of+      Nothing -> error "read of non-existing element"+      Just v  -> VGM.unsafeRead msparseData v+  -- | Note that @writeM@ will fail loudly, because we can specialize in @FillTyLvl@ to use+  -- non-failing writes.+  {-# Inline writeM #-}+  writeM MSparse{..} idx elm = do+    case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices idx of+      Nothing -> error "read of non-existing element"+      Just v  -> VGM.unsafeWrite msparseData v elm+  {-# Inline newSM #-}+  newSM h fs' = do+    let msparseUpperBound = h+        -- sort sparse indices by (manhattan, linearIndex)+        {-# Inline srt #-}+        srt x y = let ix = fromLinearIndex h x+                      iy = fromLinearIndex h y+                  in  compare (manhattan h ix, x) (manhattan h iy, y)+        {-# Inline radixsrt #-}+        radixsrt i x = let ix = fromLinearIndex h x in Sort.radix i (manhattan h ix, x)+    msparseIndices <- do+      marr <- VG.thaw (VU.convert $ VG.map (linearIndex h) fs')+      Sort.sortBy (Sort.passes (undefined :: (Int,Int))) (Sort.size (undefined :: Int)) radixsrt marr+      VG.unsafeFreeze marr+    let -- For any manhattan distance not found in the distances, we set to the length of the the+        -- @msparseIndices@ vector. Perform reverse-scan to update all manhattan start distances.+        go :: VU.MVector s Int -> ST s ()+        {-# Inline go #-}+        go mv = do+          VG.forM_ (VG.reverse $ VG.indexed msparseIndices) $ \(i,k) -> let lix = fromLinearIndex h k; mh = manhattan h lix in VGM.write mv mh i+    let mmanhattanStart = VU.modify go $ VG.replicate (manhattanMax h +1) (VG.length msparseIndices)+    msparseData <- VGM.new $ VG.length msparseIndices+    return $ MSparse {..}+  {-# Inline newWithSM #-}+  newWithSM h fs' e = do+    mv <- newSM h fs'+    VGM.set (msparseData mv) e+    return mv+  {-# Inline safeWriteM #-}+  safeWriteM MSparse{..} sh e = case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices sh of+      Nothing -> return ()+      Just v  -> VGM.unsafeWrite msparseData v e+  {-# Inline safeReadM #-}+  safeReadM MSparse{..} sh = case manhattanIndex msparseUpperBound mmanhattanStart msparseIndices sh of+      Nothing -> return Nothing+      Just v  -> Just <$> VGM.unsafeRead msparseData v+  -- ** implement me+  transformShape = error "implement me"+  fromListM = error "implement me"++++instance (Index sh, VG.Vector v e, VG.Vector v e') ⇒ PrimArrayMap (Sparse w v) sh e e' where+  {-# Inline mapArray #-}+  mapArray f sparse = sparse{sparseData = VG.map f (sparseData sparse)}++++++-- * Helper functions.++-- | Find the index with manhattan helper+--+-- TODO consider using binary search instead of a linear scan here!+-- e.g.: @k = VAS.binarySearchByBounds (==)@+--+-- NOTE running times with 100x100 DP problem "NeedlemanWunsch"+-- full findIndex of sixs:              0,050,000 cells/sec+-- using manhattan buckets, findIndex:  5,000,000 cells/sec+-- using binarySearch on slices:       11,000,000 cells/sec+--+-- On a 1000x1000 DP NeedlemanWunsch problem, binary search on slices is at 6,500,000 cells/sec.++manhattanIndex+  :: (SparseBucket sh, Index sh)+  => LimitType sh -> Vector Int -> VU.Vector Int -> sh -> Maybe Int+{-# Inline manhattanIndex #-}+manhattanIndex ub mstart sixs idx = fmap (+l) . binarySearch (linearIndex ub idx) $ VG.unsafeSlice l (h-l) sixs+  where+    b = manhattan ub idx+    -- lower and upper bucket bounds+    l = mstart `VU.unsafeIndex` b+    h = mstart `VU.unsafeIndex` (b+1)++binarySearch :: Int -> VU.Vector Int -> Maybe Int+{-# Inline binarySearch #-}+{-+binarySearch k xs =+  let r1 = binarySearch1 k xs+      r2 = binarySearch2 k xs+  in if r1==r2 then r1 else error $ show (k,xs,r1,r2)+-}+{-+-- 1000x1000 at @1000 yields 3,050,000 cells / second+binarySearch (I# e) v = go 0 pp+  where+    -- largest index to check+    (I# r) = VG.length v -1+    -- largest power of two <= (r+1)+    pp = (2 ^ (max 0 $ msb $ VG.length v -1))+    -- wrap the actual non-branching worker function+    go :: Int -> Int -> Maybe Int+    {-# Inline go #-}+    go (I# l) (I# p) = let i = I# (go' l p) in if (VG.length v<1 || i<0) then Nothing else Just i+    -- @go'@ should be non-branching, and use a minimal number of array reads.+    go' :: Int# -> Int# -> Int#+    {-# Inline go' #-}+    go' l p+      -- we are done and will return the proposed position of the last element found or -1+      | 1# <- p ==# 0# = (e ==# x) *# l -# (e /=# x)+      | otherwise      = let i = go' (l +# (p *# chk *# leq)) (quotInt# p 2#) -- (uncheckedIShiftRA# p 1#)+                             -- (I# ii) = traceShow (I# l, I# p, I# i2r, I# x, I# leq) (I# i)+                         in  i -- i+      where i2r    = l +# (p *# chk) -- index to read+            (I# x) = VU.unsafeIndex v (I# i2r)+            leq    = x <=# e+            newl   = l +# p+            chk    = newl <=# r+-}+--+-- 1000x1000 at @1000 yields 6,030,000 cells / second+binarySearch e v = go 0 (VG.length v -1)+  where+    go :: Int -> Int -> Maybe Int+    go !l !r =+      let !m = (r+l) `div` 2+          !x = VG.unsafeIndex v m+      in  if r<l then Nothing else case compare e x of+                                    LT -> go l (m-1)+                                    EQ -> Just m+                                    GT -> go (m+1) r+--+++-- | Given two index vectors of the same shape, will return the correctly ordered vector of+-- the union of indices.+--+-- TODO This requires that @Ord (Shape O)@ uses the @Down@ instance of Ord! We need to fix this in+-- the @Index@ modules.+--+-- TODO Rewrite to allow fusion without intermediate vectors using uncons. This will make it+-- possible to chain applications. @stream@ should be fine for this.++mergeIndexVectors :: (Eq sh, Ord sh, VG.Vector w sh) => w sh -> w sh -> w sh+{-# Inlinable mergeIndexVectors #-}+mergeIndexVectors xs ys = VG.create $ do+  let lxs = VG.length xs+      lys = VG.length ys+  mv <- VGM.new $ lxs + lys+  let go !n !i !j+        | i>=lxs && j>=lys = return n+        | j>=lys = VG.unsafeIndexM xs i >>= VGM.unsafeWrite mv n >> go (n+1) (i+1) j+        | i>=lxs = VG.unsafeIndexM ys j >>= VGM.unsafeWrite mv n >> go (n+1) i (j+1)+        | otherwise = do+            x <- VG.unsafeIndexM xs i+            y <- VG.unsafeIndexM ys j+            if | x==y -> VGM.unsafeWrite mv n x >> go (n+1) (i+1) (j+1)+               | x< y -> VGM.unsafeWrite mv n x >> go (n+1) (i+1) j+               | x> y -> VGM.unsafeWrite mv n y >> go (n+1) i     (j+1)+  n <- go 0 0 0+  return $ VGM.unsafeTake n mv+
PrimitiveArray.cabal view
@@ -1,33 +1,38 @@+Cabal-version:  2.2 Name:           PrimitiveArray-Version:        0.6.1.0-License:        BSD3+Version:        0.10.1.1+License:        BSD-3-Clause License-file:   LICENSE Maintainer:     choener@bioinf.uni-leipzig.de-author:         Christian Hoener zu Siederdissen, 2011-2015-copyright:      Christian Hoener zu Siederdissen, 2011-2015-homepage:       http://www.bioinf.uni-leipzig.de/Software/gADP/+author:         Christian Hoener zu Siederdissen, 2011-2021+copyright:      Christian Hoener zu Siederdissen, 2011-2021 homepage:       https://github.com/choener/PrimitiveArray bug-reports:    https://github.com/choener/PrimitiveArray/issues Stability:      Experimental Category:       Data Build-type:     Simple-Cabal-version:  >=1.10.0-tested-with:    GHC == 7.8.4, GHC == 7.10.1+tested-with:    GHC == 8.8, GHC == 8.10, GHC == 9.0 Synopsis:       Efficient multidimensional arrays Description:+                <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>+                .                 This library provides efficient multidimensional arrays. Import                 @Data.PrimitiveArray@ for indices, lenses, and arrays.                 .-                For ADPfusion users, the library also provides the machinary to+                For+                <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized ADP>+                users, the library also provides the machinary to                 fill tables in the correct order required by usual CYK-style                 parsers, or regular grammars (used e.g. in alignment-                algorithms). This means that unless your grammar require a+                algorithms). This means that unless your grammar requires a                 strange order in which parsing is to be performed, it will                 mostly "just work".                 .-                In general all operations are (highly) unsafe, no-                bounds-checking or other sanity-checking is performed.-                Operations are aimed toward efficiency as much as possible.+                In general operations do not perform bounds-checking or other+                sanity-checking and are aimed towards efficiency as much as+                possible. Users (like @ADPfusion@) should perform their own+                bounds-checking, outside of code that performs "loop-like"+                operations.   @@ -37,75 +42,174 @@   -Library-  Exposed-modules:-    Data.PrimitiveArray-    Data.PrimitiveArray.Class-    Data.PrimitiveArray.Dense-    Data.PrimitiveArray.FillTables-    Data.PrimitiveArray.Index-    Data.PrimitiveArray.Index.Class-    Data.PrimitiveArray.Index.Complement-    Data.PrimitiveArray.Index.Int-    Data.PrimitiveArray.Index.Outside-    Data.PrimitiveArray.Index.PhantomInt-    Data.PrimitiveArray.Index.Point-    Data.PrimitiveArray.Index.Set-    Data.PrimitiveArray.Index.Subword-    Data.PrimitiveArray.QuickCheck.Index.Set-  build-depends: base                     >= 4.7      && < 4.9-               , aeson                    >= 0.8      && < 0.10-               , binary                   >= 0.7      && < 0.8-               , bits                     >= 0.4      && < 0.5-               , cereal                   >= 0.4      && < 0.5-               , deepseq                  >= 1.3      && < 1.5-               , OrderedBits              >= 0.0.0.1  && < 0.0.1.0-               , primitive                >= 0.5.4    && < 0.7-               , QuickCheck               >= 2.7      && < 2.9-               , vector                   >= 0.10     && < 0.11-               , vector-binary-instances  >= 0.2      && < 0.3-               , vector-th-unbox          >= 0.2      && < 0.3+flag debug+  description:  Enable bounds checking and various other debug operations at the cost of a significant performance penalty.+  default:      False+  manual:       True++flag debugoutput+  description:  Enable debug output, which spams the screen full of index information+  default:      False+  manual:       True++flag llvm+  description:  use llvm+  default:      False+  manual:       True++flag debugdump+  description:  Enable dumping intermediate / core files+  default:      False+  manual:       True++flag dump-core+  description: Dump HTML for the core generated by GHC during compilation+  default:     False+  manual:      True++++common deps+  build-depends: base                     >= 4.7      &&  < 5.0+               , aeson                    >= 0.8+               , binary                   >= 0.7+               , bits                     >= 0.4+               , cereal                   >= 0.4+               , cereal-vector            >= 0.2+               , containers+               , deepseq                  >= 1.3+               , hashable                 >= 1.2+               , hashtables               >= 1.2+               , lens                     >= 4.0+               , log-domain               >= 0.10+               , mtl                      >= 2.0+               , primitive                >= 0.5.4+               , QuickCheck               >= 2.7+               , smallcheck               >= 1.1+               , text                     >= 1.0+               , unordered-containers     >= 0.2+               , vector                   >= 0.11+               , vector-algorithms        >= 0.8+               , vector-binary-instances  >= 0.2+               , vector-th-unbox          >= 0.2+               --+               , DPutils                  == 0.1.1.*+               , OrderedBits              == 0.0.2.*   default-extensions: BangPatterns+                    , CPP+                    , DataKinds                     , DefaultSignatures                     , DeriveDataTypeable+                    , DeriveFunctor                     , DeriveGeneric+                    , DerivingStrategies                     , FlexibleContexts                     , FlexibleInstances+                    , FunctionalDependencies+                    , GADTs                     , GeneralizedNewtypeDeriving                     , MultiParamTypeClasses+                    , MultiWayIf+                    , PatternSynonyms+                    , PolyKinds                     , RankNTypes+                    , RecordWildCards                     , ScopedTypeVariables                     , StandaloneDeriving                     , TemplateHaskell+                    , TypeApplications                     , TypeFamilies                     , TypeOperators                     , UndecidableInstances+                    , UnicodeSyntax   default-language:     Haskell2010   ghc-options:     -O2     -funbox-strict-fields+  if flag(debug)+    cpp-options: -DADPFUSION_CHECKS+    ghc-options: -fno-ignore-asserts --disable-optimizations+  if flag(debugoutput)+    cpp-options: -DADPFUSION_DEBUGOUTPUT   +Library+  import:+    deps+  Exposed-modules:+    Data.PrimitiveArray+    Data.PrimitiveArray.Checked+    Data.PrimitiveArray.Class+    Data.PrimitiveArray.Dense+    Data.PrimitiveArray.Sparse+    Data.PrimitiveArray.Sparse.BinSearch+    Data.PrimitiveArray.Sparse.IntBinSearch+    Data.PrimitiveArray.HashTable+    Data.PrimitiveArray.Index+    Data.PrimitiveArray.Index.BitSet0+    Data.PrimitiveArray.Index.BitSet1+    Data.PrimitiveArray.Index.BitSetClasses+    Data.PrimitiveArray.Index.Class+    Data.PrimitiveArray.Index.Int+    Data.PrimitiveArray.Index.IOC+    Data.PrimitiveArray.Index.PhantomInt+    Data.PrimitiveArray.Index.Point+    Data.PrimitiveArray.Index.Subword+    Data.PrimitiveArray.Index.Unit+++ test-suite properties+  import:+    deps+  build-depends: base+               , tasty                    >= 0.11+               , tasty-quickcheck         >= 0.8+               , tasty-smallcheck         >= 0.8+               , tasty-th                 >= 0.1+               --+               , PrimitiveArray   type:     exitcode-stdio-1.0   main-is:     properties.hs+  other-modules:+    QuickCheck+    SmallCheck+    Common   ghc-options:     -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs:     tests-  default-language:-    Haskell2010-  default-extensions: TemplateHaskell-  build-depends: base-               , PrimitiveArray-               , QuickCheck-               , test-framework               >= 0.8  && < 0.9-               , test-framework-quickcheck2   >= 0.3  && < 0.4-               , test-framework-th            >= 0.2  && < 0.3+  build-depends: PrimitiveArray+++benchmark Lookup+  import:+    deps+  type:+    exitcode-stdio-1.0+  main-is:+    Lookup.hs+  hs-source-dirs:+    bench+  build-depends: PrimitiveArray+               , criterion        ^>= 1.5+  if flag(llvm)+    ghc-options:+      -fllvm+      -optlo-O3+  if flag(debugdump)+    ghc-options:+      -ddump-to-file+      -ddump-simpl+      -dsuppress-all+  if flag(dump-core)+    build-depends: dump-core+    ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html+
README.md view
@@ -1,8 +1,9 @@-[![Build Status](https://travis-ci.org/choener/PrimitiveArray.svg?branch=master)](https://travis-ci.org/choener/PrimitiveArray)+![github action: CI](https://github.com/choener/PrimitiveArray/actions/workflows/ci.yml/badge.svg)+![github action: hackage](https://github.com/choener/PrimitiveArray/actions/workflows/hackage.yml/badge.svg)  # PrimitiveArray -[*generalized ADPfusion Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)+[*generalized Algebraic Dynamic Programming Homepage*](http://www.bioinf.uni-leipzig.de/Software/gADP/)  PrimitiveArray provides operations on multi-dimensional arrays. Internally, the representation is based on the vector library, while the multi-dimensional
+ bench/Lookup.hs view
@@ -0,0 +1,50 @@++module Main where++import Criterion.Main++import Data.PrimitiveArray as PA++++go ∷ (Index i) ⇒ Int → Unboxed i Int → i → Int+{-# Inline go #-}+go !c !pa !i = f c i 0+  where f  0 !i !acc = acc+        f !k !i !acc = f (k-1) i (acc + pa ! i)++go1 ∷ Int → Unboxed (Z:.Int) Int → (Z:.Int) → Int+{-# NoInline go1 #-}+go1 = go++go2 ∷ Int → Unboxed (Z:.Int:.Int) Int → (Z:.Int:.Int) → Int+{-# NoInline go2 #-}+go2 = go++go3 ∷ Int → Unboxed (Z:.Int:.Int:.Int) Int → (Z:.Int:.Int:.Int) → Int+{-# NoInline go3 #-}+go3 = go++main ∷ IO ()+main = do+  let !(pa1 ∷ Unboxed (Z:.Int)           Int) = PA.fromAssocs (ZZ:..LtInt 10)                       0 []+  let !(pa2 ∷ Unboxed (Z:.Int:.Int)      Int) = PA.fromAssocs (ZZ:..LtInt 10:..LtInt 10)            0 []+  let !(pa3 ∷ Unboxed (Z:.Int:.Int:.Int) Int) = PA.fromAssocs (ZZ:..LtInt 10:..LtInt 10:..LtInt 10) 0 []+  defaultMain+    [ bgroup "1"+        [ bench "10^0" $ whnf (go1          1 pa1) (Z:.5)+        , bench "10^3" $ whnf (go1       1000 pa1) (Z:.5)+        , bench "10^6" $ whnf (go1    1000000 pa1) (Z:.5)+        , bench "10^9" $ whnf (go1 1000000000 pa1) (Z:.5)+        ]+    , bgroup "2"+        [ bench "      1" $ whnf (go2       1 pa2) (Z:.5:.5)+        , bench "   1000" $ whnf (go2    1000 pa2) (Z:.5:.5)+        , bench "1000000" $ whnf (go2 1000000 pa2) (Z:.5:.5)+        ]+    , bgroup "3"+        [ bench "      1" $ whnf (go3       1 pa3) (Z:.5:.5:.5)+        , bench "   1000" $ whnf (go3    1000 pa3) (Z:.5:.5:.5)+        , bench "1000000" $ whnf (go3 1000000 pa3) (Z:.5:.5:.5)+        ]+    ]
changelog.md view
@@ -1,3 +1,92 @@+0.11.1.1++- version bump on DPutils++0.10.1.0+--------++- introduction of @Data.PrimitiveArray.Sparse@ which uses different sparsification options. The+  default is @D.P.S.Search@ based on binary search.+- All array operations, pure or mutable are now based on a single, unified class. Mostly because+  mutable operations go via a data family anyway.++0.10.0.0+--------++- Rewrote Data.PrimitiveArray.Dense to accept all vector types using one+  interface. This is a breaking change, since @Unboxed@ becomes @Dense+  Data.Vector.Unboxed.Vector@, but now @Dense v@ accepts any @v@ as underlying+  storage vector. Breaking occurs only at user sites where the actual vector+  type needs to be specified. This tends to be very localized.++0.9.1.1+-------++- OrderedBits version bump++0.9.1.0+-------++- Arbitrary instance(s), field lenses that are probably not a good idea (don't use them!)++0.9.0.0+-------++- large-scale changes+- associated data families for bounds++0.8.1.0+-------++- inclusion of Upperlimit data family to simplify declaration of upper limits++0.8.0.1+-------++- PointL delays inlining to phase 0 for table filling. This is part of the+  close-to-C optimization effort for linear languages.+- disabling smallcheck until I fix how things are generated++0.8.0.0+-------++- renamed Interface (Iter) to Boundary (Boundary)+- Typeable instances for Dense primitive arrays+- EdgeBoundary index structure+- changes and fixes to quickcheck/smallcheck+- added ScoreMatrix module with simple score and distance matrix structure+  (requires log-domain)++0.7.2.0+-------++- JSONKey (To/From) for index types.++0.7.1.0+-------++- minor updates to dependencies+- tasty framework+- Subword/upper triangular indexing provided by DPutils++0.7.0.1+-------++- Data.PrimitiveArray.Checked to capture index out-of-bounds problems++0.7.0.0+-------++- vector <= 0.11 support; including compatibility layer+- redesigned Index structures (for dealing with Inside/Outside/Complement)++0.6.1.1+-------++- Hashable instances for all index structures+- Hashable instances for Unboxed and Boxed arrays. *These require Hashable+  instances for vectors, which are not available by default*+ 0.6.1.0 -------
+ tests/Common.hs view
@@ -0,0 +1,40 @@++module Common where++import           Control.Arrow ((&&&), second)+import           Data.List (nub, sort, group)+import qualified Data.Map.Strict as M+import qualified Data.Set as S++import           Data.PrimitiveArray.Index.Class+++-- * generic functions++-- | Generates a list of, eg, @PointL@s. This are then grouped according to+-- the @linearIndex@. Within each group, there should only be @PointL@s+-- with the same value.++uniquenessTest ∷ (Ord a, Index a) ⇒ LimitType a → LimitType a → [a] → Bool+uniquenessTest low hgh xs = all allEq ys && all allEq zs+  where ys  = M.fromListWith S.union . map (second S.singleton) . map (linearIndex hgh &&& id) $ xs+        zs  = M.fromListWith S.union . map (second S.singleton) . map (id &&& linearIndex hgh) $ xs+{-# Inlineable uniquenessTest #-}+{-+uniquenessTest low xs = all allEq ys && all allEq zs+  where hgh = maximum xs+        ys  = group . sort . map (linearIndex low hgh &&& id) $ xs+        zs  = group . sort . map (id &&& linearIndex low hgh) $ xs+-}++-- | are all @xs@ equal to each other++allEq = (1==) . S.size+{-# Inline allEq #-}++{-+allEq [] = True+allEq (x:xs) = all (x==) xs+-}++
+ tests/QuickCheck.hs view
@@ -0,0 +1,36 @@++module QuickCheck where++import Data.List (maximumBy)+import Data.Ord (comparing)+import Test.QuickCheck+import Test.Tasty.QuickCheck+import Test.Tasty.TH++import Data.PrimitiveArray.Index.Class+--import Data.PrimitiveArray.Index.EdgeBoundary+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+--import Data.PrimitiveArray.Index.Set+--import Data.PrimitiveArray.Index.Subword++import Common++++-- * Uniqueness tests++-- prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (LtPointL 0) (LtPointL $ maximum $ map fromPointL xs) xs++-- prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) (maximumBy (comparing fromSubwordSnd) xs) xs++-- prop_EdgeBoundary_I_unique (xs :: [EdgeBoundary I]) = uniquenessTest (0 :-> 0) (maximumBy (comparing fromEdgeBoundarySnd) xs) xs++-- | TODO check that bitsets produce the correct number of bits when counting++--prop_BitSet1_First_I_set (numberOfBits ∷ ()) = strm == lst+--  where strm = sort . unId $ streamUp (LtBitSet1 0) (LtBitSet1 0) :: IO [BitSet1 First I]+--        lst  = sort []++quickcheck_tests = $(testGroupGenerator)+
+ tests/SmallCheck.hs view
@@ -0,0 +1,37 @@++module SmallCheck where++import Control.Applicative+import Data.Bits+import Data.List (nub, sort, group, maximumBy)+import Data.Ord (comparing)+import Data.Word (Word)+import Debug.Trace+import Test.SmallCheck+import Test.Tasty+import Test.Tasty.SmallCheck+import Test.Tasty.TH++import Data.PrimitiveArray.Index.Class+--import Data.PrimitiveArray.Index.EdgeBoundary+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+--import Data.PrimitiveArray.Index.Set+--import Data.PrimitiveArray.Index.Subword++import Common++++-- * Uniqueness tests. The @xs@ lists are fairly small.++prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (LtPointL 0) (LtPointL $ maximum $ map fromPointL xs) xs++-- prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) (maximumBy (comparing fromSubwordSnd) xs) xs++-- prop_EdgeBoundary_I_unique (xs :: [EdgeBoundary I]) = uniquenessTest (0 :-> 0) (maximumBy (comparing fromEdgeBoundarySnd) xs) xs++++smallcheck_tests = $(testGroupGenerator)+
tests/properties.hs view
@@ -1,17 +1,73 @@  module Main where -import           Test.Framework.Providers.QuickCheck2-import           Test.Framework.TH+import Control.Applicative+import Data.Bits+import Data.List (nub, sort, group)+import Data.Word (Word)+import Test.Tasty+import Test.Tasty.TH+import qualified Test.QuickCheck as QC -import qualified  Data.PrimitiveArray.QuickCheck.Index.Set as QCS+import Data.PrimitiveArray.Index.IOC+import Data.PrimitiveArray.Index.Point+--import Data.PrimitiveArray.Index.Set+import Data.PrimitiveArray.Index.Class +import QuickCheck+import SmallCheck  --- prop_Fixed_BitSet_setSucc = QCS.prop_Fixed_BitSet_setSucc +-- * Points +-- | @linearIndex <-> fromLinearIndex@ +prop_FromLinear_ZP ( x :: PointL I, a')+  | ix == frm = True+  | otherwise = error $ show (x,a',lt, ix, lin, frm)+  where ltx = LtPointL $ QC.getNonNegative a' + fromPointL x+        lt  = ZZ:..ltx+        ix  = Z:.x+        lin = linearIndex lt ix+        frm = fromLinearIndex lt lin++prop_FromLinear_ZPP ( x :: PointL I, y :: PointL I, a', b')+  | ix == frm = True+  | otherwise = error $ show (x,y,a',b',lt, ix, lin, frm)+  where ltx = LtPointL $ QC.getNonNegative a' + fromPointL x+        lty = LtPointL $ QC.getNonNegative b' + fromPointL y+        lt  = ZZ:..ltx:..lty+        ix  = Z:.x:.y+        lin = linearIndex lt ix+        frm = fromLinearIndex lt lin++-- * Sets++-- TODO what exactly does the mask fix? Only bits already @1@, or every bit+-- as it is? The mask should actually freeze-fix those bits, where we are+-- set to @1@!++--prop_Fixed_BitSet_setSucc (u :: Word, Fixed m s :: Fixed (BitSet I)) = traceShow (tgo, tsu) $ tgo == tsu+--  where tgo = go s+--        tsu = (getFixed <$> setSucc (Fixed 0 0) (Fixed 0 h) (Fixed m s))+--        fb1 = m .&. s -- fixed bits to 1+--        fb0 = m .&. complement s  -- fixed bits to 0+--        h   = bit (fromIntegral $ u `mod` 8) - 1+--        go x -- continue creating successors, until the mask criterion is met (again).+--          | Nothing <- ssx = Nothing+--          | Just x' <- ssx+--          , fb0 == m .&. complement x'+--          , fb1 == m .&. x' = traceShow ('j',fb0,fb1,m,x,x') $ Just x'+--          | Just x' <- ssx  = traceShow ('g',fb0,fb1,m,x,x') $ go x'+--          where ssx = setSucc 0 h x+++ main :: IO ()-main = $(defaultMainGenerator)+main = do+  defaultMain $ testGroup ""+    [ -- quickcheck_tests+--    , smallcheck_tests+    ]