diff --git a/Data/PrimitiveArray.hs b/Data/PrimitiveArray.hs
--- a/Data/PrimitiveArray.hs
+++ b/Data/PrimitiveArray.hs
@@ -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
 
diff --git a/Data/PrimitiveArray/Checked.hs b/Data/PrimitiveArray/Checked.hs
--- a/Data/PrimitiveArray/Checked.hs
+++ b/Data/PrimitiveArray/Checked.hs
@@ -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 (!) #-}
 
diff --git a/Data/PrimitiveArray/Class.hs b/Data/PrimitiveArray/Class.hs
--- a/Data/PrimitiveArray/Class.hs
+++ b/Data/PrimitiveArray/Class.hs
@@ -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 #-}
 
 
diff --git a/Data/PrimitiveArray/Dense.hs b/Data/PrimitiveArray/Dense.hs
--- a/Data/PrimitiveArray/Dense.hs
+++ b/Data/PrimitiveArray/Dense.hs
@@ -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 #-}
 
 
diff --git a/Data/PrimitiveArray/FillTables.hs b/Data/PrimitiveArray/FillTables.hs
deleted file mode 100644
--- a/Data/PrimitiveArray/FillTables.hs
+++ /dev/null
@@ -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 #-}
-
diff --git a/Data/PrimitiveArray/Index.hs b/Data/PrimitiveArray/Index.hs
--- a/Data/PrimitiveArray/Index.hs
+++ b/Data/PrimitiveArray/Index.hs
@@ -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
 
diff --git a/Data/PrimitiveArray/Index/BitSet0.hs b/Data/PrimitiveArray/Index/BitSet0.hs
new file mode 100644
--- /dev/null
+++ b/Data/PrimitiveArray/Index/BitSet0.hs
@@ -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'
+
diff --git a/Data/PrimitiveArray/Index/BitSet1.hs b/Data/PrimitiveArray/Index/BitSet1.hs
new file mode 100644
--- /dev/null
+++ b/Data/PrimitiveArray/Index/BitSet1.hs
@@ -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'
+
diff --git a/Data/PrimitiveArray/Index/BitSetClasses.hs b/Data/PrimitiveArray/Index/BitSetClasses.hs
new file mode 100644
--- /dev/null
+++ b/Data/PrimitiveArray/Index/BitSetClasses.hs
@@ -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
+
diff --git a/Data/PrimitiveArray/Index/Class.hs b/Data/PrimitiveArray/Index/Class.hs
--- a/Data/PrimitiveArray/Index/Class.hs
+++ b/Data/PrimitiveArray/Index/Class.hs
@@ -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 #-}
 
diff --git a/Data/PrimitiveArray/Index/EdgeBoundary.hs b/Data/PrimitiveArray/Index/EdgeBoundary.hs
deleted file mode 100644
--- a/Data/PrimitiveArray/Index/EdgeBoundary.hs
+++ /dev/null
@@ -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
-
diff --git a/Data/PrimitiveArray/Index/Int.hs b/Data/PrimitiveArray/Index/Int.hs
--- a/Data/PrimitiveArray/Index/Int.hs
+++ b/Data/PrimitiveArray/Index/Int.hs
@@ -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 #-}
 
diff --git a/Data/PrimitiveArray/Index/PhantomInt.hs b/Data/PrimitiveArray/Index/PhantomInt.hs
--- a/Data/PrimitiveArray/Index/PhantomInt.hs
+++ b/Data/PrimitiveArray/Index/PhantomInt.hs
@@ -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 #-}
--}
 
diff --git a/Data/PrimitiveArray/Index/Point.hs b/Data/PrimitiveArray/Index/Point.hs
--- a/Data/PrimitiveArray/Index/Point.hs
+++ b/Data/PrimitiveArray/Index/Point.hs
@@ -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 #-}
 
diff --git a/Data/PrimitiveArray/Index/Set.hs b/Data/PrimitiveArray/Index/Set.hs
deleted file mode 100644
--- a/Data/PrimitiveArray/Index/Set.hs
+++ /dev/null
@@ -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'
-
diff --git a/Data/PrimitiveArray/Index/Subword.hs b/Data/PrimitiveArray/Index/Subword.hs
--- a/Data/PrimitiveArray/Index/Subword.hs
+++ b/Data/PrimitiveArray/Index/Subword.hs
@@ -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
diff --git a/Data/PrimitiveArray/Index/Unit.hs b/Data/PrimitiveArray/Index/Unit.hs
--- a/Data/PrimitiveArray/Index/Unit.hs
+++ b/Data/PrimitiveArray/Index/Unit.hs
@@ -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 = []
+
diff --git a/Data/PrimitiveArray/ScoreMatrix.hs b/Data/PrimitiveArray/ScoreMatrix.hs
--- a/Data/PrimitiveArray/ScoreMatrix.hs
+++ b/Data/PrimitiveArray/ScoreMatrix.hs
@@ -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)
diff --git a/Data/PrimitiveArray/Vector/Compat.hs b/Data/PrimitiveArray/Vector/Compat.hs
deleted file mode 100644
--- a/Data/PrimitiveArray/Vector/Compat.hs
+++ /dev/null
@@ -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
-
diff --git a/PrimitiveArray.cabal b/PrimitiveArray.cabal
--- a/PrimitiveArray.cabal
+++ b/PrimitiveArray.cabal
@@ -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
diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -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
 -------
 
diff --git a/tests/Common.hs b/tests/Common.hs
--- a/tests/Common.hs
+++ b/tests/Common.hs
@@ -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
diff --git a/tests/QuickCheck.hs b/tests/QuickCheck.hs
--- a/tests/QuickCheck.hs
+++ b/tests/QuickCheck.hs
@@ -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)
 
diff --git a/tests/SmallCheck.hs b/tests/SmallCheck.hs
--- a/tests/SmallCheck.hs
+++ b/tests/SmallCheck.hs
@@ -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
 
 
 
diff --git a/tests/properties.hs b/tests/properties.hs
--- a/tests/properties.hs
+++ b/tests/properties.hs
@@ -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