PrimitiveArray 0.8.0.1 → 0.9.0.0

raw patch · 25 files changed

+987/−1244 lines, 25 filesdep +lensdep +mtldep ~DPutilsdep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, mtl

Dependency ranges changed: DPutils, vector

API changes (from Hackage documentation)

Files

• Data/PrimitiveArray.hs +2/−4
• Data/PrimitiveArray/Checked.hs +4/−4
• Data/PrimitiveArray/Class.hs +67/−23
• Data/PrimitiveArray/Dense.hs +99/−70
• Data/PrimitiveArray/FillTables.hs +0/−64
• Data/PrimitiveArray/Index.hs +11/−4
• Data/PrimitiveArray/Index/BitSet0.hs +139/−0
• Data/PrimitiveArray/Index/BitSet1.hs +165/−0
• Data/PrimitiveArray/Index/BitSetClasses.hs +164/−0
• Data/PrimitiveArray/Index/Class.hs +106/−63
• Data/PrimitiveArray/Index/EdgeBoundary.hs +0/−141
• Data/PrimitiveArray/Index/Int.hs +22/−19
• Data/PrimitiveArray/Index/PhantomInt.hs +25/−50
• Data/PrimitiveArray/Index/Point.hs +51/−43
• Data/PrimitiveArray/Index/Set.hs +0/−670
• Data/PrimitiveArray/Index/Subword.hs +27/−16
• Data/PrimitiveArray/Index/Unit.hs +23/−10
• Data/PrimitiveArray/ScoreMatrix.hs +5/−5
• Data/PrimitiveArray/Vector/Compat.hs +0/−25
• PrimitiveArray.cabal +43/−14
• changelog.md +11/−0
• tests/Common.hs +3/−3
• tests/QuickCheck.hs +10/−6
• tests/SmallCheck.hs +6/−6
• tests/properties.hs +4/−4

@@ -2,14 +2,12 @@ module Data.PrimitiveArray    ( module Data.PrimitiveArray.Class   , module Data.PrimitiveArray.Dense-  , module Data.PrimitiveArray.FillTables+--  , module Data.PrimitiveArray.FillTables   , module Data.PrimitiveArray.Index-  , module Data.PrimitiveArray.Vector.Compat   ) where  import Data.PrimitiveArray.Class import Data.PrimitiveArray.Dense-import Data.PrimitiveArray.FillTables+--import Data.PrimitiveArray.FillTables import Data.PrimitiveArray.Index-import Data.PrimitiveArray.Vector.Compat 

@@ -19,11 +19,11 @@ -- outside of the allocated area.  --(!) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> elm-(!) arr@(Unboxed l h v) idx-  | not (uncurry inBounds (bounds arr) idx) = error $ "(!) / inBounds: out of bounds! " ++ show (l,h,idx)-  | li < 0 || li >= len = error $ "(!) / linearIndex: out of bounds! " ++ show (l,h,li,len,idx)+(!) arr@(Unboxed 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 l h idx+  where li  = linearIndex h idx         len = VG.length v {-# Inline (!) #-} 

@@ -10,14 +10,18 @@  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.Monadic as SM-import           Data.Vector.Fusion.Util -import Data.PrimitiveArray.Index+import           Data.PrimitiveArray.Index.Class   @@ -33,21 +37,21 @@   -- | Return the bounds of the array. All bounds are inclusive, as in   -- @[lb..ub]@ -  boundsM :: MutArr m (arr sh elm) -> (sh,sh)+  upperBoundM :: MutArr m (arr sh elm) -> LimitType sh    -- | Given lower and upper bounds and a list of /all/ elements, produce a   -- mutable array. -  fromListM :: PrimMonad m => sh -> sh -> [elm] -> m (MutArr m (arr sh elm))+  fromListM :: PrimMonad m => LimitType sh -> [elm] -> m (MutArr m (arr sh elm))    -- | Creates a new array with the given bounds with each element within the   -- array being in an undefined state. -  newM :: PrimMonad m => sh -> sh -> m (MutArr m (arr sh elm))+  newM :: PrimMonad m => LimitType sh -> m (MutArr m (arr sh elm))    -- | Creates a new array with all elements being equal to 'elm'. -  newWithM :: PrimMonad m => sh -> sh -> elm -> m (MutArr m (arr sh elm))+  newWithM :: PrimMonad m => LimitType sh -> elm -> m (MutArr m (arr sh elm))    -- | Reads a single element in the array. @@ -65,7 +69,7 @@    -- | Returns the bounds of an immutable array, again inclusive bounds: @ [lb..ub] @. -  bounds :: arr sh elm -> (sh,sh)+  upperBound :: arr sh elm -> LimitType sh    -- | 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@@ -85,7 +89,7 @@    -- | Savely transform the shape space of a table. -  transformShape :: (Index sh') => (sh -> sh') -> arr sh elm -> arr sh' elm+  transformShape :: (Index sh') => (LimitType sh -> LimitType sh') -> arr sh elm -> arr sh' elm  class (Index sh) => PrimArrayMap arr sh e e' where @@ -95,17 +99,26 @@   +data PAErrors+  = PAEUpperBound+  deriving (Eq,Generic)++instance Show PAErrors where+  show (PAEUpperBound) = "Upper bound is too large for @Int@ size!"+++ -- | 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+(!) arr idx = assert (inBounds (upperBound arr) idx) $ unsafeIndex arr idx {-# INLINE (!) #-}  -- | 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 marr idx = inBounds (upperBoundM marr) idx {-# INLINE inBoundsM #-}  -- -- | Given two arrays with the same dimensionality, their respective starting@@ -127,32 +140,63 @@  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+  => 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, MPrimArrayOps arr sh elm, PrimArrayOps arr sh elm)+  ⇒ LimitType sh+  → elm+  → m (arr sh elm)+newWithPA ub def = do+  ma ← newWithM ub def+  unsafeFreeze ma+{-# Inlinable newWithPA #-}++-- | 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, MPrimArrayOps arr sh elm, 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)) . unId . SM.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 = P.map (\k -> (k,unsafeIndex arr k)) . unId . SM.toList $ streamUp zeroBound' (upperBound arr) where {-# INLINE assocs #-}  -- | 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, MPrimArrayOps arr sh elm) => LimitType sh -> [elm] -> arr sh elm+fromList ub xs = runST $ fromListM ub xs >>= unsafeFreeze {-# 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, MPrimArrayOps arr sh elm) => LimitType sh -> elm -> [(sh,elm)] -> arr sh elm+fromAssocs ub def xs = runST $ fromAssocsM ub def xs >>= unsafeFreeze {-# INLINE fromAssocs #-}  -- -- | Determines if an index is valid for a given immutable array.@@ -163,8 +207,8 @@  -- | 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) . unId . SM.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 #-}  

@@ -22,62 +22,82 @@ import           Control.Monad.Primitive (PrimState) import           Data.Aeson (ToJSON,FromJSON) import           Data.Binary (Binary)+import           Data.Hashable (Hashable) import           Data.Serialize (Serialize)+import           Data.Typeable (Typeable) import           Data.Vector.Binary-import           Data.Vector.Serialize import           Data.Vector.Generic.Mutable as GM hiding (length)+import           Data.Vector.Serialize import           Data.Vector.Unboxed.Mutable (Unbox)+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           Data.Hashable (Hashable)-import           Data.Typeable (Typeable)+import           Data.Data   import           Data.PrimitiveArray.Class-import           Data.PrimitiveArray.Index+import           Data.PrimitiveArray.Index.Class    -- * Unboxed, multidimensional arrays. -data Unboxed sh e = Unboxed !sh !sh !(VU.Vector e)-  deriving (Read,Show,Eq,Generic,Typeable)+data Unboxed sh e = Unboxed !(LimitType sh) !(VU.Vector 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)-instance (Hashable  sh, Hashable  e, Hashable (VU.Vector e), Unbox e) => Hashable  (Unboxed sh e)+deriving instance (Eq      (LimitType sh), Eq e     , Unbox e) ⇒ Eq      (Unboxed sh e)+deriving instance (Generic (LimitType sh), Generic e, Unbox e) ⇒ Generic (Unboxed sh e)+deriving instance (Read    (LimitType sh), Read e   , Unbox e) ⇒ Read    (Unboxed sh e)+deriving instance (Show    (LimitType sh), Show e   , Unbox e) ⇒ Show    (Unboxed sh e)+deriving instance+  ( Data sh, Data (LimitType sh)+  , Data e, Unbox e+  ) ⇒ Data    (Unboxed sh e) -instance (NFData sh) => NFData (Unboxed sh e) where-  rnf (Unboxed l h xs) = rnf l `seq` rnf h `seq` rnf xs+instance (Binary    (LimitType sh), Binary    e, Unbox e, Generic (LimitType sh), Generic e) => Binary    (Unboxed sh e)+instance (Serialize (LimitType sh), Serialize e, Unbox e, Generic (LimitType sh), Generic e) => Serialize (Unboxed sh e)+instance (ToJSON    (LimitType sh), ToJSON    e, Unbox e, Generic (LimitType sh), Generic e) => ToJSON    (Unboxed sh e)+instance (FromJSON  (LimitType sh), FromJSON  e, Unbox e, Generic (LimitType sh), Generic e) => FromJSON  (Unboxed sh e)+instance (Hashable  (LimitType sh), Hashable  e, Hashable (VU.Vector e), Unbox e, Generic (LimitType sh), Generic e) => Hashable  (Unboxed sh e)++instance (NFData (LimitType sh)) => NFData (Unboxed sh e) where+  rnf (Unboxed h xs) = rnf h `seq` rnf xs   {-# Inline rnf #-} -data instance MutArr m (Unboxed sh e) = MUnboxed !sh !sh !(VU.MVector (PrimState m) e)+data instance MutArr m (Unboxed sh e) = MUnboxed !(LimitType sh) !(VU.MVector (PrimState m) e)   deriving (Generic,Typeable) -instance (NFData sh) => NFData (MutArr m (Unboxed sh e)) where-  rnf (MUnboxed l h xs) = rnf l `seq` rnf h `seq` rnf xs+instance (NFData (LimitType sh)) => NFData (MutArr m (Unboxed sh e)) where+  rnf (MUnboxed h xs) = 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+instance+  ( Index sh+  , Unbox elm+#if ADPFUSION_DEBUGOUTPUT+  , Show sh, Show (LimitType sh), Show elm+#endif+  ) ⇒ MPrimArrayOps Unboxed sh elm where+  upperBoundM (MUnboxed h _) = h+  fromListM h xs = do+    ma <- newM h+    let (MUnboxed _ mba) = ma+    zipWithM_ (\k x -> assert (length xs == size h) $ unsafeWrite mba k x) [0.. size 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+  newM h = MUnboxed h `liftM` new (size h)+  newWithM h def = do+    ma <- newM h+    let (MUnboxed _ mba) = ma+    forM_ [0 .. size 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 = unsafeWrite mba (linearIndex l h idx) elm-  {-# INLINE boundsM #-}+  readM  (MUnboxed h mba) idx     = assert (inBounds h idx) $ unsafeRead  mba (linearIndex h idx)+  writeM (MUnboxed 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 upperBoundM #-}   {-# INLINE fromListM #-}   {-# NoInline newM #-}   {-# INLINE newWithM #-}@@ -85,62 +105,71 @@   {-# INLINE writeM #-}  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 #-}+  upperBound (Unboxed h _) = h+  unsafeFreeze (MUnboxed h mba) = Unboxed h `liftM` G.unsafeFreeze mba+  unsafeThaw   (Unboxed  h ba) = MUnboxed h `liftM` G.unsafeThaw ba+  unsafeIndex  (Unboxed  h ba) idx = G.unsafeIndex ba (linearIndex h idx)+  transformShape tr (Unboxed h ba) = Unboxed (tr h) ba+  {-# INLINE upperBound #-}   {-# INLINE unsafeFreeze #-}   {-# INLINE unsafeThaw #-}   {-# INLINE unsafeIndex #-}   {-# INLINE transformShape #-}  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)+  map f (Unboxed h xs) = Unboxed h (VU.map f xs)   {-# INLINE map #-}    -- * Boxed, multidimensional arrays. -data Boxed sh e = Boxed !sh !sh !(V.Vector e)-  deriving (Read,Show,Eq,Generic,Typeable)+data Boxed sh e = Boxed !(LimitType sh) !(V.Vector e) -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)-instance (Hashable  sh, Hashable  e, Hashable (V.Vector e)) => Hashable  (Boxed sh e)+deriving instance (Read    (LimitType sh), Read e) ⇒ Read (Boxed sh e)+deriving instance (Show    (LimitType sh), Show e) ⇒ Show (Boxed sh e)+deriving instance (Eq      (LimitType sh), Eq   e) ⇒ Eq   (Boxed sh e)+deriving instance (Generic (LimitType sh), Generic e) ⇒ Generic (Boxed sh e)+deriving instance+  ( Data sh, Data (LimitType sh)+  , Data e+  ) ⇒ Data    (Boxed sh e) -instance (NFData sh, NFData e) => NFData (Boxed sh e) where-  rnf (Boxed l h xs) = rnf l `seq` rnf h `seq` rnf xs++instance (Binary    (LimitType sh), Binary    e, Unbox e, Generic (LimitType sh), Generic e) => Binary    (Boxed sh e)+instance (Serialize (LimitType sh), Serialize e, Unbox e, Generic (LimitType sh), Generic e) => Serialize (Boxed sh e)+instance (ToJSON    (LimitType sh), ToJSON    e, Unbox e, Generic (LimitType sh), Generic e) => ToJSON    (Boxed sh e)+instance (FromJSON  (LimitType sh), FromJSON  e, Unbox e, Generic (LimitType sh), Generic e) => FromJSON  (Boxed sh e)+instance (Hashable  (LimitType sh), Hashable  e, Hashable (V.Vector e), Unbox e, Generic (LimitType sh), Generic e) => Hashable  (Boxed sh e)++instance (NFData (LimitType sh), NFData e) => NFData (Boxed sh e) where+  rnf (Boxed h xs) = rnf h `seq` rnf xs   {-# Inline rnf #-} -data instance MutArr m (Boxed sh e) = MBoxed !sh !sh !(V.MVector (PrimState m) e)+data instance MutArr m (Boxed sh e) = MBoxed !(LimitType sh) !(V.MVector (PrimState m) e)   deriving (Generic,Typeable) -instance (NFData sh) => NFData (MutArr m (Boxed sh e)) where-  rnf (MBoxed l h _) = rnf l `seq` rnf h -- no rnf for the data !+instance (NFData (LimitType sh)) => NFData (MutArr m (Boxed sh e)) where+  rnf (MBoxed h xs) = rnf h -- no rnf for the data !   {-# Inline rnf #-}  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+  upperBoundM (MBoxed h _) = h+  fromListM h xs = do+    ma <- newM h+    let (MBoxed _ mba) = ma+    zipWithM_ (\k x -> assert (length xs == size h) $ unsafeWrite mba k x) [0 .. size 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+  newM h =+    MBoxed h `liftM` new (size h)+  newWithM h def = do+    ma <- newM h+    let (MBoxed _ mba) = ma+    forM_ [0 .. size 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 #-}+  readM  (MBoxed h mba) idx     = assert (inBounds h idx) $ GM.unsafeRead  mba (linearIndex h idx)+  writeM (MBoxed h mba) idx elm = assert (inBounds h idx) $ GM.unsafeWrite mba (linearIndex h idx) elm+  {-# INLINE upperBoundM #-}   {-# INLINE fromListM #-}   {-# NoInline newM #-}   {-# INLINE newWithM #-}@@ -148,19 +177,19 @@   {-# INLINE writeM #-}  instance (Index sh) => 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 #-}+  upperBound (Boxed h _) = h+  unsafeFreeze (MBoxed h mba) = Boxed h `liftM` G.unsafeFreeze mba+  unsafeThaw   (Boxed h ba) = MBoxed h `liftM` G.unsafeThaw ba+  unsafeIndex (Boxed h ba) idx = assert (inBounds h idx) $ G.unsafeIndex ba (linearIndex h idx)+  transformShape tr (Boxed h ba) = Boxed (tr h) ba+  {-# INLINE upperBound #-}   {-# INLINE unsafeFreeze #-}   {-# INLINE unsafeThaw #-}   {-# INLINE unsafeIndex #-}   {-# INLINE transformShape #-}  instance (Index sh) => PrimArrayMap Boxed sh e e' where-  map f (Boxed l h xs) = Boxed l h (V.map f xs)+  map f (Boxed h xs) = Boxed h (V.map f xs)   {-# INLINE map #-}  

@@ -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 #-}-

@@ -1,22 +1,29 @@  module Data.PrimitiveArray.Index   ( module Data.PrimitiveArray.Index.Class-  , module Data.PrimitiveArray.Index.EdgeBoundary+  , 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.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.EdgeBoundary hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)+--import Data.PrimitiveArray.Index.EdgeBoundary hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep) import Data.PrimitiveArray.Index.Int 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.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 

@@ -0,0 +1,139 @@++-- | 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 (Eq,Ord,Generic,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 #-}++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'+

@@ -0,0 +1,165 @@++-- | 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]++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 = Boundary 0+  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+  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 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'+

@@ -0,0 +1,164 @@++-- | 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 (Eq,Ord,Generic,Num)++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 #-}++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.+--+-- 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++++-- | for 'Test.QuickCheck.Arbitrary'++arbitraryBitSetMax ∷ Int+arbitraryBitSetMax = 6+

@@ -3,17 +3,22 @@  import           Control.Applicative import           Control.DeepSeq (NFData(..))+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.Generics import qualified Data.Vector.Fusion.Stream.Monadic as SM import           Test.QuickCheck+import           Text.Printf   @@ -22,7 +27,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) |]@@ -61,7 +66,7 @@ -- 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) |]@@ -89,7 +94,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)  derivingUnbox "Z"   [t| Z -> () |]@@ -116,30 +121,51 @@ -- 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 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] -  -- | 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 (Eq,Ord,Show,Num,Bounded,Integral,Real,Enum)   @@ -147,69 +173,86 @@ -- 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+  size _ = 1   {-# INLINE size #-}-  inBounds _ _ _ = True+  inBounds _ _ = True   {-# INLINE inBounds #-}+  zeroBound = Z+  {-# Inline zeroBound #-}+  zeroBound' = ZZ+  {-# Inline zeroBound' #-}+  totalSize ZZ = [1]+  {-# Inline [1] totalSize #-}  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 #-}  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)+  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 #-} -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 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 (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))++--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 #-} 

@@ -1,141 +0,0 @@---- | Edge boundaries capture edge indexing of the type @From :-> To@, where--- both @From@ and @To@ are @Int@s. Each such @Int@ gives one of the two--- nodes between edge exists.--module Data.PrimitiveArray.Index.EdgeBoundary where--import Control.Applicative ((<$>))-import Control.DeepSeq (NFData(..))-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(..), map)-import Data.Vector.Unboxed.Deriving-import Debug.Trace-import GHC.Generics (Generic)-import Prelude hiding (map)-import Test.QuickCheck (Arbitrary(..), choose)-import Test.SmallCheck.Series as TS--import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Index.IOC-import Data.PrimitiveArray.Vector.Compat------ | An edge boundary as two @Int@s denoting the edge @From :-> To@.--data EdgeBoundary t = !Int :-> !Int-  deriving (Eq,Ord,Show,Generic,Read)--fromEdgeBoundaryFst :: EdgeBoundary t -> Int-fromEdgeBoundaryFst (i :-> _) = i-{-# Inline fromEdgeBoundaryFst #-}--fromEdgeBoundarySnd :: EdgeBoundary t -> Int-fromEdgeBoundarySnd (_ :-> j) = j-{-# Inline fromEdgeBoundarySnd #-}--derivingUnbox "EdgeBoundary"-  [t| forall t . EdgeBoundary t -> (Int,Int) |]-  [| \ (f :-> t) -> (f,t) |]-  [| \ (f,t) -> (f :-> t) |]--instance Binary       (EdgeBoundary t)-instance Serialize    (EdgeBoundary t)-instance FromJSON     (EdgeBoundary t)-instance FromJSONKey  (EdgeBoundary t)-instance ToJSON       (EdgeBoundary t)-instance ToJSONKey    (EdgeBoundary t)-instance Hashable     (EdgeBoundary t)--instance NFData (EdgeBoundary t) where-  rnf (f :-> t) = f `seq` rnf t-  {-# Inline rnf #-}-----instance Index (EdgeBoundary t) where-  linearIndex (f :-> _) (_ :-> t) (i :-> j) = i * (t+1) + j-  {-# Inline linearIndex #-}-  smallestLinearIndex _ = error "still needed?"-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex (_ :-> t) = (t+1) * (t+1) - 1-  {-# Inline largestLinearIndex #-}-  size _ (_ :-> t) = (t+1) * (t+1)-  {-# Inline size #-}-  inBounds _ (_ :-> t) (i :-> j) = 0<=i && i <= t   &&  0 <= j && j<=t-  {-# Inline inBounds #-}---- | @EdgeBoundary I@ (inside)--instance IndexStream z => IndexStream (z:.EdgeBoundary I) where-  streamUp   (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamUpMk   l) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamDownMk h) (streamDownStep l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | @EdgeBoundary O@ (outside).------ Note: @streamUp@ really needs to use @streamDownMk@ / @streamDownStep@--- for the right order of indices!--instance IndexStream z => IndexStream (z:.EdgeBoundary O) where-  streamUp   (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamDownMk h) (streamDownStep l h) $ streamUp   ls hs-  streamDown (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamUpMk   l) (streamUpStep   l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | @EdgeBoundary C@ (complement)--instance IndexStream z => IndexStream (z:.EdgeBoundary C) where-  streamUp   (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamUpMk   l) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:.(l:->_)) (hs:.(_:->h)) = flatten (streamDownMk h) (streamDownStep l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | generic @mk@ for @streamUp@ / @streamDown@--streamUpMk l z = return (z,l,l)-{-# Inline [0] streamUpMk #-}--streamUpStep l h (z,i,j)-  | i > h     = return $ Done-  | j > h     = return $ Skip (z,i+1,l)-  | otherwise = return $ Yield (z:.(i:->j)) (z,i,j+1)-{-# Inline [0] streamUpStep #-}--streamDownMk h z = return (z,h,h)-{-# Inline [0] streamDownMk #-}--streamDownStep l h (z,i,j)-  | i < l     = return $ Done-  | j < l     = return $ Skip (z,i-1,h)-  | otherwise = return $ Yield (z:.(i:->j)) (z,i,j-1)-{-# Inline [0] streamDownStep #-}--instance (IndexStream (Z:.EdgeBoundary t)) => IndexStream (EdgeBoundary t)----instance Arbitrary (EdgeBoundary t) where-  arbitrary = do-    a <- choose (0,14) -- at most 15*15 nodes-    b <- choose (0,14)-    return $ a :-> b-  shrink (i:->j) = Prelude.fmap (\(k,l) -> k :-> l) $ shrink (i,j)------ | TODO this is unbelievably slow right now--instance Monad m => Serial m (EdgeBoundary t) where-  series = do-    i <- TS.getNonNegative <$> series-    j <- TS.getNonNegative <$> series-    return $ i :-> j-

@@ -1,47 +1,50 @@  module Data.PrimitiveArray.Index.Int where -import Data.Vector.Fusion.Stream.Monadic (map,Step(..))-import Prelude hiding (map)+import qualified Data.Vector.Fusion.Stream.Monadic as SM -import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Vector.Compat+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 #-} +deriving instance Show (LimitType Int)+ instance IndexStream z => IndexStream (z:.Int) where-  streamUp (ls:.l) (hs:.h) = flatten mk step $ 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 $ 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 #-} 

@@ -11,14 +11,13 @@ import Data.Ix(Ix) import Data.Serialize (Serialize) import Data.Typeable-import Data.Vector.Fusion.Stream.Monadic (map,Step(..))+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-import Data.PrimitiveArray.Vector.Compat   @@ -26,7 +25,7 @@ -- type @p@. In particular, the @Index@ and @IndexStream@ instances are the -- same as for raw @Int@s. -newtype PInt t p = PInt { getPInt :: Int }+newtype PInt (ioc ∷ k) (p ∷ k) = PInt { getPInt :: Int }   deriving (Read,Show,Eq,Ord,Enum,Num,Integral,Real,Generic,Data,Typeable,Ix)  pIntI :: Int -> PInt I p@@ -54,41 +53,49 @@ instance NFData       (PInt t p)  instance Index (PInt t p) where-  linearIndex _ _ (PInt k) = k+  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 #-} +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:.l) (hs:.h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  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 => IndexStream (z:.PInt O p) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamUp ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs+  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:.l) (hs:.h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  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:.k) (z,k+1)+  | otherwise = return $ Yield (z:.PInt k) (z,k+1) {-# Inline [0] streamUpStep #-}  streamDownMk l h z = return (z,h)@@ -96,38 +103,6 @@  streamDownStep l h (z,k)   | k < l     = return $ Done-  | otherwise = return $ Yield (z:.k) (z,k-1)+  | otherwise = return $ Yield (z:.PInt k) (z,k-1) {-# Inline [0] streamDownStep #-}--instance IndexStream (PInt I p)--instance IndexStream (PInt O p)--instance IndexStream (PInt C p)--{--instance IndexStream z => IndexStream (z:.(PInt p)) where-  streamUp (ls:.l) (hs:.h) = 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)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  streamDown (ls:.l) (hs:.h) = 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)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# 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)-  {-# Inline streamDown #-}--} 

@@ -26,7 +26,6 @@  import           Data.PrimitiveArray.Index.Class import           Data.PrimitiveArray.Index.IOC-import           Data.PrimitiveArray.Vector.Compat   @@ -73,32 +72,40 @@   {-# Inline rnf #-}  instance Index (PointL t) where-  linearIndex _ _ (PointL z) = z+  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+  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 #-} +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 z => IndexStream (z:.PointL I) where-  streamUp   (ls:.PointL lf) (hs:.PointL ht) = flatten (streamUpMk   lf) (streamUpStep   ht) $ streamUp ls hs-  streamDown (ls:.PointL lf) (hs:.PointL ht) = flatten (streamDownMk ht) (streamDownStep lf) $ streamDown ls hs+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep lf) $ streamDown ls hs   {-# Inline [0] streamUp #-}   {-# Inline [0] streamDown #-}  instance IndexStream z => IndexStream (z:.PointL O) where-  streamUp   (ls:.PointL lf) (hs:.PointL ht) = flatten (streamDownMk ht) (streamDownStep lf) $ streamUp   ls hs-  streamDown (ls:.PointL lf) (hs:.PointL ht) = flatten (streamUpMk   lf) (streamUpStep   ht) $ streamDown ls hs+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep lf) $ streamUp   ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   ht) $ streamDown ls hs   {-# Inline [0] streamUp #-}   {-# Inline [0] streamDown #-}  instance IndexStream z => IndexStream (z:.PointL C) where-  streamUp   (ls:.PointL lf) (hs:.PointL ht) = flatten (streamUpMk   lf) (streamUpStep   ht) $ streamUp ls hs-  streamDown (ls:.PointL lf) (hs:.PointL ht) = flatten (streamDownMk ht) (streamDownStep lf) $ streamDown ls hs+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep lf) $ streamDown ls hs   {-# Inline [0] streamUp #-}   {-# Inline [0] streamDown #-} @@ -120,8 +127,13 @@   | otherwise     = return $ SM.Yield (z:.PointL (I# k)) (SP z (k -# 1#)) {-# Inline [0] streamDownStep #-} -instance IndexStream (Z:.PointL t) => IndexStream (PointL t)+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)@@ -135,32 +147,28 @@   --- * @PointR@------ TODO complete instances--derivingUnbox "PointR"-  [t| forall t . PointR t -> Int    |]-  [| \ (PointR i) -> i |]-  [| \ i -> PointR i   |]--instance Binary    (PointR t)-instance Serialize (PointR t)-instance FromJSON  (PointR t)-instance ToJSON    (PointR t)-instance Hashable  (PointR t)--instance NFData (PointR t) where-  rnf (PointR l) = rnf l-  {-# Inline rnf #-}--instance Index (PointR t) where-  linearIndex l _ (PointR z) = undefined-  {-# INLINE linearIndex #-}-  smallestLinearIndex = undefined-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex = undefined-  {-# INLINE largestLinearIndex #-}-  size = undefined-  {-# INLINE size #-}+-- -- * @PointR@+-- --+-- -- TODO complete instances+-- +-- derivingUnbox "PointR"+--   [t| forall t . PointR t -> Int    |]+--   [| \ (PointR i) -> i |]+--   [| \ i -> PointR i   |]+-- +-- instance Binary    (PointR t)+-- instance Serialize (PointR t)+-- instance FromJSON  (PointR t)+-- instance ToJSON    (PointR t)+-- instance Hashable  (PointR t)+-- +-- instance NFData (PointR t) where+--   rnf (PointR l) = rnf l+--   {-# Inline rnf #-}+-- +-- instance Index (PointR t) where+--   linearIndex l (PointR z) = undefined+--   {-# INLINE linearIndex #-}+--   size = undefined+--   {-# INLINE size #-} 

@@ -1,670 +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,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 qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck (Arbitrary(..), choose, elements)--import           Data.Bits.Ordered-import           Data.PrimitiveArray.Index.Class-import           Data.PrimitiveArray.Index.IOC-import           Data.PrimitiveArray.Vector.Compat------ * @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 Boundary i t = Boundary { getBoundary :: Int }-  deriving (Eq,Ord,Generic,Num)--instance Show (Boundary i t) where-  show (Boundary i) = "(I:" ++ show i ++ ")"---- | 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 t = BitSet { getBitSet :: Int }-  deriving (Eq,Ord,Read,Generic,FiniteBits,Ranked,Num,Bits)--instance FromJSON     (BitSet t)-instance FromJSONKey  (BitSet t)-instance ToJSON       (BitSet t)-instance ToJSONKey    (BitSet t)--bitSetI :: Int -> BitSet I-bitSetI = BitSet-{-# Inline bitSetI #-}--bitSetO :: Int -> BitSet O-bitSetO = BitSet-{-# Inline bitSetO #-}--bitSetC :: Int -> BitSet C-bitSetC = BitSet-{-# Inline bitSetC #-}---- | A bitset with one interface.---- type BS1 t i = BitSet t :> Boundary i--data BS1 i t = BS1 !(BitSet t) !(Boundary i t)--deriving instance Show (BS1 i t)---- | A bitset with two interfaces.---- type BS2 t i j = BitSet t :> Boundary i :> Boundary j--data BS2 i j t = BS2 !(BitSet t) !(Boundary i t) !(Boundary j t)--deriving instance Show (BS2 i j t)---- | 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 "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-  linearIndex l _ (Boundary z) = z - smallestLinearIndex l-  {-# INLINE linearIndex #-}-  smallestLinearIndex (Boundary l) = l-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (Boundary h) = h-  {-# INLINE largestLinearIndex #-}-  size (Boundary l) (Boundary h) = h - l + 1-  {-# INLINE size #-}-  inBounds l h z = l <= z && z <= h-  {-# INLINE inBounds #-}--instance IndexStream z => IndexStream (z:.Boundary k I) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBndMk   l h) (streamUpBndStep   l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownBndMk l h) (streamDownBndStep l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream (Z:.Boundary k I) => IndexStream (Boundary k I)--streamUpBndMk :: (Monad m) => Boundary k i -> Boundary k i -> t -> m (t, Boundary k i)-streamUpBndMk l h z = return (z, l)-{-# Inline [0] streamUpBndMk #-}--streamUpBndStep :: (Monad m) => Boundary k i -> Boundary k i -> (t, Boundary k i) -> m (SM.Step (t, Boundary k i) (t :. Boundary k i))-streamUpBndStep l h (z , k)-  | k > h     = return $ SM.Done-  | otherwise = return $ SM.Yield (z:.k) (z, k+1)-{-# Inline [0] streamUpBndStep #-}--streamDownBndMk :: (Monad m) => Boundary k i -> Boundary k i -> t -> m (t, Boundary k i)-streamDownBndMk l h z = return (z, h)-{-# Inline [0] streamDownBndMk #-}--streamDownBndStep :: (Monad m) => Boundary k i -> Boundary k i -> (t, Boundary k i) -> m (SM.Step (t, Boundary k i) (t :. Boundary k i))-streamDownBndStep l h (z , k)-  | k < l     = return $ SM.Done-  | otherwise = return $ SM.Yield (z:.k) (z,k-1)-{-# Inline [0] streamDownBndStep #-}----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 Binary    (BitSet t)-instance Serialize (BitSet t)-instance Hashable  (BitSet t)--instance NFData (BitSet t) where-  rnf (BitSet s) = rnf s-  {-# Inline rnf #-}--instance Index (BitSet t) 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 I) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBsMk   l h) (streamUpBsStep   l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownBsMk l h) (streamDownBsStep l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.BitSet O) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamDownBsMk l h) (streamDownBsStep l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamUpBsMk   l h) (streamUpBsStep   l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.BitSet C) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBsMk   l h) (streamUpBsStep   l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownBsMk l h) (streamDownBsStep l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream (Z:.BitSet t) => IndexStream (BitSet t)---streamUpBsMk :: (Monad m, Ord a) => a -> a -> t -> m (t, Maybe a)-streamUpBsMk l h z = return (z, if l <= h then Just l else Nothing)-{-# Inline [0] streamUpBsMk #-}--streamUpBsStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamUpBsStep l h (z , Nothing) = return $ SM.Done-streamUpBsStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-{-# Inline [0] streamUpBsStep #-}--streamDownBsMk :: (Monad m, Ord a) => a -> a -> t -> m (t, Maybe a)-streamDownBsMk l h z = return (z, if l <=h then Just h else Nothing)-{-# Inline [0] streamDownBsMk #-}--streamDownBsStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamDownBsStep l h (z , Nothing) = return $ SM.Done-streamDownBsStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)-{-# Inline [0] streamDownBsStep #-}------ ** @BS1@---- |------ @linearIndex@ explicitly maps @BS1 0 whatever@ to @0@.--instance Index (BS1 i t) where-  linearIndex (BS1 ls li) (BS1 hs hi) (BS1 s i)-    | s == 0    = 0-    | otherwise = linearIndex (ls:.li) (hs:.hi) (s:.i)-  {-# INLINE linearIndex #-}-  smallestLinearIndex (BS1 s i) = smallestLinearIndex (s:.i)-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (BS1 s i) = largestLinearIndex (s:.i)-  {-# INLINE largestLinearIndex #-}-  size (BS1 ls li) (BS1 hs hi) = size (ls:.li) (hs:.hi)-  {-# INLINE size #-}-  inBounds (BS1 ls li) (BS1 hs hi) (BS1 s i) = inBounds (ls:.li) (hs:.hi) (s:.i)-  {-# INLINE inBounds #-}--instance IndexStream z => IndexStream (z:.BS1 i I) 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 => IndexStream (z:.BS1 i O) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamDownBsIMk l h) (streamDownBsIStep l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamUpBsIMk   l h) (streamUpBsIStep   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:.BS1 i t) => IndexStream (BS1 i t)--streamUpBsIMk :: (Monad m) => BS1 a i -> BS1 b i -> z -> m (z, Maybe (BS1 c i))-streamUpBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sl (Boundary . max 0 $ lsbZ sl)) else Nothing)-{-# Inline [0] streamUpBsIMk #-}--streamUpBsIStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamUpBsIStep l h (z , Nothing) = return $ SM.Done-streamUpBsIStep l h (z,  Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-{-# Inline [0] streamUpBsIStep #-}--streamDownBsIMk :: (Monad m) => BS1 a i -> BS1 b i -> z -> m (z, Maybe (BS1 c i))-streamDownBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sh (Boundary . max 0 $ lsbZ sh)) else Nothing)-{-# Inline [0] streamDownBsIMk #-}--streamDownBsIStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamDownBsIStep l h (z , Nothing) = return $ SM.Done-streamDownBsIStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)-{-# Inline [0] streamDownBsIStep #-}------ ** BS2--instance Index (BS2 i j t) where-  linearIndex (BS2 ls li lj) (BS2 hs hi hj) (BS2 s i j) = linearIndex (ls:.li:.lj) (hs:.hi:.hj) (s:.i:.j)-  {-# INLINE linearIndex #-}-  smallestLinearIndex (BS2 s i j) = smallestLinearIndex (s:.i:.j)-  {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (BS2 s i j) = largestLinearIndex (s:.i:.j)-  {-# INLINE largestLinearIndex #-}-  size (BS2 ls li lj) (BS2 hs hi hj) = size (ls:.li:.lj) (hs:.hi:.hj)-  {-# INLINE size #-}-  inBounds (BS2 ls li lj) (BS2 hs hi hj) (BS2 s i j) = inBounds (ls:.li:.lj) (hs:.hi:.hj) (s:.i:.j)-  {-# INLINE inBounds #-}--instance IndexStream z => IndexStream (z:.BS2 i j I) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBsIiMk   l h) (streamUpBsIiStep   l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownBsIiMk l h) (streamDownBsIiStep l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.BS2 i j O) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamDownBsIiMk l h) (streamDownBsIiStep l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamUpBsIiMk   l h) (streamUpBsIiStep   l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.BS2 i j C) where-  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBsIiMk   l h) (streamUpBsIiStep   l h) $ streamUp   ls hs-  streamDown (ls:.l) (hs:.h) = flatten (streamDownBsIiMk l h) (streamDownBsIiStep l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}--instance IndexStream (Z:.BS2 i j t) => IndexStream (BS2 i j t)--streamUpBsIiMk :: (Monad m) => BS2 a b i -> BS2 c d i -> z -> m (z, Maybe (BS2 e f i))-streamUpBsIiMk (BS2 sl _ _) (BS2 sh _ _) z-  | sl > sh   = return (z , Nothing)-  | cl == 0   = return (z , Just (BS2 0 0 0))-  | cl == 1   = let i = lsbZ sl-                in  return (z , Just (BS2 sl (Boundary i) (Boundary i)))-  | otherwise = let i = lsbZ sl; j = lsbZ (sl `clearBit` i)-                in  return (z , Just (BS2 sl (Boundary i) (Boundary j)))-  where cl = popCount sl-{-# Inline [0] streamUpBsIiMk #-}--streamUpBsIiStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamUpBsIiStep l h (z , Nothing) = return $ SM.Done-streamUpBsIiStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)-{-# Inline [0] streamUpBsIiStep #-}--streamDownBsIiMk :: (Monad m) => BS2 a b i -> BS2 c d i -> z -> m (z, Maybe (BS2 e f i))-streamDownBsIiMk (BS2 sl _ _) (BS2 sh _ _) z-  | sl > sh   = return (z , Nothing)-  | ch == 0   = return (z , Just (BS2 0 0 0))-  | ch == 1   = let i = lsbZ sh-                in  return (z , Just (BS2 sh (Boundary i) (Boundary i)))-  | otherwise = let i = lsbZ sh; j = lsbZ sh-                in  return (z , Just (BS2 sh (Boundary i) (Boundary j)))-  where ch = popCount sh-{-# Inline [0] streamDownBsIiMk #-}--streamDownBsIiStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))-streamDownBsIiStep l h (z , Nothing) = return $ SM.Done-streamDownBsIiStep l h (z , Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)-{-# Inline [0] streamDownBsIiStep #-}------ ** Set predecessor and successor--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 SetPredSucc (BS1 i t) where-  setSucc (BS1 l il) (BS1 h ih) (BS1 s (Boundary is))-    | cs > ch                          = Nothing-    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Boundary is')-    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Boundary $ lsbZ s')-    | cs >= ch                         = Nothing-    | cs < ch                          = let s' = BitSet $ 2^(cs+1)-1 in Just (BS1 s' (Boundary (lsbZ s')))-    where ch = popCount h-          cs = popCount s-  {-# Inline setSucc #-}-  setPred (BS1 l il) (BS1 h ih) (BS1 s (Boundary is))-    | cs < cl                          = Nothing-    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Boundary is')-    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Boundary  $ lsbZ s')-    | cs <= cl                         = Nothing-    | cs > cl                          = let s' = BitSet $ 2^(cs-1)-1 in Just (BS1 s' (Boundary (max 0 $ lsbZ s')))-    where cl = popCount l-          ch = popCount h-          cs = popCount s-  {-# Inline setPred #-}--instance SetPredSucc (BS2 i j t) where-  setSucc (BS2 l il jl) (BS2 h ih jh) (BS2 s (Boundary is) (Boundary 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 (BS2 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 (BS2 s' (Boundary is') (Boundary is'))-    -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Boundary is) (Boundary js'))-    -- advance other interface, -    | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Boundary is') (Boundary js'))-    -- find another permutation of the population-    | Just s'  <- popPermutation ch s-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary 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 (BS2 s' (Boundary is') (Boundary js'))-    where ch = popCount h-          cs = popCount s-  {-# Inline setSucc #-}-  setPred (BS2 l il jl) (BS2 h ih jh) (BS2 s (Boundary is) (Boundary 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 (BS2 s' (Boundary is') (Boundary is'))-    -- return the single @0@ set-    | cs == 1                         = Just (BS2 0 0 0)-    -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Boundary is) (Boundary js'))-    -- advance other interface, -    | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Boundary is') (Boundary js'))-    -- find another permutation of the population-    | Just s'  <- popPermutation ch s-    , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary 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 (BS2 s' (Boundary is') (Boundary js'))-    -- decrease population to single-element sets-    | cs > cl && cs == 2              = Just (BS2 1 0 0)-    where cl = popCount l-          ch = popCount h-          cs = popCount s-  {-# Inline setPred #-}----type instance Mask (BitSet t)  = BitSet t--type instance Mask (BS1 i t)   = BitSet t--type instance Mask (BS2 i j t) = BitSet t----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), Hashable t, Hashable (Mask t)) => Hashable (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)--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 t -> Maybe (Fixed (BitSet t))-testBsS k = setSucc (Fixed 0 0) (Fixed 0 7) (Fixed 4 k)-{-# NoInline testBsS #-}--instance SetPredSucc (Fixed (BitSet t)) 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 (BS1 i t)) where-  setPred (Fixed _ (BS1 l li)) (Fixed _ (BS1 h hi)) (Fixed !m (BS1 s i))-    | s `testBit` getBoundary i = (Fixed m . (`BS1` i) . ( `setBit` getBoundary i)) <$> setPred l h (s .&. complement m)-    | otherwise             = (Fixed m) <$> setPred (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)-  {-# Inline setPred #-}-  setSucc (Fixed _ (BS1 l li)) (Fixed _ (BS1 h hi)) (Fixed !m (BS1 s i))-    | s `testBit` getBoundary i = (Fixed m . (`BS1` i) . ( `setBit` getBoundary i)) <$> setSucc l h (s .&. complement m)-    | otherwise             = (Fixed m) <$> setSucc (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)-  {-# Inline setSucc #-}--instance SetPredSucc (Fixed (BS2 i j t)) where-  setPred (Fixed _ (BS2 l li lj)) (Fixed _ (BS2 h hi hj)) (Fixed !m (BS2 s i j))-    | s `testBit` getBoundary i && s `testBit` getBoundary j-    = (Fixed m . (\z       -> BS2 (z `setBit` getBoundary i `setBit` getBoundary j) i j)) <$> setPred l h (s .&. complement m)-    | s `testBit` getBoundary i-    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getBoundary i) i j')) <$> setPred (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)-    | s `testBit` getBoundary j-    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getBoundary j) i' j)) <$> setPred (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)-  {-# Inline setPred #-}-  setSucc (Fixed _ (BS2 l li lj)) (Fixed _ (BS2 h hi hj)) (Fixed !m (BS2 s i j))-    | s `testBit` getBoundary i && s `testBit` getBoundary j-    = (Fixed m . (\z       -> BS2 (z `setBit` getBoundary i `setBit` getBoundary j) i j)) <$> setSucc l h (s .&. complement m)-    | s `testBit` getBoundary i-    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getBoundary i) i j')) <$> setSucc (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)-    | s `testBit` getBoundary j-    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getBoundary j) i' j)) <$> setSucc (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)-  {-# Inline setSucc #-}----instance ApplyMask (BitSet t) where-  applyMask = popShiftL-  {-# Inline applyMask #-}--instance ApplyMask (BS1 i t) where-  applyMask m (BS1 s i)-    | popCount s == 0 = BS1 0 0-    | otherwise       = BS1 (popShiftL m s) (Boundary . lsbZ . popShiftL m . BitSet . bit $ getBoundary i)-  {-# Inline applyMask #-}--instance ApplyMask (BS2 i j t) where-  applyMask m (BS2 s i j)-    | popCount s == 0 = BS2 0 0 0-    | popCount s == 1 = BS2 s' i' (Boundary $ getBoundary i')-    | otherwise       = BS2 s' i' j'-    where s' = popShiftL m s-          i' = Boundary . getBitSet . popShiftL m $ (BitSet $ 2 ^ getBoundary i :: BitSet t)-          j' = Boundary . getBitSet . popShiftL m $ (BitSet $ 2 ^ getBoundary j :: BitSet t)-  {-# 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 t) 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 (BS1 i t) where-  arbitrary = do-    s <- arbitrary-    if s==0-      then return (BS1 s 0)-      else do i <- elements $ activeBitsL s-              return (BS1 s $ Boundary i)-  shrink (BS1 s i) =-    let s' = [ BS1 (s `clearBit` a) i-             | a <- activeBitsL s-             , Boundary a /= i ]-             ++ [ BS1 0 0 | popCount s == 1 ]-    in  s' ++ concatMap shrink s'--instance Arbitrary (BS2 i j t) where-  arbitrary = do-    s <- arbitrary-    case (popCount s) of-      0 -> return (BS2 s 0 0)-      1 -> do i <- elements $ activeBitsL s-              return (BS2 s (Boundary i) (Boundary i))-      _ -> do i <- elements $ activeBitsL s-              j <- elements $ activeBitsL (s `clearBit` i)-              return (BS2 s (Boundary i) (Boundary j))-  shrink (BS2 s i j) =-    let s' = [ BS2 (s `clearBit` a) i j-             | a <- activeBitsL s-             , Boundary a /= i, Boundary a /= j ]-             ++ [ BS2 (0 `setBit` a) (Boundary a) (Boundary a)-                | popCount s == 2-                , a <- activeBitsL s ]-             ++ [ BS2 0 0 0-                | popCount s == 1 ]-    in  s' ++ concatMap shrink s'-

@@ -11,7 +11,7 @@ import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Serialize (Serialize)-import Data.Vector.Fusion.Stream.Monadic (Step(..), map)+import Data.Vector.Fusion.Stream.Monadic (Step(..), map,flatten) import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import Prelude hiding (map)@@ -22,7 +22,6 @@  import Data.PrimitiveArray.Index.Class import Data.PrimitiveArray.Index.IOC-import Data.PrimitiveArray.Vector.Compat   @@ -83,22 +82,30 @@   instance Index (Subword t) where-  linearIndex _ (Subword (_:.n)) (Subword (i:.j)) = toLinear n (i,j)+  newtype LimitType (Subword t) = LtSubword Int+  linearIndex (LtSubword n) (Subword (i:.j)) = toLinear n (i,j)   {-# Inline linearIndex #-}-  smallestLinearIndex _ = error "still needed?"-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex (Subword (i:.j)) = linearizeUppertri (i,j) - 1-  {-# Inline largestLinearIndex #-}-  size _ (Subword (i:.j)) = linearizeUppertri (i,j)+  size (LtSubword n) = linearizeUppertri (0,n)   {-# Inline size #-}-  inBounds _ (Subword (_:.h)) (Subword (i:.j)) = 0<=i && i<=j && j<=h+  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 #-} +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:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  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 #-} @@ -108,16 +115,16 @@ -- for the right order of indices!  instance IndexStream z => IndexStream (z:.Subword O) where-  streamUp   (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamDownMk l h) (streamDownStep   h) $ streamUp   ls hs-  streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamDown ls hs+  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 #-}   {-# Inline streamDown #-}  -- | @Subword C@ (complement)  instance IndexStream z => IndexStream (z:.Subword C) where-  streamUp   (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:.Subword (l:._)) (hs:.Subword (_:.h)) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  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 #-} @@ -141,7 +148,11 @@   | otherwise = return $ Yield (z:.subword i j) (z,i,j-1) {-# Inline [0] streamDownStep #-} -instance (IndexStream (Z:.Subword t)) => IndexStream (Subword t)+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 (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}  instance Arbitrary (Subword t) where   arbitrary = do

@@ -41,25 +41,38 @@   {-# Inline rnf #-}  instance Index (Unit t) where-  linearIndex _ _ _ = 0+  data LimitType (Unit t) = LtUnit+  linearIndex _ _ = 0   {-# Inline linearIndex #-}-  smallestLinearIndex _ = 0-  {-# Inline smallestLinearIndex #-}-  largestLinearIndex _ = 0-  {-# Inline largestLinearIndex #-}-  size _ _ = 1+  size _ = 1   {-# Inline size #-}-  inBounds _ _ _ = True+  inBounds _ _ = True   {-# Inline inBounds #-}+  zeroBound = Unit+  {-# Inline zeroBound #-}+  zeroBound' = LtUnit+  {-# Inline zeroBound' #-}+  totalSize LtUnit = return 1+  {-# Inline [0] totalSize #-} +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:.Unit) (hs:.Unit) = map (\z -> z:.Unit) $ streamUp ls hs+  streamUp (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamUp ls hs   {-# Inline streamUp #-}-  streamDown (ls:.Unit) (hs:.Unit) = map (\z -> z:.Unit) $ streamDown ls hs+  streamDown (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamDown ls hs   {-# Inline streamDown #-} -instance (IndexStream (Z:.Unit t)) => IndexStream (Unit t)+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 = []+

@@ -26,7 +26,7 @@   , scoreNodes  :: !(Unboxed Int t)   , rowNames    :: !(V.Vector Text)   , colNames    :: !(V.Vector Text)-  } deriving (Eq,Show)+  } deriving (Show)  -- | Get the distance between edges @(From,To)@. @@ -54,13 +54,13 @@ -- | Number of rows in a score matrix.  numRows :: Unbox t => ScoreMatrix t -> Int-numRows ScoreMatrix{..} = let ((Z:.0:.0),(Z:.n':._)) = bounds scoreMatrix in n' + 1+numRows ScoreMatrix{..} = let (_:..LtInt n':.._) = upperBound scoreMatrix in n' + 1 {-# Inline numRows #-}  -- | Number of columns in a score matrix.  numCols :: Unbox t => ScoreMatrix t -> Int-numCols ScoreMatrix{..} = let ((Z:.0:.0),(Z:._:.n')) = bounds scoreMatrix in n' + 1+numCols ScoreMatrix{..} = let (_:.._:..LtInt n') = upperBound scoreMatrix in n' + 1 {-# Inline numCols #-}  listOfRowNames :: ScoreMatrix t -> [Text]@@ -113,10 +113,10 @@     putStrLn $ fp ++ " is not a NxN matrix"     print mat'     exitFailure-  let scoreMatrix = PA.fromAssocs (Z:.0:.0) (Z:.n-1:.n-1) 0+  let scoreMatrix = PA.fromAssocs (ZZ:..LtInt (n-1):..LtInt (n-1)) 0           $ concatMap (\(r,es) -> [ ((Z:.r:.c),e) | (c,e) <- zip [0..] es ])           $ zip [0..] mat' -- rows-  let scoreNodes = PA.fromAssocs 0 (n-1) 0 []+  let scoreNodes = PA.fromAssocs (LtInt $ n-1) 0 []   let rowNames = V.fromList . map T.pack . drop 1 . words $ head ls   let colNames = V.fromList . map (T.pack . head . words) $ tail ls   return $ ScoreMatrix{..} -- mat rowNames colNames (V.fromList $ replicate n 0)

@@ -1,25 +0,0 @@--module Data.PrimitiveArray.Vector.Compat-  ( flatten-  , Size(..)-  ) where--import qualified Data.Vector.Fusion.Stream.Monadic as SM--#if MIN_VERSION_vector(0,11,0)-import Data.Vector.Fusion.Bundle.Size-#else-import Data.Vector.Fusion.Stream.Size-#endif----flatten :: Monad m => (a -> m s) -> (s -> m (SM.Step s b)) -> SM.Stream m a -> SM.Stream m b-{-# Inline flatten #-}--#if MIN_VERSION_vector(0,11,0)-flatten = SM.flatten-#else-flatten = \mk step -> SM.flatten mk step Unknown-#endif-

@@ -1,17 +1,17 @@ Name:           PrimitiveArray-Version:        0.8.0.1+Version:        0.9.0.0 License:        BSD3 License-file:   LICENSE Maintainer:     choener@bioinf.uni-leipzig.de-author:         Christian Hoener zu Siederdissen, 2011-2016-copyright:      Christian Hoener zu Siederdissen, 2011-2016+author:         Christian Hoener zu Siederdissen, 2011-2018+copyright:      Christian Hoener zu Siederdissen, 2011-2018 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.10.3, GHC == 8.0.1+tested-with:    GHC == 8.4.4 Synopsis:       Efficient multidimensional arrays Description:                 <http://www.bioinf.uni-leipzig.de/Software/gADP/ generalized Algebraic Dynamic Programming>@@ -24,13 +24,15 @@                 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.   @@ -40,25 +42,42 @@   +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+++ Library   Exposed-modules:     Data.PrimitiveArray     Data.PrimitiveArray.Checked     Data.PrimitiveArray.Class     Data.PrimitiveArray.Dense-    Data.PrimitiveArray.FillTables+--    Data.PrimitiveArray.FillTables     Data.PrimitiveArray.Index+    Data.PrimitiveArray.Index.BitSet0+    Data.PrimitiveArray.Index.BitSet1+    Data.PrimitiveArray.Index.BitSetClasses+--    Data.PrimitiveArray.Index.BS0+--    Data.PrimitiveArray.Index.BS2     Data.PrimitiveArray.Index.Class-    Data.PrimitiveArray.Index.EdgeBoundary+--    Data.PrimitiveArray.Index.EdgeBoundary     Data.PrimitiveArray.Index.Int     Data.PrimitiveArray.Index.IOC     Data.PrimitiveArray.Index.PhantomInt     Data.PrimitiveArray.Index.Point-    Data.PrimitiveArray.Index.Set+--    Data.PrimitiveArray.Index.Set     Data.PrimitiveArray.Index.Subword+--    Data.PrimitiveArray.Index.TernarySet     Data.PrimitiveArray.Index.Unit     Data.PrimitiveArray.ScoreMatrix-    Data.PrimitiveArray.Vector.Compat   build-depends: base                     >= 4.7      &&  < 5.0                , aeson                    >= 0.8                , binary                   >= 0.7@@ -67,16 +86,18 @@                , cereal-vector            >= 0.2                , deepseq                  >= 1.3                , hashable                 >= 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-               , vector                   >= 0.10+               , vector                   >= 0.11                , vector-binary-instances  >= 0.2                , vector-th-unbox          >= 0.2                ---               , DPutils                  == 0.0.1.*+               , DPutils                  == 0.0.2.*                , OrderedBits              == 0.0.1.*   default-extensions: BangPatterns                     , CPP@@ -88,6 +109,7 @@                     , GADTs                     , GeneralizedNewtypeDeriving                     , MultiParamTypeClasses+                    , PolyKinds                     , RankNTypes                     , RecordWildCards                     , ScopedTypeVariables@@ -96,11 +118,17 @@                     , 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 -O0+  if flag(debugoutput)+    cpp-options: -DADPFUSION_DEBUGOUTPUT   @@ -122,6 +150,7 @@   default-extensions: CPP                     , ScopedTypeVariables                     , TemplateHaskell+                    , UnicodeSyntax   build-depends: base                , containers                , QuickCheck

@@ -1,3 +1,14 @@+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 ------- 

@@ -15,10 +15,10 @@ -- the @linearIndex@. Within each group, there should only be @PointL@s -- with the same value. -uniquenessTest :: (Ord a, Index a) => a -> a -> [a] -> Bool+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 low hgh &&& id) $ xs-        zs  = M.fromListWith S.union . map (second S.singleton) . map (id &&& linearIndex low hgh) $ xs+  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

@@ -8,11 +8,11 @@ import Test.Tasty.TH  import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Index.EdgeBoundary+--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 Data.PrimitiveArray.Index.Set+--import Data.PrimitiveArray.Index.Subword  import Common @@ -20,13 +20,17 @@  -- * Uniqueness tests -prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) (maximum xs) xs+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_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+-- 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) 

@@ -13,11 +13,11 @@ import Test.Tasty.TH  import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Index.EdgeBoundary+--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 Data.PrimitiveArray.Index.Set+--import Data.PrimitiveArray.Index.Subword  import Common @@ -25,11 +25,11 @@  -- * Uniqueness tests. The @xs@ lists are fairly small. -prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) (maximum xs) xs+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_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+-- prop_EdgeBoundary_I_unique (xs :: [EdgeBoundary I]) = uniquenessTest (0 :-> 0) (maximumBy (comparing fromEdgeBoundarySnd) xs) xs   

@@ -8,10 +8,10 @@ import Test.Tasty import Test.Tasty.TH -import Data.PrimitiveArray.Index.IOC-import Data.PrimitiveArray.Index.Point-import Data.PrimitiveArray.Index.Set-import Data.PrimitiveArray.Index.Class+--import Data.PrimitiveArray.Index.IOC+--import Data.PrimitiveArray.Index.Point+--import Data.PrimitiveArray.Index.Set+--import Data.PrimitiveArray.Index.Class  import QuickCheck import SmallCheck