packages feed

PrimitiveArray 0.9.1.0 → 0.9.1.1

raw patch · 34 files changed

+2087/−2076 lines, 34 filesdep ~OrderedBits

Dependency ranges changed: OrderedBits

Files

− Data/PrimitiveArray.hs 
@@ -1,13 +0,0 @@--module Data.PrimitiveArray -  ( module Data.PrimitiveArray.Class-  , module Data.PrimitiveArray.Dense---  , module Data.PrimitiveArray.FillTables-  , module Data.PrimitiveArray.Index-  ) where--import Data.PrimitiveArray.Class-import Data.PrimitiveArray.Dense---import Data.PrimitiveArray.FillTables-import Data.PrimitiveArray.Index-
− Data/PrimitiveArray/Checked.hs 
@@ -1,29 +0,0 @@---- | This module exports everything that @Data.PrimitiveArray@ exports, but--- it will do some bounds-checking on certain operations.------ Checked are: @(!)@--module Data.PrimitiveArray.Checked-  ( module Data.PrimitiveArray-  , (!)-  ) where--import qualified Data.Vector.Generic as VG--import           Data.PrimitiveArray hiding ((!))---- | Bounds-checked version of indexing.------ First, we check via @inBounds@, second we check if the linear index is--- outside of the allocated area.----(!) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> elm-(!) arr@(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 h idx-        len = VG.length v-{-# Inline (!) #-}-
− Data/PrimitiveArray/Class.hs 
@@ -1,233 +0,0 @@---- | Vastly extended primitive arrays. Some basic ideas are now modeled after--- the vector package, especially the monadic mutable / pure immutable array--- system.------ NOTE all operations in MPrimArrayOps and PrimArrayOps are highly unsafe. No--- bounds-checking is performed at all.--module Data.PrimitiveArray.Class where--import           Control.Applicative (Applicative, pure, (<$>), (<*>))-import           Control.Exception (assert)-import           Control.Monad.Except-import           Control.Monad (forM_)-import           Control.Monad.Primitive (PrimMonad, 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.PrimitiveArray.Index.Class------ | Mutable version of an array.--data family MutArr (m :: * -> *) (arr :: *) :: *----- | The core set of operations for monadic arrays.--class (Index sh) => MPrimArrayOps arr sh elm where--  -- | Return the bounds of the array. All bounds are inclusive, as in-  -- @[lb..ub]@--  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 => 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 => LimitType sh -> m (MutArr m (arr sh elm))--  -- | Creates a new array with all elements being equal to 'elm'.--  newWithM :: PrimMonad m => LimitType sh -> elm -> m (MutArr m (arr sh elm))--  -- | Reads a single element in the array.--  readM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> m elm--  -- | Writes a single element in the array.--  writeM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> elm -> m ()------ | The core set of functions on immutable arrays.--class (Index sh) => PrimArrayOps arr sh elm where--  -- | Returns the bounds of an immutable array, again inclusive bounds: @ [lb..ub] @.--  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-  -- array afterwards.--  unsafeFreeze :: PrimMonad m => MutArr m (arr sh elm) -> m (arr sh elm)--  -- | Thaw an immutable array into a mutable one. Both versions share-  -- memory.--  unsafeThaw :: PrimMonad m => arr sh elm -> m (MutArr m (arr sh elm))--  -- | Extract a single element from the array. Generally unsafe as not-  -- bounds-checking is performed.--  unsafeIndex :: arr sh elm -> sh -> elm--  -- | Savely transform the shape space of a table.--  transformShape :: (Index sh') => (LimitType sh -> LimitType sh') -> arr sh elm -> arr sh' elm--class (Index sh) => PrimArrayMap arr sh e e' where--  -- | Map a function over each element, keeping the shape intact.--  map :: (e -> e') -> arr sh e -> arr sh e'----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 (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 = inBounds (upperBoundM marr) idx-{-# INLINE inBoundsM #-}---- -- | Given two arrays with the same dimensionality, their respective starting--- -- index, and how many steps to go in each dimension (in terms of a dimension--- -- again), determine if the multidimensional slices have the same value at--- -- all positions--- ----- -- TODO specialize for DIM1 (and maybe higher dim's) to use memcmp--- --- sliceEq :: (Eq elm, PrimArrayOps arr sh elm) => arr sh elm -> sh -> arr sh elm -> sh -> sh -> Bool--- sliceEq arr1 k1 arr2 k2 xtnd = assert ((inBounds arr1 k1) && (inBounds arr2 k2) && (inBounds arr1 $ k1 `addDim` xtnd) && (inBounds arr2 $ k2 `addDim` xtnd)) $ and res where---   res = zipWith (==) xs ys---   xs = P.map (unsafeIndex arr1) $ rangeList k1 xtnd---   ys = P.map (unsafeIndex arr2) $ rangeList k2 xtnd--- {-# INLINE sliceEq #-}---- | Construct a mutable primitive array from a lower and an upper bound, a--- default element, and a list of associations.--fromAssocsM-  :: (PrimMonad m, MPrimArrayOps arr sh elm)-  => LimitType sh -> elm -> [(sh,elm)] -> m (MutArr m (arr sh elm))-fromAssocsM ub def xs = do-  ma <- newWithM ub def---  let s = size ub---  traceShow (s,length xs) $ when (s < length xs) $ error "bang"-  forM_ xs $ \(k,v) -> writeM ma k v-  return ma-{-# INLINE fromAssocsM #-}---- | Initialize an immutable array but stay within the primitive monad @m@.--newWithPA-  ∷ (PrimMonad m, 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 :: 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) => 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) => 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.--- --- inBounds :: PrimArrayOps arr sh elm => arr sh elm -> sh -> Bool--- inBounds arr idx = let (lb,ub) = bounds arr in inShapeRange lb (ub `addDim` unitDim) idx--- {-# INLINE inBounds #-}---- | Returns all elements of an immutable array as a list.--toList :: forall arr sh elm . (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [elm]-toList arr = let ub = upperBound arr in P.map ((!) arr) . unId . SM.toList $ streamUp zeroBound' ub-{-# INLINE toList #-}------ * Freeze an inductive stack of tables with a 'Z' at the bottom.---- | 'freezeTables' freezes a stack of tables.--class FreezeTables m t where-    type Frozen t :: *-    freezeTables :: t -> m (Frozen t)--instance Applicative m => FreezeTables m Z where-    type Frozen Z = Z-    freezeTables Z = pure Z-    {-# INLINE freezeTables #-}--instance (Functor m, Applicative m, Monad m, PrimMonad m, FreezeTables m ts, PrimArrayOps arr sh elm) => FreezeTables m (ts:.MutArr m (arr sh elm)) where-    type Frozen (ts:.MutArr m (arr sh elm)) = Frozen ts :. arr sh elm-    freezeTables (ts:.t) = (:.) <$> freezeTables ts <*> unsafeFreeze t-    {-# INLINE freezeTables #-}-
− Data/PrimitiveArray/Dense.hs 
@@ -1,220 +0,0 @@---- | Dense primitive arrays where the lower index is zero (or the--- equivalent of zero for newtypes and enumerations).------ Actual @write@s to data structures use a more safe @write@ instead of--- the unsafe @unsafeWrite@. Writes also tend to occur much less in DP--- algorithms (say, N^2 writes for an N^3 time algorithm -- mostly reads--- are being executed).------ TODO consider if we want to force the lower index to be zero, or allow--- non-zero lower indices. Will have to be considered together with the--- @Index.Class@ module!------ TODO while @Unboxed@ is, in princile, @Hashable@, we'd need the--- corresponding @VU.Vector@ instances ...--module Data.PrimitiveArray.Dense where--import           Control.DeepSeq-import           Control.Exception (assert)-import           Control.Monad (liftM, forM_, zipWithM_)-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.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.Data---import           Data.PrimitiveArray.Class-import           Data.PrimitiveArray.Index.Class------ * Unboxed, multidimensional arrays.--data Unboxed sh e = Unboxed !(LimitType sh) !(VU.Vector 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 (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 !(LimitType sh) !(VU.MVector (PrimState m) e)-  deriving (Generic,Typeable)--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-#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 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 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 #-}-  {-# INLINE readM #-}-  {-# INLINE writeM #-}--instance (Index sh, Unbox elm) => PrimArrayOps Unboxed sh elm where-  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 h xs) = Unboxed h (VU.map f xs)-  {-# INLINE map #-}------ * Boxed, multidimensional arrays.--data Boxed sh e = Boxed !(LimitType sh) !(V.Vector 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 (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 !(LimitType sh) !(V.MVector (PrimState m) e)-  deriving (Generic,Typeable)--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-  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 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 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 #-}-  {-# INLINE readM #-}-  {-# INLINE writeM #-}--instance (Index sh) => PrimArrayOps Boxed sh elm where-  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 h xs) = Boxed h (V.map f xs)-  {-# INLINE map #-}----{-- -- - This stuff tells us how to write efficient generics on large data- - constructors like the Turner and Vienna ctors.- ---import qualified Data.Generics.TH as T--data Unboxed sh e = Unboxed !sh !(VU.Vector e)-  deriving (Show,Eq,Ord)--data X e = X (Unboxed DIM1 e) (Unboxed DIM1 e)-  deriving (Show,Eq,Ord)--x :: X Int-x = X z z where z = (Unboxed (Z:.10) (VU.fromList [ 0 .. 10] ))--pot :: X Int -> X Double-pot = $( T.thmapT (T.mkTs ['f]) [t| X Int |] ) where-  f :: Unboxed DIM1 Int -> Unboxed DIM1 Double-  f (Unboxed sh xs) = Unboxed sh (VU.map fromIntegral xs)---}-
− Data/PrimitiveArray/Index.hs 
@@ -1,29 +0,0 @@--module Data.PrimitiveArray.Index-  ( module Data.PrimitiveArray.Index.Class-  , 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.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.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.BitSet1 hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)-import Data.PrimitiveArray.Index.BitSet0 hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)-import Data.PrimitiveArray.Index.BitSetClasses-import Data.PrimitiveArray.Index.Subword hiding (streamUpMk, streamUpStep, streamDownMk, streamDownStep)-import Data.PrimitiveArray.Index.Unit-
− Data/PrimitiveArray/Index/BitSet0.hs 
@@ -1,139 +0,0 @@---- | 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'-
− Data/PrimitiveArray/Index/BitSet1.hs 
@@ -1,165 +0,0 @@---- | 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'-
− Data/PrimitiveArray/Index/BitSetClasses.hs 
@@ -1,164 +0,0 @@---- | 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-
− Data/PrimitiveArray/Index/Class.hs 
@@ -1,292 +0,0 @@--module Data.PrimitiveArray.Index.Class where--import           Control.Applicative-import           Control.DeepSeq (NFData(..))-import           Control.Lens hiding (Index, (:>))-import           Control.Monad.Except-import           Control.Monad (liftM2)-import           Data.Aeson-import           Data.Binary-import           Data.Data-import           Data.Hashable (Hashable)-import           Data.Proxy-import           Data.Serialize-import           Data.Typeable-import           Data.Vector.Fusion.Stream.Monadic (Stream)-import           Data.Vector.Unboxed.Deriving-import           Data.Vector.Unboxed (Unbox(..))-import           GHC.Generics-import           GHC.TypeNats-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import           Test.QuickCheck-import           Text.Printf-import           Data.Type.Equality----infixl 3 :.---- | Strict pairs -- as in @repa@.--data a :. b = !a :. !b-  deriving (Eq,Ord,Show,Generic,Data,Typeable)--derivingUnbox "StrictPair"-  [t| forall a b . (Unbox a, Unbox b) => (a:.b) -> (a,b) |]-  [| \(a:.b) -> (a, b) |]-  [| \(a,b)  -> (a:.b) |]--instance (Binary    a, Binary    b) => Binary    (a:.b)-instance (Serialize a, Serialize b) => Serialize (a:.b)-instance (ToJSON    a, ToJSON    b) => ToJSON    (a:.b)-instance (FromJSON  a, FromJSON  b) => FromJSON  (a:.b)-instance (Hashable  a, Hashable  b) => Hashable  (a:.b)--instance (ToJSON a  , ToJSONKey   a, ToJSON b  , ToJSONKey   b) => ToJSONKey   (a:.b)-instance (FromJSON a, FromJSONKey a, FromJSON b, FromJSONKey b) => FromJSONKey (a:.b)--deriving instance (Read a, Read b) => Read (a:.b)--instance (NFData a, NFData b) => NFData (a:.b) where-  rnf (a:.b) = rnf a `seq` rnf b-  {-# Inline rnf #-}--instance (Arbitrary a, Arbitrary b) => Arbitrary (a :. b) where-  arbitrary     = liftM2 (:.) arbitrary arbitrary-  shrink (a:.b) = [ (a':.b) | a' <- shrink a ] ++ [ (a:.b') | b' <- shrink b ]--infixr 3 :>---- | A different version of strict pairs. Makes for simpler type inference in--- multi-tape grammars. We use @:>@ when we have special needs, like--- non-recursive instances on inductives tuples, as used for set indices.------ This one is @infixr@ so that in @a :> b@ we can have the main type in--- @a@ and the specializing types in @b@ and then dispatch on @a :> ts@--- with @ts@ maybe a chain of @:>@.--data a :> b = !a :> !b-  deriving (Eq,Ord,Show,Generic,Data,Typeable)--derivingUnbox "StrictIxPair"-  [t| forall a b . (Unbox a, Unbox b) => (a:>b) -> (a,b) |]-  [| \(a:>b) -> (a, b) |]-  [| \(a,b)  -> (a:>b) |]--instance (Binary    a, Binary    b) => Binary    (a:>b)-instance (Serialize a, Serialize b) => Serialize (a:>b)-instance (ToJSON    a, ToJSON    b) => ToJSON    (a:>b)-instance (FromJSON  a, FromJSON  b) => FromJSON  (a:>b)-instance (Hashable  a, Hashable  b) => Hashable  (a:>b)--deriving instance (Read a, Read b) => Read (a:>b)--instance (NFData a, NFData b) => NFData (a:>b) where-  rnf (a:>b) = rnf a `seq` rnf b-  {-# Inline rnf #-}----instance (Arbitrary a, Arbitrary b) => Arbitrary (a :> b) where---  arbitrary = (:>) <$> arbitrary <*> arbitrary---  shrink (a:>b) = (:>) <$> shrink a <*> shrink b------ | Base data constructor for multi-dimensional indices.--data Z = Z-  deriving (Eq,Ord,Read,Show,Generic,Data,Typeable)--derivingUnbox "Z"-  [t| Z -> () |]-  [| const () |]-  [| const Z  |]--instance Binary    Z-instance Serialize Z-instance ToJSON    Z-instance FromJSON  Z-instance Hashable  Z--instance Arbitrary Z where-  arbitrary = return Z--instance NFData Z where-  rnf Z = ()-  {-# Inline rnf #-}------ | Index structures for complex, heterogeneous indexing. Mostly designed for--- indexing in DP grammars, where the indices work for linear and context-free--- grammars on one or more tapes, for strings, sets, later on tree structures.--class Index i where-  -- | 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 ∷ 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 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.--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 #-}---- | In case @totalSize@ or variants thereof produce a size that is too big to--- handle.--newtype SizeError = SizeError String-  deriving (Eq,Ord,Show)---- | The total number of cells that are allocated.--newtype CellSize = CellSize Word-  deriving (Eq,Ord,Show,Num,Bounded,Integral,Real,Enum)------ | Generate a stream of indices in correct order for dynamic programming.--- Since the stream generators require @concatMap@ / @flatten@ we have to--- write more specialized code for @(z:.IX)@ stuff.--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 ⇒ 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 ⇒ LimitType i → LimitType i → Stream m i----instance Index Z where-  data LimitType Z = ZZ-  linearIndex _ _ = 0-  {-# INLINE linearIndex #-}-  size _ = 1-  {-# INLINE size #-}-  inBounds _ _ = True-  {-# INLINE inBounds #-}-  zeroBound = Z-  {-# Inline zeroBound #-}-  zeroBound' = ZZ-  {-# Inline zeroBound' #-}-  totalSize ZZ = [1]-  {-# Inline [1] totalSize #-}--instance IndexStream Z where-  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-  data LimitType (zs:.z) = !(LimitType zs) :.. !(LimitType z)-  linearIndex (hs:..h) (zs:.z) = linearIndex hs zs * size h + linearIndex h z-  {-# INLINE linearIndex #-}-  size (hs:..h) = size hs * size h-  {-# INLINE size #-}-  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 #-}--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 #-}------ * Somewhat experimental lens support.------ The problem here is that tuples are n-ary, while inductive tuples are--- binary, recursive.--instance Field1 (Z:.a) (Z:.a') a a' where-  {-# Inline _1 #-}-  _1 = lens (\(Z:.a) → a) (\(Z:._) a → (Z:.a))--instance Field1 (Z:.a:.b) (Z:.a':.b) a a' where-  {-# Inline _1 #-}-  _1 = lens (\(Z:.a:.b) → a) (\(Z:._:.b) a → (Z:.a:.b))--instance Field1 (Z:.a:.b:.c) (Z:.a':.b:.c) a a' where-  {-# Inline _1 #-}-  _1 = lens (\(Z:.a:.b:.c) → a) (\(Z:._:.b:.c) a → (Z:.a:.b:.c))---instance Field2 (Z:.a:.b) (Z:.a:.b') b b' where-  {-# Inline _2 #-}-  _2 = lens (\(Z:.a:.b) → b) (\(Z:.a:._) b → (Z:.a:.b))--instance Field2 (Z:.a:.b:.c) (Z:.a:.b':.c) b b' where-  {-# Inline _2 #-}-  _2 = lens (\(Z:.a:.b:.c) → b) (\(Z:.a:._:.c) b → (Z:.a:.b:.c))---instance Field3 (Z:.a:.b:.c) (Z:.a:.b:.c') c c' where-  {-# Inline _3 #-}-  _3 = lens (\(Z:.a:.b:.c) → c) (\(Z:.a:.b:._) c → (Z:.a:.b:.c))-
− Data/PrimitiveArray/Index/IOC.hs 
@@ -1,17 +0,0 @@--module Data.PrimitiveArray.Index.IOC where------ | Phantom type for @Inside@ indices.--data I---- | Phantom type for @Outside@ indices.--data O---- | Phantom type for @Complement@ indices.--data C-
− Data/PrimitiveArray/Index/Int.hs 
@@ -1,50 +0,0 @@--module Data.PrimitiveArray.Index.Int where--import qualified Data.Vector.Fusion.Stream.Monadic as SM--import           Data.PrimitiveArray.Index.Class----instance Index Int where-  newtype LimitType Int = LtInt Int-  linearIndex _ k = k-  {-# Inline linearIndex #-}-  size (LtInt h) = h+1-  {-# Inline size #-}-  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:.. LtInt l) (hs:.. LtInt h) = SM.flatten mk step $ streamUp ls hs-    where mk z = return (z,l)-          step (z,k)-            | k > h     = return $ SM.Done-            | otherwise = return $ SM.Yield (z:.k) (z,k+1)-          {-# Inline [0] mk   #-}-          {-# Inline [0] step #-}-  {-# Inline streamUp #-}-  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 $ 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 = SM.map (\(Z:.k) -> k) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# Inline streamUp #-}-  streamDown l h = SM.map (\(Z:.k) -> k) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# Inline streamDown #-}-
− Data/PrimitiveArray/Index/PhantomInt.hs 
@@ -1,108 +0,0 @@---- | A linear 0-based int-index with a phantom type.--module Data.PrimitiveArray.Index.PhantomInt where--import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey)-import Data.Binary (Binary)-import Data.Data-import Data.Hashable (Hashable)-import Data.Ix(Ix)-import Data.Serialize (Serialize)-import Data.Typeable-import Data.Vector.Fusion.Stream.Monadic (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------ | A 'PInt' behaves exactly like an @Int@, but has an attached phantom--- type @p@. In particular, the @Index@ and @IndexStream@ instances are the--- same as for raw @Int@s.--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-pIntI = PInt-{-# Inline pIntI #-}--pIntO :: Int -> PInt O p-pIntO = PInt-{-# Inline pIntO #-}--pIntC :: Int -> PInt C p-pIntC = PInt-{-# Inline pIntC #-}--derivingUnbox "PInt"-  [t| forall t p . PInt t p -> Int |]  [| getPInt |]  [| PInt |]--instance Binary       (PInt t p)-instance Serialize    (PInt t p)-instance FromJSON     (PInt t p)-instance FromJSONKey  (PInt t p)-instance ToJSON       (PInt t p)-instance ToJSONKey    (PInt t p)-instance Hashable     (PInt t p)-instance NFData       (PInt t p)--instance Index (PInt t p) where-  newtype LimitType (PInt t p) = LtPInt Int-  linearIndex _ (PInt k) = k-  {-# Inline linearIndex #-}-  size (LtPInt h) = h+1-  {-# Inline size #-}-  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:..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:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamUp ls hs-  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream z => IndexStream (z:.PInt C p) where-  streamUp   (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs-  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs-  {-# Inline streamUp   #-}-  {-# Inline streamDown #-}--instance IndexStream (Z:.PInt ioc p) => IndexStream (PInt ioc p) where-  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# INLINE streamUp #-}-  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# INLINE streamDown #-}--streamUpMk l h z = return (z,l)-{-# Inline [0] streamUpMk #-}--streamUpStep l h (z,k)-  | k > h     = return $ Done-  | otherwise = return $ Yield (z:.PInt k) (z,k+1)-{-# Inline [0] streamUpStep #-}--streamDownMk l h z = return (z,h)-{-# Inline [0] streamDownMk #-}--streamDownStep l h (z,k)-  | k < l     = return $ Done-  | otherwise = return $ Yield (z:.PInt k) (z,k-1)-{-# Inline [0] streamDownStep #-}-
− Data/PrimitiveArray/Index/Point.hs 
@@ -1,229 +0,0 @@--{-# Language MagicHash #-}---- | @Point@ index structures are used for left- and right-linear grammars.--- Such grammars have at most one syntactic symbol on each r.h.s. of a rule.--- The syntactic symbol needs to be in an outermost position.--module Data.PrimitiveArray.Index.Point where--import           Control.Applicative-import           Control.DeepSeq (NFData(..))-import           Data.Aeson-import           Data.Binary-import           Data.Bits-import           Data.Bits.Extras (Ranked)-import           Data.Hashable (Hashable)-import           Data.Serialize-import           Data.Vector.Unboxed.Deriving-import           Data.Vector.Unboxed (Unbox(..))-import           GHC.Exts-import           GHC.Generics (Generic)-import qualified Data.Vector.Fusion.Stream.Monadic as SM-import qualified Data.Vector.Unboxed as VU-import           Test.QuickCheck as TQ-import           Test.SmallCheck.Series as TS--import           Data.PrimitiveArray.Index.Class-import           Data.PrimitiveArray.Index.IOC------ | A point in a left-linear grammar. The syntactic symbol is in left-most--- position.--newtype PointL t = PointL {fromPointL :: Int}-  deriving (Eq,Ord,Read,Show,Generic)--pointLI :: Int -> PointL I-pointLI = PointL-{-# Inline pointLI #-}--pointLO :: Int -> PointL O-pointLO = PointL-{-# Inline pointLO #-}--pointLC :: Int -> PointL C-pointLC = PointL-{-# Inline pointLC #-}----derivingUnbox "PointL"-  [t| forall t . PointL t -> Int    |]-  [| \ (PointL i) -> i |]-  [| \ i -> PointL i   |]--instance Binary       (PointL t)-instance Serialize    (PointL t)-instance FromJSON     (PointL t)-instance FromJSONKey  (PointL t)-instance ToJSON       (PointL t)-instance ToJSONKey    (PointL t)-instance Hashable     (PointL t)--instance NFData (PointL t) where-  rnf (PointL l) = rnf l-  {-# Inline rnf #-}--instance Index (PointL t) where-  newtype LimitType (PointL t) = LtPointL Int-  linearIndex _ (PointL z) = z-  {-# INLINE linearIndex #-}-  size (LtPointL h) = h + 1-  {-# INLINE size #-}-  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:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs-  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs-  {-# Inline [0] streamUp #-}-  {-# Inline [0] streamDown #-}--instance IndexStream z => IndexStream (z:.PointL O) where-  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamUp   ls hs-  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamDown ls hs-  {-# Inline [0] streamUp #-}-  {-# Inline [0] streamDown #-}--instance IndexStream z => IndexStream (z:.PointL C) where-  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs-  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs-  {-# Inline [0] streamUp #-}-  {-# Inline [0] streamDown #-}--data SP z = SP !z !Int#--streamUpMk (I# lf) z = return $ SP z lf-{-# Inline [0] streamUpMk #-}--streamUpStep wrapper (I# ht) (SP z k)-  | 1# <- k ># ht = return $ SM.Done-  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k +# 1#))-{-# Inline [0] streamUpStep #-}--streamDownMk (I# ht) z = return $ SP z ht-{-# Inline [0] streamDownMk #-}--streamDownStep wrapper (I# lf) (SP z k)-  | 1# <- k <# lf = return $ SM.Done-  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k -# 1#))-{-# Inline [0] streamDownStep #-}--instance IndexStream (Z:.PointL t) => IndexStream (PointL t) where-  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# INLINE streamUp #-}-  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# INLINE streamDown #-}---instance Arbitrary (PointL t) where-  arbitrary = do-    b <- choose (0,100)-    return $ PointL b-  shrink (PointL j)-    | 0<j = [PointL $ j-1]-    | otherwise = []--instance Monad m => Serial m (PointL t) where-  series = PointL . TS.getNonNegative <$> series------ * @PointR@---- | A point in a right-linear grammars.--newtype PointR t = PointR {fromPointR :: Int}-  deriving (Eq,Ord,Read,Show,Generic)----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 FromJSONKey  (PointR t)-instance ToJSON       (PointR t)-instance ToJSONKey    (PointR t)-instance Hashable     (PointR t)--instance NFData (PointR t) where-  rnf (PointR l) = rnf l-  {-# Inline rnf #-}--instance Index (PointR t) where-  newtype LimitType (PointR t) = LtPointR Int-  linearIndex _ (PointR z) = z-  {-# INLINE linearIndex #-}-  size (LtPointR h) = h + 1-  {-# INLINE size #-}-  inBounds (LtPointR h) (PointR x) = 0<=x && x<=h-  {-# INLINE inBounds #-}-  zeroBound = PointR 0-  {-# Inline [0] zeroBound #-}-  zeroBound' = LtPointR 0-  {-# Inline [0] zeroBound' #-}-  totalSize (LtPointR h) = [fromIntegral $ h + 1]-  {-# Inline [0] totalSize #-}--deriving instance Eq      (LimitType (PointR t))-deriving instance Generic (LimitType (PointR t))-deriving instance Read    (LimitType (PointR t))-deriving instance Show    (LimitType (PointR t))--instance IndexStream z => IndexStream (z:.PointR I) where-  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamUp ls hs-  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamDown ls hs-  {-# Inline [0] streamUp #-}-  {-# Inline [0] streamDown #-}--instance IndexStream z => IndexStream (z:.PointR O) where-  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamUp   ls hs-  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamDown ls hs-  {-# Inline [0] streamUp #-}-  {-# Inline [0] streamDown #-}----instance IndexStream z => IndexStream (z:.PointR C) where---  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMkR   lf) (streamUpStepR   ht) $ streamUp ls hs---  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMkR ht) (streamDownStepR lf) $ streamDown ls hs---  {-# Inline [0] streamUp #-}---  {-# Inline [0] streamDown #-}--instance IndexStream (Z:.PointR t) => IndexStream (PointR t) where-  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# INLINE streamUp #-}-  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# INLINE streamDown #-}---- arbitrarily set maximum here to--arbMaxPointR = 100--instance Arbitrary (PointR t) where-  arbitrary = do-    b <- choose (0,arbMaxPointR)-    return $ PointR b-  shrink (PointR j)-    | j<arbMaxPointR = [PointR $ j+1]-    | otherwise = []----instance Monad m => Serial m (PointR t) where---  series = PointR . TS.getNonNegative <$> series-
− Data/PrimitiveArray/Index/Subword.hs 
@@ -1,178 +0,0 @@---- | Index structure for context-free grammars on strings. A @Subword@ captures--- a pair @(i,j)@ with @i<=j@.--module Data.PrimitiveArray.Index.Subword 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,flatten)-import Data.Vector.Unboxed.Deriving-import GHC.Generics (Generic)-import Prelude hiding (map)-import Test.QuickCheck (Arbitrary(..), choose)-import Test.SmallCheck.Series as TS--import Math.TriangularNumbers--import Data.PrimitiveArray.Index.Class-import Data.PrimitiveArray.Index.IOC------ | A subword wraps a pair of @Int@ indices @i,j@ with @i<=j@.------ Subwords always yield the upper-triangular part of a rect-angular array.--- This gives the quite curious effect that @(0,N)@ points to the--- ``largest'' index, while @(0,0) ... (1,1) ... (k,k) ... (N,N)@ point to--- the smallest. We do, however, use (0,0) as the smallest as (0,k) gives--- successively smaller upper triangular parts.--newtype Subword t = Subword {fromSubword :: (Int:.Int)}-  deriving (Eq,Ord,Show,Generic,Read)--fromSubwordFst :: Subword t -> Int-fromSubwordFst (Subword (i:._)) = i-{-# Inline fromSubwordFst #-}--fromSubwordSnd :: Subword t -> Int-fromSubwordSnd (Subword (_:.j)) = j-{-# Inline fromSubwordSnd #-}--derivingUnbox "Subword"-  [t| forall t . Subword t -> (Int,Int) |]-  [| \ (Subword (i:.j)) -> (i,j) |]-  [| \ (i,j) -> Subword (i:.j) |]--instance Binary       (Subword t)-instance Serialize    (Subword t)-instance FromJSON     (Subword t)-instance FromJSONKey  (Subword t)-instance ToJSON       (Subword t)-instance ToJSONKey    (Subword t)-instance Hashable     (Subword t)--instance NFData (Subword t) where-  rnf (Subword (i:.j)) = i `seq` rnf j-  {-# Inline rnf #-}---- | Create a @Subword t@ where @t@ is inferred.--subword :: Int -> Int -> Subword t-subword i j = Subword (i:.j)-{-# INLINE subword #-}--subwordI :: Int -> Int -> Subword I-subwordI i j = Subword (i:.j)-{-# INLINE subwordI #-}--subwordO :: Int -> Int -> Subword O-subwordO i j = Subword (i:.j)-{-# INLINE subwordO #-}--subwordC :: Int -> Int -> Subword C-subwordC i j = Subword (i:.j)-{-# INLINE subwordC #-}----instance Index (Subword t) where-  newtype LimitType (Subword t) = LtSubword Int-  linearIndex (LtSubword n) (Subword (i:.j)) = toLinear n (i,j)-  {-# Inline linearIndex #-}-  size (LtSubword n) = linearizeUppertri (0,n)-  {-# Inline size #-}-  inBounds (LtSubword h) (Subword (i:.j)) = 0<=i && i<=j && j<=h-  {-# Inline inBounds #-}-  zeroBound = subword 0 0-  {-# Inline zeroBound #-}-  zeroBound' = LtSubword 0-  {-# Inline zeroBound' #-}-  totalSize (LtSubword n) = [fromIntegral (n+1) ^ 2 `div` 2]-  {-# Inline totalSize #-}--deriving instance Eq      (LimitType (Subword t))-deriving instance Generic (LimitType (Subword t))-deriving instance Read    (LimitType (Subword t))-deriving instance Show    (LimitType (Subword t))---- | @Subword I@ (inside)--instance IndexStream z => IndexStream (z:.Subword I) where-  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | @Subword O@ (outside).------ Note: @streamUp@ really needs to use @streamDownMk@ / @streamDownStep@--- for the right order of indices!--instance IndexStream z => IndexStream (z:.Subword O) where-  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamUp   ls hs-  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | @Subword C@ (complement)--instance IndexStream z => IndexStream (z:.Subword C) where-  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs-  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs-  {-# Inline streamUp #-}-  {-# Inline streamDown #-}---- | generic @mk@ for @streamUp@ / @streamDown@--streamUpMk h z = return (z,h,h)-{-# Inline [0] streamUpMk #-}--streamUpStep l h (z,i,j)-  | i < l     = return $ Done-  | j > h     = return $ Skip (z,i-1,i-1)-  | otherwise = return $ Yield (z:.subword i j) (z,i,j+1)-{-# Inline [0] streamUpStep #-}--streamDownMk l h z = return (z,l,h)-{-# Inline [0] streamDownMk #-}--streamDownStep h (z,i,j)-  | i > h     = return $ Done-  | j < i     = return $ Skip (z,i+1,h)-  | otherwise = return $ Yield (z:.subword i j) (z,i,j-1)-{-# Inline [0] streamDownStep #-}--instance (IndexStream (Z:.Subword t)) => IndexStream (Subword t) where-  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# INLINE streamUp #-}-  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# INLINE streamDown #-}--instance Arbitrary (Subword t) where-  arbitrary = do-    a <- choose (0,20)-    b <- choose (0,20)-    return $ Subword (min a b :. max a b)-  shrink (Subword (i:.j))-    | i<j       = [Subword (i:.j-1), Subword (i+1:.j)]-    | otherwise = []--instance Monad m => Serial m (Subword t) where-  series = do-    i <- TS.getNonNegative <$> series-    j <- TS.getNonNegative <$> series-    guard $ i<=j-    return $ subword i j-    {--    let nns :: Series m Int = TS.getNonNegative <$> series-    ps <- nns >< nns-    let qs = [ subword i j | (i,j) <- ps, i<=j ]-    return qs-    -}-
− Data/PrimitiveArray/Index/Unit.hs 
@@ -1,78 +0,0 @@---- | Unit indices admit a single element to be memoized. We can't use @()@--- because we want to attach phantom types.--module Data.PrimitiveArray.Index.Unit where--import Control.Applicative (pure)-import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey)-import Data.Binary (Binary)-import Data.Hashable (Hashable)-import Data.Serialize (Serialize)-import Data.Vector.Fusion.Stream.Monadic (Step(..), map)-import Data.Vector.Unboxed.Deriving-import GHC.Generics (Generic)-import Prelude hiding (map)-import Test.QuickCheck (Arbitrary(..), choose)--import Data.PrimitiveArray.Index.Class----data Unit t = Unit-  deriving (Eq,Ord,Show,Generic,Read)--derivingUnbox "Unit"-  [t| forall t . Unit t -> () |]-  [| \ Unit -> ()   |]-  [| \ ()   -> Unit |]--instance Binary       (Unit t)-instance Serialize    (Unit t)-instance FromJSON     (Unit t)-instance FromJSONKey  (Unit t)-instance ToJSON       (Unit t)-instance ToJSONKey    (Unit t)-instance Hashable     (Unit t)--instance NFData (Unit t) where-  rnf Unit = ()-  {-# Inline rnf #-}--instance Index (Unit t) where-  data LimitType (Unit t) = LtUnit-  linearIndex _ _ = 0-  {-# Inline linearIndex #-}-  size _ = 1-  {-# Inline size #-}-  inBounds _ _ = True-  {-# Inline inBounds #-}-  zeroBound = Unit-  {-# Inline zeroBound #-}-  zeroBound' = LtUnit-  {-# Inline zeroBound' #-}-  totalSize LtUnit = return 1-  {-# Inline [0] totalSize #-}--deriving instance Eq      (LimitType (Unit t))-deriving instance Generic (LimitType (Unit t))-deriving instance Read    (LimitType (Unit t))-deriving instance Show    (LimitType (Unit t))--instance IndexStream z => IndexStream (z:.Unit t) where-  streamUp (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamUp ls hs-  {-# Inline streamUp #-}-  streamDown (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamDown ls hs-  {-# Inline streamDown #-}--instance (IndexStream (Z:.Unit t)) => IndexStream (Unit t) where-  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)-  {-# INLINE streamUp #-}-  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)-  {-# INLINE streamDown #-}--instance Arbitrary (Unit t) where-  arbitrary = pure Unit-  shrink Unit = []-
− Data/PrimitiveArray/ScoreMatrix.hs 
@@ -1,123 +0,0 @@---- | Simple score and distance matrices. These are two-dimensional tables--- together with row and column vectors of names.--module Data.PrimitiveArray.ScoreMatrix where--import           Control.Monad (when,unless)-import           Data.Text (Text)-import           Data.Vector.Unboxed (Unbox)-import           Numeric.Log-import qualified Data.Text as T-import qualified Data.Vector as V-import           System.Exit (exitFailure)--import           Data.PrimitiveArray hiding (map)-import qualified Data.PrimitiveArray as PA------ | NxN sized score matrices------ TODO needs a vector with the column names!--data ScoreMatrix t = ScoreMatrix-  { scoreMatrix :: !(Unboxed (Z:.Int:.Int) t)-  , scoreNodes  :: !(Unboxed Int t)-  , rowNames    :: !(V.Vector Text)-  , colNames    :: !(V.Vector Text)-  } deriving (Show)---- | Get the distance between edges @(From,To)@.--(.!.) :: Unbox t => ScoreMatrix t -> (Int,Int) -> t-ScoreMatrix mat _ _ _ .!. (f,t) = mat ! (Z:.f:.t)-{-# Inline (.!.) #-}---- | If the initial node has a "distance", it'll be here--nodeDist :: Unbox t => ScoreMatrix t -> Int -> t-nodeDist ScoreMatrix{..} k = scoreNodes ! k---- | Get the name of the node at an row index--rowNameOf :: ScoreMatrix t -> Int -> Text-rowNameOf ScoreMatrix{..} k = rowNames V.! k-{-# Inline rowNameOf #-}---- | Get the name of the node at an column index--colNameOf :: ScoreMatrix t -> Int -> Text-colNameOf ScoreMatrix{..} k = colNames V.! k-{-# Inline colNameOf #-}---- | Number of rows in a score matrix.--numRows :: Unbox t => ScoreMatrix t -> Int-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 (_:.._:..LtInt n') = upperBound scoreMatrix in n' + 1-{-# Inline numCols #-}--listOfRowNames :: ScoreMatrix t -> [Text]-listOfRowNames ScoreMatrix{..} = V.toList rowNames--listOfColNames :: ScoreMatrix t -> [Text]-listOfColNames ScoreMatrix{..} = V.toList colNames---- | Turns a @ScoreMatrix@ for distances into one scaled by "temperature" for--- Inside/Outside calculations. Each value is scaled by--- @\k -> exp $ negate k / r * t@ where--- r = (n-1) * d--- d = mean of genetic distance------ Node scores are turned directly into probabilities.------ TODO Again, there is overlap and we should really have @newtype--- Distance@ and friends.------ TODO @newtype Temperature = Temperature Double@------ TODO fix for rows /= cols!!!--toPartMatrix-  :: Double-  -- ^ temperature-  -> ScoreMatrix Double-  -> ScoreMatrix (Log Double)-toPartMatrix t scoreMat@(ScoreMatrix mat sn rns cns) = ScoreMatrix p psn rns cns-  where p = PA.map (\k -> Exp {- . log . exp -} $ negate k / (r * t)) mat-        psn = PA.map (\k -> Exp $ negate k) sn-        n = numRows scoreMat-        d = Prelude.sum [ mat ! (Z:.i:.j) | i <- [0..n-1], j <- [i+1..n-1] ] / fromIntegral (n*(n-1))-        r = fromIntegral (n-1) * d---- | Import data.------ TODO Should be generalized because @Lib-BiobaseBlast@ does almost the--- same thing.--fromFile :: FilePath -> IO (ScoreMatrix Double)-fromFile fp = do-  ls <- lines <$> readFile fp-  when (null ls) $ do-    putStrLn $ fp ++ " is empty"-    exitFailure-  let mat' = map (map read . tail . words) $ tail ls-  let n = length mat'-  unless (all ((==n) . length) mat') $ do-    putStrLn $ fp ++ " is not a NxN matrix"-    print mat'-    exitFailure-  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 (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)-
PrimitiveArray.cabal view
@@ -1,6 +1,6 @@ Cabal-version:  2.2 Name:           PrimitiveArray-Version:        0.9.1.0+Version:        0.9.1.1 License:        BSD-3-Clause License-file:   LICENSE Maintainer:     choener@bioinf.uni-leipzig.de@@ -80,7 +80,7 @@                , vector-th-unbox          >= 0.2                --                , DPutils                  == 0.1.0.*-               , OrderedBits              == 0.0.1.*+               , OrderedBits              == 0.0.2.*   default-extensions: BangPatterns                     , CPP                     , DataKinds@@ -93,6 +93,7 @@                     , GADTs                     , GeneralizedNewtypeDeriving                     , MultiParamTypeClasses+                    , PatternSynonyms                     , PolyKinds                     , RankNTypes                     , RecordWildCards@@ -111,7 +112,7 @@     -funbox-strict-fields   if flag(debug)     cpp-options: -DADPFUSION_CHECKS-    ghc-options: -fno-ignore-asserts -O0+    ghc-options: -fno-ignore-asserts --disable-optimizations   if flag(debugoutput)     cpp-options: -DADPFUSION_DEBUGOUTPUT @@ -125,24 +126,20 @@     Data.PrimitiveArray.Checked     Data.PrimitiveArray.Class     Data.PrimitiveArray.Dense---    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.Int     Data.PrimitiveArray.Index.IOC     Data.PrimitiveArray.Index.PhantomInt     Data.PrimitiveArray.Index.Point---    Data.PrimitiveArray.Index.Set     Data.PrimitiveArray.Index.Subword---    Data.PrimitiveArray.Index.TernarySet     Data.PrimitiveArray.Index.Unit     Data.PrimitiveArray.ScoreMatrix+  hs-source-dirs:+    lib
changelog.md view
@@ -1,3 +1,8 @@+0.9.1.1+-------++- OrderedBits version bump+ 0.9.1.0 -------
+ lib/Data/PrimitiveArray.hs view
@@ -0,0 +1,13 @@++module Data.PrimitiveArray +  ( module Data.PrimitiveArray.Class+  , module Data.PrimitiveArray.Dense+--  , module Data.PrimitiveArray.FillTables+  , module Data.PrimitiveArray.Index+  ) where++import Data.PrimitiveArray.Class+import Data.PrimitiveArray.Dense+--import Data.PrimitiveArray.FillTables+import Data.PrimitiveArray.Index+
+ lib/Data/PrimitiveArray/Checked.hs view
@@ -0,0 +1,29 @@++-- | This module exports everything that @Data.PrimitiveArray@ exports, but+-- it will do some bounds-checking on certain operations.+--+-- Checked are: @(!)@++module Data.PrimitiveArray.Checked+  ( module Data.PrimitiveArray+  , (!)+  ) where++import qualified Data.Vector.Generic as VG++import           Data.PrimitiveArray hiding ((!))++-- | Bounds-checked version of indexing.+--+-- First, we check via @inBounds@, second we check if the linear index is+-- outside of the allocated area.++--(!) :: PrimArrayOps arr sh elm => arr sh elm -> sh -> elm+(!) arr@(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 h idx+        len = VG.length v+{-# Inline (!) #-}+
+ lib/Data/PrimitiveArray/Class.hs view
@@ -0,0 +1,233 @@++-- | Vastly extended primitive arrays. Some basic ideas are now modeled after+-- the vector package, especially the monadic mutable / pure immutable array+-- system.+--+-- NOTE all operations in MPrimArrayOps and PrimArrayOps are highly unsafe. No+-- bounds-checking is performed at all.++module Data.PrimitiveArray.Class where++import           Control.Applicative (Applicative, pure, (<$>), (<*>))+import           Control.Exception (assert)+import           Control.Monad.Except+import           Control.Monad (forM_)+import           Control.Monad.Primitive (PrimMonad, 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.PrimitiveArray.Index.Class++++-- | Mutable version of an array.++data family MutArr (m :: * -> *) (arr :: *) :: *+++-- | The core set of operations for monadic arrays.++class (Index sh) => MPrimArrayOps arr sh elm where++  -- | Return the bounds of the array. All bounds are inclusive, as in+  -- @[lb..ub]@++  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 => 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 => LimitType sh -> m (MutArr m (arr sh elm))++  -- | Creates a new array with all elements being equal to 'elm'.++  newWithM :: PrimMonad m => LimitType sh -> elm -> m (MutArr m (arr sh elm))++  -- | Reads a single element in the array.++  readM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> m elm++  -- | Writes a single element in the array.++  writeM :: PrimMonad m => MutArr m (arr sh elm) -> sh -> elm -> m ()++++-- | The core set of functions on immutable arrays.++class (Index sh) => PrimArrayOps arr sh elm where++  -- | Returns the bounds of an immutable array, again inclusive bounds: @ [lb..ub] @.++  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+  -- array afterwards.++  unsafeFreeze :: PrimMonad m => MutArr m (arr sh elm) -> m (arr sh elm)++  -- | Thaw an immutable array into a mutable one. Both versions share+  -- memory.++  unsafeThaw :: PrimMonad m => arr sh elm -> m (MutArr m (arr sh elm))++  -- | Extract a single element from the array. Generally unsafe as not+  -- bounds-checking is performed.++  unsafeIndex :: arr sh elm -> sh -> elm++  -- | Savely transform the shape space of a table.++  transformShape :: (Index sh') => (LimitType sh -> LimitType sh') -> arr sh elm -> arr sh' elm++class (Index sh) => PrimArrayMap arr sh e e' where++  -- | Map a function over each element, keeping the shape intact.++  map :: (e -> e') -> arr sh e -> arr sh e'++++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 (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 = inBounds (upperBoundM marr) idx+{-# INLINE inBoundsM #-}++-- -- | Given two arrays with the same dimensionality, their respective starting+-- -- index, and how many steps to go in each dimension (in terms of a dimension+-- -- again), determine if the multidimensional slices have the same value at+-- -- all positions+-- --+-- -- TODO specialize for DIM1 (and maybe higher dim's) to use memcmp+-- +-- sliceEq :: (Eq elm, PrimArrayOps arr sh elm) => arr sh elm -> sh -> arr sh elm -> sh -> sh -> Bool+-- sliceEq arr1 k1 arr2 k2 xtnd = assert ((inBounds arr1 k1) && (inBounds arr2 k2) && (inBounds arr1 $ k1 `addDim` xtnd) && (inBounds arr2 $ k2 `addDim` xtnd)) $ and res where+--   res = zipWith (==) xs ys+--   xs = P.map (unsafeIndex arr1) $ rangeList k1 xtnd+--   ys = P.map (unsafeIndex arr2) $ rangeList k2 xtnd+-- {-# INLINE sliceEq #-}++-- | Construct a mutable primitive array from a lower and an upper bound, a+-- default element, and a list of associations.++fromAssocsM+  :: (PrimMonad m, MPrimArrayOps arr sh elm)+  => LimitType sh -> elm -> [(sh,elm)] -> m (MutArr m (arr sh elm))+fromAssocsM ub def xs = do+  ma <- newWithM ub def+--  let s = size ub+--  traceShow (s,length xs) $ when (s < length xs) $ error "bang"+  forM_ xs $ \(k,v) -> writeM ma k v+  return ma+{-# INLINE fromAssocsM #-}++-- | Initialize an immutable array but stay within the primitive monad @m@.++newWithPA+  ∷ (PrimMonad m, 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 :: 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) => 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) => 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.+-- +-- inBounds :: PrimArrayOps arr sh elm => arr sh elm -> sh -> Bool+-- inBounds arr idx = let (lb,ub) = bounds arr in inShapeRange lb (ub `addDim` unitDim) idx+-- {-# INLINE inBounds #-}++-- | Returns all elements of an immutable array as a list.++toList :: forall arr sh elm . (IndexStream sh, PrimArrayOps arr sh elm) => arr sh elm -> [elm]+toList arr = let ub = upperBound arr in P.map ((!) arr) . unId . SM.toList $ streamUp zeroBound' ub+{-# INLINE toList #-}++++-- * Freeze an inductive stack of tables with a 'Z' at the bottom.++-- | 'freezeTables' freezes a stack of tables.++class FreezeTables m t where+    type Frozen t :: *+    freezeTables :: t -> m (Frozen t)++instance Applicative m => FreezeTables m Z where+    type Frozen Z = Z+    freezeTables Z = pure Z+    {-# INLINE freezeTables #-}++instance (Functor m, Applicative m, Monad m, PrimMonad m, FreezeTables m ts, PrimArrayOps arr sh elm) => FreezeTables m (ts:.MutArr m (arr sh elm)) where+    type Frozen (ts:.MutArr m (arr sh elm)) = Frozen ts :. arr sh elm+    freezeTables (ts:.t) = (:.) <$> freezeTables ts <*> unsafeFreeze t+    {-# INLINE freezeTables #-}+
+ lib/Data/PrimitiveArray/Dense.hs view
@@ -0,0 +1,220 @@++-- | Dense primitive arrays where the lower index is zero (or the+-- equivalent of zero for newtypes and enumerations).+--+-- Actual @write@s to data structures use a more safe @write@ instead of+-- the unsafe @unsafeWrite@. Writes also tend to occur much less in DP+-- algorithms (say, N^2 writes for an N^3 time algorithm -- mostly reads+-- are being executed).+--+-- TODO consider if we want to force the lower index to be zero, or allow+-- non-zero lower indices. Will have to be considered together with the+-- @Index.Class@ module!+--+-- TODO while @Unboxed@ is, in princile, @Hashable@, we'd need the+-- corresponding @VU.Vector@ instances ...++module Data.PrimitiveArray.Dense where++import           Control.DeepSeq+import           Control.Exception (assert)+import           Control.Monad (liftM, forM_, zipWithM_)+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.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.Data+++import           Data.PrimitiveArray.Class+import           Data.PrimitiveArray.Index.Class++++-- * Unboxed, multidimensional arrays.++data Unboxed sh e = Unboxed !(LimitType sh) !(VU.Vector 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 (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 !(LimitType sh) !(VU.MVector (PrimState m) e)+  deriving (Generic,Typeable)++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+#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 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 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 #-}+  {-# INLINE readM #-}+  {-# INLINE writeM #-}++instance (Index sh, Unbox elm) => PrimArrayOps Unboxed sh elm where+  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 h xs) = Unboxed h (VU.map f xs)+  {-# INLINE map #-}++++-- * Boxed, multidimensional arrays.++data Boxed sh e = Boxed !(LimitType sh) !(V.Vector 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 (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 !(LimitType sh) !(V.MVector (PrimState m) e)+  deriving (Generic,Typeable)++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+  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 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 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 #-}+  {-# INLINE readM #-}+  {-# INLINE writeM #-}++instance (Index sh) => PrimArrayOps Boxed sh elm where+  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 h xs) = Boxed h (V.map f xs)+  {-# INLINE map #-}++++{-+ -+ - This stuff tells us how to write efficient generics on large data+ - constructors like the Turner and Vienna ctors.+ -++import qualified Data.Generics.TH as T++data Unboxed sh e = Unboxed !sh !(VU.Vector e)+  deriving (Show,Eq,Ord)++data X e = X (Unboxed DIM1 e) (Unboxed DIM1 e)+  deriving (Show,Eq,Ord)++x :: X Int+x = X z z where z = (Unboxed (Z:.10) (VU.fromList [ 0 .. 10] ))++pot :: X Int -> X Double+pot = $( T.thmapT (T.mkTs ['f]) [t| X Int |] ) where+  f :: Unboxed DIM1 Int -> Unboxed DIM1 Double+  f (Unboxed sh xs) = Unboxed sh (VU.map fromIntegral xs)++-}+
+ lib/Data/PrimitiveArray/Index.hs view
@@ -0,0 +1,29 @@++module Data.PrimitiveArray.Index+  ( module Data.PrimitiveArray.Index.Class+  , 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.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.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.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+
+ lib/Data/PrimitiveArray/Index/BitSet0.hs view
@@ -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'+
+ lib/Data/PrimitiveArray/Index/BitSet1.hs view
@@ -0,0 +1,168 @@++-- | 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 = UndefBoundary+  in  return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)+{-# Inline [0] streamUpMk #-}++streamUpStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))+streamUpStep l h (z, Nothing) = return $ SM.Done+streamUpStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setSucc l h t)+{-# Inline [0] streamUpStep #-}++streamDownMk ∷ Monad m ⇒ Int → Int → z → m (z, Maybe (BitSet1 c ioc))+streamDownMk l h z =+  let set = BitSet $ 2^h-1+      bnd = Boundary 0 -- this is the actual boundary at zero+  in  return (z, if l <= h then Just (BitSet1 set bnd) else Nothing)+{-# Inline [0] streamDownMk #-}++streamDownStep ∷ Monad m ⇒ Int → Int → (t, Maybe (BitSet1 c ioc)) → m (SM.Step (t, Maybe (BitSet1 c ioc)) (t:.BitSet1 c ioc))+streamDownStep l h (z, Nothing) = return $ SM.Done+streamDownStep l h (z, Just t ) = return $ SM.Yield (z:.t) (z , setPred l h t)+{-# Inline [0] streamDownStep #-}++instance SetPredSucc (BitSet1 t ioc) where+  setSucc pcl pch (BitSet1 s (Boundary is))+    | cs > pch                         = Nothing+    | Just is' <- maybeNextActive is s = Just $ BitSet1 s  (Boundary is')+    | Just s'  <- popPermutation pch s = Just $ BitSet1 s' (Boundary $ lsbZ s')+    | cs >= pch                        = Nothing+    | cs < pch                         = let s' = BitSet $ 2^(cs+1)-1+                                         in  Just (BitSet1 s' (Boundary (lsbZ s')))+    where cs = popCount s+  {-# Inline setSucc #-}+  setPred pcl pch (BitSet1 s (Boundary is))+    | cs < pcl                          = Nothing+    | Just is' <- maybeNextActive is s  = Just $ BitSet1 s  (Boundary is')+    | Just s'  <- popPermutation pch s  = Just $ BitSet1 s' (Boundary $ lsbZ s')+    | cs <= pcl                         = Nothing+    | cs > pcl                          = let s' = BitSet $ 2^(cs-1)-1+                                          in  Just (BitSet1 s' (Boundary (max 0 $ lsbZ s')))+    where cs = popCount s+  {-# Inline setPred #-}++instance SetPredSucc (FixedMask (BitSet1 t ioc)) where+  setSucc pcl pch (FixedMask mask bs1) = undefined++instance Arbitrary (BitSet1 t ioc) where+  arbitrary = do+    s <- arbitrary+    if s==0+      then return (BitSet1 s 0)+      else do i <- elements $ activeBitsL s+              return (BitSet1 s $ Boundary i)+  shrink (BitSet1 s i) =+    let s' = [ BitSet1 (s `clearBit` a) i+             | a <- activeBitsL s+             , Boundary a /= i ]+             ++ [ BitSet1 0 0 | popCount s == 1 ]+    in  s' ++ concatMap shrink s'+
+ lib/Data/PrimitiveArray/Index/BitSetClasses.hs view
@@ -0,0 +1,170 @@++-- | 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)++-- | Whenever we can not set the boundary we should have for a set, we use this+-- pattern. All legal boundaries are @>=0@. We also need to set the undefined+-- boundary to @0@, since the @linearIndex@ will use this value to add, which+-- for empty sets would reduce to @0 - UndefBoundary === 0@.++pattern UndefBoundary ∷ Boundary boundaryType ioc+pattern UndefBoundary = Boundary 0++instance Show (Boundary i t) where+  show (Boundary i) = "(I:" ++ show i ++ ")"++derivingUnbox "Boundary"+  [t| forall i t . Boundary i t → Int |]+  [| \(Boundary i) → i                |]+  [| Boundary                         |]++instance Binary    (Boundary i t)+instance Serialize (Boundary i t)+instance ToJSON    (Boundary i t)+instance FromJSON  (Boundary i t)+instance Hashable  (Boundary i t)++instance NFData (Boundary i t) where+  rnf (Boundary i) = rnf i+  {-# Inline rnf #-}++instance Index (Boundary i t) where+  newtype LimitType (Boundary i t) = LtBoundary Int+  linearIndex _ (Boundary z) = z+  {-# INLINE linearIndex #-}+  size (LtBoundary h) = h + 1+  {-# INLINE size #-}+  inBounds (LtBoundary h) z = 0 <= z && getBoundary z <= h+  {-# INLINE inBounds #-}+  zeroBound = Boundary 0+  {-# Inline zeroBound #-}+  zeroBound' = LtBoundary 0+  {-# Inline zeroBound' #-}+  totalSize (LtBoundary n) = [fromIntegral n]+  {-# Inline totalSize #-}++instance IndexStream z ⇒ IndexStream (z:.Boundary k I) where+  streamUp   (ls:..LtBoundary l) (hs:..LtBoundary h) = SM.flatten (streamUpBndMk   l h) (streamUpBndStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtBoundary l) (hs:..LtBoundary h) = SM.flatten (streamDownBndMk l h) (streamDownBndStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream (Z:.Boundary k I) ⇒ IndexStream (Boundary k I) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# Inline streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# Inline streamDown #-}++streamUpBndMk l h z = return (z, l)+{-# Inline [0] streamUpBndMk #-}++streamUpBndStep l h (z , k)+  | k > h     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.Boundary k) (z, k+1)+{-# Inline [0] streamUpBndStep #-}++streamDownBndMk l h z = return (z, h)+{-# Inline [0] streamDownBndMk #-}++streamDownBndStep l h (z , k)+  | k < l     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.Boundary k) (z,k-1)+{-# Inline [0] streamDownBndStep #-}++-- | Declare the interface to be the start of a path.++data First++-- | Declare the interface to be the end of a path.++data Last++-- | Declare the interface to match anything.+--+-- TODO needed? want to use later in ADPfusion++data Any++++-- * Moving indices within sets.++-- | Successor and Predecessor for sets. Designed as a class to accomodate+-- sets with interfaces and without interfaces with one function.+--+-- The functions are not written recursively, as we currently only have+-- three cases, and we do not want to "reset" while generating successors+-- and predecessors.+--+-- Note that sets have a partial order. Within the group of element with+-- the same @popCount@, we use @popPermutation@ which has the same stepping+-- order for both, @setSucc@ and @setPred@.++class SetPredSucc s where+  -- | Set successor. The first argument is the lower set limit, the second+  -- the upper set limit, the third the current set.+  setSucc ∷ Int → Int → s → Maybe s+  -- | Set predecessor. The first argument is the lower set limit, the+  -- second the upper set limit, the third the current set.+  setPred ∷ Int → Int → s → Maybe s++-- | Masks are used quite often for different types of bitsets. We liberate+-- them as a type family.++type family Mask s ∷ *++-- | @Fixed@ allows us to fix some or all bits of a bitset, thereby+-- providing @succ/pred@ operations which are only partially free.+--+-- @f = getFixedMask .&. getFixed@ are the fixed bits.+-- @n = getFixed .&. complement getFixedMask@ are the free bits.+-- @to = complement getFixed@ is the to move mask+-- @n' = popShiftR to n@ yields the population after the move+-- @p = popPermutation undefined n'@ yields the new population permutation+-- @p' = popShiftL to p@ yields the population moved back+-- @final = p' .|. f@++data FixedMask t = FixedMask { getMask ∷ (Mask t) , getFixed ∷ !t }++-- | Assuming a bitset on bits @[0 .. highbit]@, we can apply a mask that+-- stretches out those bits over @[0 .. higherBit]@ with @highbit <=+-- higherBit@. Any active interfaces are correctly set as well.++class ApplyMask s where+  applyMask :: Mask s → s → s++++-- | for 'Test.QuickCheck.Arbitrary'++arbitraryBitSetMax ∷ Int+arbitraryBitSetMax = 6+
+ lib/Data/PrimitiveArray/Index/Class.hs view
@@ -0,0 +1,292 @@++module Data.PrimitiveArray.Index.Class where++import           Control.Applicative+import           Control.DeepSeq (NFData(..))+import           Control.Lens hiding (Index, (:>))+import           Control.Monad.Except+import           Control.Monad (liftM2)+import           Data.Aeson+import           Data.Binary+import           Data.Data+import           Data.Hashable (Hashable)+import           Data.Proxy+import           Data.Serialize+import           Data.Typeable+import           Data.Vector.Fusion.Stream.Monadic (Stream)+import           Data.Vector.Unboxed.Deriving+import           Data.Vector.Unboxed (Unbox(..))+import           GHC.Generics+import           GHC.TypeNats+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import           Test.QuickCheck+import           Text.Printf+import           Data.Type.Equality++++infixl 3 :.++-- | Strict pairs -- as in @repa@.++data a :. b = !a :. !b+  deriving (Eq,Ord,Show,Generic,Data,Typeable)++derivingUnbox "StrictPair"+  [t| forall a b . (Unbox a, Unbox b) => (a:.b) -> (a,b) |]+  [| \(a:.b) -> (a, b) |]+  [| \(a,b)  -> (a:.b) |]++instance (Binary    a, Binary    b) => Binary    (a:.b)+instance (Serialize a, Serialize b) => Serialize (a:.b)+instance (ToJSON    a, ToJSON    b) => ToJSON    (a:.b)+instance (FromJSON  a, FromJSON  b) => FromJSON  (a:.b)+instance (Hashable  a, Hashable  b) => Hashable  (a:.b)++instance (ToJSON a  , ToJSONKey   a, ToJSON b  , ToJSONKey   b) => ToJSONKey   (a:.b)+instance (FromJSON a, FromJSONKey a, FromJSON b, FromJSONKey b) => FromJSONKey (a:.b)++deriving instance (Read a, Read b) => Read (a:.b)++instance (NFData a, NFData b) => NFData (a:.b) where+  rnf (a:.b) = rnf a `seq` rnf b+  {-# Inline rnf #-}++instance (Arbitrary a, Arbitrary b) => Arbitrary (a :. b) where+  arbitrary     = liftM2 (:.) arbitrary arbitrary+  shrink (a:.b) = [ (a':.b) | a' <- shrink a ] ++ [ (a:.b') | b' <- shrink b ]++infixr 3 :>++-- | A different version of strict pairs. Makes for simpler type inference in+-- multi-tape grammars. We use @:>@ when we have special needs, like+-- non-recursive instances on inductives tuples, as used for set indices.+--+-- This one is @infixr@ so that in @a :> b@ we can have the main type in+-- @a@ and the specializing types in @b@ and then dispatch on @a :> ts@+-- with @ts@ maybe a chain of @:>@.++data a :> b = !a :> !b+  deriving (Eq,Ord,Show,Generic,Data,Typeable)++derivingUnbox "StrictIxPair"+  [t| forall a b . (Unbox a, Unbox b) => (a:>b) -> (a,b) |]+  [| \(a:>b) -> (a, b) |]+  [| \(a,b)  -> (a:>b) |]++instance (Binary    a, Binary    b) => Binary    (a:>b)+instance (Serialize a, Serialize b) => Serialize (a:>b)+instance (ToJSON    a, ToJSON    b) => ToJSON    (a:>b)+instance (FromJSON  a, FromJSON  b) => FromJSON  (a:>b)+instance (Hashable  a, Hashable  b) => Hashable  (a:>b)++deriving instance (Read a, Read b) => Read (a:>b)++instance (NFData a, NFData b) => NFData (a:>b) where+  rnf (a:>b) = rnf a `seq` rnf b+  {-# Inline rnf #-}++--instance (Arbitrary a, Arbitrary b) => Arbitrary (a :> b) where+--  arbitrary = (:>) <$> arbitrary <*> arbitrary+--  shrink (a:>b) = (:>) <$> shrink a <*> shrink b++++-- | Base data constructor for multi-dimensional indices.++data Z = Z+  deriving (Eq,Ord,Read,Show,Generic,Data,Typeable)++derivingUnbox "Z"+  [t| Z -> () |]+  [| const () |]+  [| const Z  |]++instance Binary    Z+instance Serialize Z+instance ToJSON    Z+instance FromJSON  Z+instance Hashable  Z++instance Arbitrary Z where+  arbitrary = return Z++instance NFData Z where+  rnf Z = ()+  {-# Inline rnf #-}++++-- | Index structures for complex, heterogeneous indexing. Mostly designed for+-- indexing in DP grammars, where the indices work for linear and context-free+-- grammars on one or more tapes, for strings, sets, later on tree structures.++class Index i where+  -- | 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 ∷ 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 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.++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 #-}++-- | In case @totalSize@ or variants thereof produce a size that is too big to+-- handle.++newtype SizeError = SizeError String+  deriving (Eq,Ord,Show)++-- | The total number of cells that are allocated.++newtype CellSize = CellSize Word+  deriving (Eq,Ord,Show,Num,Bounded,Integral,Real,Enum)++++-- | Generate a stream of indices in correct order for dynamic programming.+-- Since the stream generators require @concatMap@ / @flatten@ we have to+-- write more specialized code for @(z:.IX)@ stuff.++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 ⇒ 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 ⇒ LimitType i → LimitType i → Stream m i++++instance Index Z where+  data LimitType Z = ZZ+  linearIndex _ _ = 0+  {-# INLINE linearIndex #-}+  size _ = 1+  {-# INLINE size #-}+  inBounds _ _ = True+  {-# INLINE inBounds #-}+  zeroBound = Z+  {-# Inline zeroBound #-}+  zeroBound' = ZZ+  {-# Inline zeroBound' #-}+  totalSize ZZ = [1]+  {-# Inline [1] totalSize #-}++instance IndexStream Z where+  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+  data LimitType (zs:.z) = !(LimitType zs) :.. !(LimitType z)+  linearIndex (hs:..h) (zs:.z) = linearIndex hs zs * size h + linearIndex h z+  {-# INLINE linearIndex #-}+  size (hs:..h) = size hs * size h+  {-# INLINE size #-}+  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 #-}++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 #-}++++-- * Somewhat experimental lens support.+--+-- The problem here is that tuples are n-ary, while inductive tuples are+-- binary, recursive.++instance Field1 (Z:.a) (Z:.a') a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a) → a) (\(Z:._) a → (Z:.a))++instance Field1 (Z:.a:.b) (Z:.a':.b) a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a:.b) → a) (\(Z:._:.b) a → (Z:.a:.b))++instance Field1 (Z:.a:.b:.c) (Z:.a':.b:.c) a a' where+  {-# Inline _1 #-}+  _1 = lens (\(Z:.a:.b:.c) → a) (\(Z:._:.b:.c) a → (Z:.a:.b:.c))+++instance Field2 (Z:.a:.b) (Z:.a:.b') b b' where+  {-# Inline _2 #-}+  _2 = lens (\(Z:.a:.b) → b) (\(Z:.a:._) b → (Z:.a:.b))++instance Field2 (Z:.a:.b:.c) (Z:.a:.b':.c) b b' where+  {-# Inline _2 #-}+  _2 = lens (\(Z:.a:.b:.c) → b) (\(Z:.a:._:.c) b → (Z:.a:.b:.c))+++instance Field3 (Z:.a:.b:.c) (Z:.a:.b:.c') c c' where+  {-# Inline _3 #-}+  _3 = lens (\(Z:.a:.b:.c) → c) (\(Z:.a:.b:._) c → (Z:.a:.b:.c))+
+ lib/Data/PrimitiveArray/Index/IOC.hs view
@@ -0,0 +1,17 @@++module Data.PrimitiveArray.Index.IOC where++++-- | Phantom type for @Inside@ indices.++data I++-- | Phantom type for @Outside@ indices.++data O++-- | Phantom type for @Complement@ indices.++data C+
+ lib/Data/PrimitiveArray/Index/Int.hs view
@@ -0,0 +1,50 @@++module Data.PrimitiveArray.Index.Int where++import qualified Data.Vector.Fusion.Stream.Monadic as SM++import           Data.PrimitiveArray.Index.Class++++instance Index Int where+  newtype LimitType Int = LtInt Int+  linearIndex _ k = k+  {-# Inline linearIndex #-}+  size (LtInt h) = h+1+  {-# Inline size #-}+  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:.. LtInt l) (hs:.. LtInt h) = SM.flatten mk step $ streamUp ls hs+    where mk z = return (z,l)+          step (z,k)+            | k > h     = return $ SM.Done+            | otherwise = return $ SM.Yield (z:.k) (z,k+1)+          {-# Inline [0] mk   #-}+          {-# Inline [0] step #-}+  {-# Inline streamUp #-}+  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 $ 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 = SM.map (\(Z:.k) -> k) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# Inline streamUp #-}+  streamDown l h = SM.map (\(Z:.k) -> k) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# Inline streamDown #-}+
+ lib/Data/PrimitiveArray/Index/PhantomInt.hs view
@@ -0,0 +1,108 @@++-- | A linear 0-based int-index with a phantom type.++module Data.PrimitiveArray.Index.PhantomInt where++import Control.DeepSeq (NFData(..))+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey)+import Data.Binary (Binary)+import Data.Data+import Data.Hashable (Hashable)+import Data.Ix(Ix)+import Data.Serialize (Serialize)+import Data.Typeable+import Data.Vector.Fusion.Stream.Monadic (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++++-- | A 'PInt' behaves exactly like an @Int@, but has an attached phantom+-- type @p@. In particular, the @Index@ and @IndexStream@ instances are the+-- same as for raw @Int@s.++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+pIntI = PInt+{-# Inline pIntI #-}++pIntO :: Int -> PInt O p+pIntO = PInt+{-# Inline pIntO #-}++pIntC :: Int -> PInt C p+pIntC = PInt+{-# Inline pIntC #-}++derivingUnbox "PInt"+  [t| forall t p . PInt t p -> Int |]  [| getPInt |]  [| PInt |]++instance Binary       (PInt t p)+instance Serialize    (PInt t p)+instance FromJSON     (PInt t p)+instance FromJSONKey  (PInt t p)+instance ToJSON       (PInt t p)+instance ToJSONKey    (PInt t p)+instance Hashable     (PInt t p)+instance NFData       (PInt t p)++instance Index (PInt t p) where+  newtype LimitType (PInt t p) = LtPInt Int+  linearIndex _ (PInt k) = k+  {-# Inline linearIndex #-}+  size (LtPInt h) = h+1+  {-# Inline size #-}+  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:..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:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamUp ls hs+  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream z => IndexStream (z:.PInt C p) where+  streamUp   (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamUpMk   l h) (streamUpStep   l h) $ streamUp ls hs+  streamDown (ls:..LtPInt l) (hs:..LtPInt h) = flatten (streamDownMk l h) (streamDownStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-}++instance IndexStream (Z:.PInt ioc p) => IndexStream (PInt ioc p) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++streamUpMk l h z = return (z,l)+{-# Inline [0] streamUpMk #-}++streamUpStep l h (z,k)+  | k > h     = return $ Done+  | otherwise = return $ Yield (z:.PInt k) (z,k+1)+{-# Inline [0] streamUpStep #-}++streamDownMk l h z = return (z,h)+{-# Inline [0] streamDownMk #-}++streamDownStep l h (z,k)+  | k < l     = return $ Done+  | otherwise = return $ Yield (z:.PInt k) (z,k-1)+{-# Inline [0] streamDownStep #-}+
+ lib/Data/PrimitiveArray/Index/Point.hs view
@@ -0,0 +1,229 @@++{-# Language MagicHash #-}++-- | @Point@ index structures are used for left- and right-linear grammars.+-- Such grammars have at most one syntactic symbol on each r.h.s. of a rule.+-- The syntactic symbol needs to be in an outermost position.++module Data.PrimitiveArray.Index.Point where++import           Control.Applicative+import           Control.DeepSeq (NFData(..))+import           Data.Aeson+import           Data.Binary+import           Data.Bits+import           Data.Bits.Extras (Ranked)+import           Data.Hashable (Hashable)+import           Data.Serialize+import           Data.Vector.Unboxed.Deriving+import           Data.Vector.Unboxed (Unbox(..))+import           GHC.Exts+import           GHC.Generics (Generic)+import qualified Data.Vector.Fusion.Stream.Monadic as SM+import qualified Data.Vector.Unboxed as VU+import           Test.QuickCheck as TQ+import           Test.SmallCheck.Series as TS++import           Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.IOC++++-- | A point in a left-linear grammar. The syntactic symbol is in left-most+-- position.++newtype PointL t = PointL {fromPointL :: Int}+  deriving (Eq,Ord,Read,Show,Generic)++pointLI :: Int -> PointL I+pointLI = PointL+{-# Inline pointLI #-}++pointLO :: Int -> PointL O+pointLO = PointL+{-# Inline pointLO #-}++pointLC :: Int -> PointL C+pointLC = PointL+{-# Inline pointLC #-}++++derivingUnbox "PointL"+  [t| forall t . PointL t -> Int    |]+  [| \ (PointL i) -> i |]+  [| \ i -> PointL i   |]++instance Binary       (PointL t)+instance Serialize    (PointL t)+instance FromJSON     (PointL t)+instance FromJSONKey  (PointL t)+instance ToJSON       (PointL t)+instance ToJSONKey    (PointL t)+instance Hashable     (PointL t)++instance NFData (PointL t) where+  rnf (PointL l) = rnf l+  {-# Inline rnf #-}++instance Index (PointL t) where+  newtype LimitType (PointL t) = LtPointL Int+  linearIndex _ (PointL z) = z+  {-# INLINE linearIndex #-}+  size (LtPointL h) = h + 1+  {-# INLINE size #-}+  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:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++instance IndexStream z => IndexStream (z:.PointL O) where+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamUp   ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++instance IndexStream z => IndexStream (z:.PointL C) where+  streamUp   (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointL ht) $ streamUp ls hs+  streamDown (ls:..LtPointL lf) (hs:..LtPointL ht) = SM.flatten (streamDownMk ht) (streamDownStep PointL lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++data SP z = SP !z !Int#++streamUpMk (I# lf) z = return $ SP z lf+{-# Inline [0] streamUpMk #-}++streamUpStep wrapper (I# ht) (SP z k)+  | 1# <- k ># ht = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k +# 1#))+{-# Inline [0] streamUpStep #-}++streamDownMk (I# ht) z = return $ SP z ht+{-# Inline [0] streamDownMk #-}++streamDownStep wrapper (I# lf) (SP z k)+  | 1# <- k <# lf = return $ SM.Done+  | otherwise     = return $ SM.Yield (z:.wrapper (I# k)) (SP z (k -# 1#))+{-# Inline [0] streamDownStep #-}++instance IndexStream (Z:.PointL t) => IndexStream (PointL t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}+++instance Arbitrary (PointL t) where+  arbitrary = do+    b <- choose (0,100)+    return $ PointL b+  shrink (PointL j)+    | 0<j = [PointL $ j-1]+    | otherwise = []++instance Monad m => Serial m (PointL t) where+  series = PointL . TS.getNonNegative <$> series++++-- * @PointR@++-- | A point in a right-linear grammars.++newtype PointR t = PointR {fromPointR :: Int}+  deriving (Eq,Ord,Read,Show,Generic)++++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 FromJSONKey  (PointR t)+instance ToJSON       (PointR t)+instance ToJSONKey    (PointR t)+instance Hashable     (PointR t)++instance NFData (PointR t) where+  rnf (PointR l) = rnf l+  {-# Inline rnf #-}++instance Index (PointR t) where+  newtype LimitType (PointR t) = LtPointR Int+  linearIndex _ (PointR z) = z+  {-# INLINE linearIndex #-}+  size (LtPointR h) = h + 1+  {-# INLINE size #-}+  inBounds (LtPointR h) (PointR x) = 0<=x && x<=h+  {-# INLINE inBounds #-}+  zeroBound = PointR 0+  {-# Inline [0] zeroBound #-}+  zeroBound' = LtPointR 0+  {-# Inline [0] zeroBound' #-}+  totalSize (LtPointR h) = [fromIntegral $ h + 1]+  {-# Inline [0] totalSize #-}++deriving instance Eq      (LimitType (PointR t))+deriving instance Generic (LimitType (PointR t))+deriving instance Read    (LimitType (PointR t))+deriving instance Show    (LimitType (PointR t))++instance IndexStream z => IndexStream (z:.PointR I) where+  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamUp ls hs+  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++instance IndexStream z => IndexStream (z:.PointR O) where+  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMk   lf) (streamUpStep   PointR ht) $ streamUp   ls hs+  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMk ht) (streamDownStep PointR lf) $ streamDown ls hs+  {-# Inline [0] streamUp #-}+  {-# Inline [0] streamDown #-}++--instance IndexStream z => IndexStream (z:.PointR C) where+--  streamUp   (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamUpMkR   lf) (streamUpStepR   ht) $ streamUp ls hs+--  streamDown (ls:..LtPointR lf) (hs:..LtPointR ht) = SM.flatten (streamDownMkR ht) (streamDownStepR lf) $ streamDown ls hs+--  {-# Inline [0] streamUp #-}+--  {-# Inline [0] streamDown #-}++instance IndexStream (Z:.PointR t) => IndexStream (PointR t) where+  streamUp l h = SM.map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = SM.map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++-- arbitrarily set maximum here to++arbMaxPointR = 100++instance Arbitrary (PointR t) where+  arbitrary = do+    b <- choose (0,arbMaxPointR)+    return $ PointR b+  shrink (PointR j)+    | j<arbMaxPointR = [PointR $ j+1]+    | otherwise = []++--instance Monad m => Serial m (PointR t) where+--  series = PointR . TS.getNonNegative <$> series+
+ lib/Data/PrimitiveArray/Index/Subword.hs view
@@ -0,0 +1,178 @@++-- | Index structure for context-free grammars on strings. A @Subword@ captures+-- a pair @(i,j)@ with @i<=j@.++module Data.PrimitiveArray.Index.Subword 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,flatten)+import Data.Vector.Unboxed.Deriving+import GHC.Generics (Generic)+import Prelude hiding (map)+import Test.QuickCheck (Arbitrary(..), choose)+import Test.SmallCheck.Series as TS++import Math.TriangularNumbers++import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.IOC++++-- | A subword wraps a pair of @Int@ indices @i,j@ with @i<=j@.+--+-- Subwords always yield the upper-triangular part of a rect-angular array.+-- This gives the quite curious effect that @(0,N)@ points to the+-- ``largest'' index, while @(0,0) ... (1,1) ... (k,k) ... (N,N)@ point to+-- the smallest. We do, however, use (0,0) as the smallest as (0,k) gives+-- successively smaller upper triangular parts.++newtype Subword t = Subword {fromSubword :: (Int:.Int)}+  deriving (Eq,Ord,Show,Generic,Read)++fromSubwordFst :: Subword t -> Int+fromSubwordFst (Subword (i:._)) = i+{-# Inline fromSubwordFst #-}++fromSubwordSnd :: Subword t -> Int+fromSubwordSnd (Subword (_:.j)) = j+{-# Inline fromSubwordSnd #-}++derivingUnbox "Subword"+  [t| forall t . Subword t -> (Int,Int) |]+  [| \ (Subword (i:.j)) -> (i,j) |]+  [| \ (i,j) -> Subword (i:.j) |]++instance Binary       (Subword t)+instance Serialize    (Subword t)+instance FromJSON     (Subword t)+instance FromJSONKey  (Subword t)+instance ToJSON       (Subword t)+instance ToJSONKey    (Subword t)+instance Hashable     (Subword t)++instance NFData (Subword t) where+  rnf (Subword (i:.j)) = i `seq` rnf j+  {-# Inline rnf #-}++-- | Create a @Subword t@ where @t@ is inferred.++subword :: Int -> Int -> Subword t+subword i j = Subword (i:.j)+{-# INLINE subword #-}++subwordI :: Int -> Int -> Subword I+subwordI i j = Subword (i:.j)+{-# INLINE subwordI #-}++subwordO :: Int -> Int -> Subword O+subwordO i j = Subword (i:.j)+{-# INLINE subwordO #-}++subwordC :: Int -> Int -> Subword C+subwordC i j = Subword (i:.j)+{-# INLINE subwordC #-}++++instance Index (Subword t) where+  newtype LimitType (Subword t) = LtSubword Int+  linearIndex (LtSubword n) (Subword (i:.j)) = toLinear n (i,j)+  {-# Inline linearIndex #-}+  size (LtSubword n) = linearizeUppertri (0,n)+  {-# Inline size #-}+  inBounds (LtSubword h) (Subword (i:.j)) = 0<=i && i<=j && j<=h+  {-# Inline inBounds #-}+  zeroBound = subword 0 0+  {-# Inline zeroBound #-}+  zeroBound' = LtSubword 0+  {-# Inline zeroBound' #-}+  totalSize (LtSubword n) = [fromIntegral (n+1) ^ 2 `div` 2]+  {-# Inline totalSize #-}++deriving instance Eq      (LimitType (Subword t))+deriving instance Generic (LimitType (Subword t))+deriving instance Read    (LimitType (Subword t))+deriving instance Show    (LimitType (Subword t))++-- | @Subword I@ (inside)++instance IndexStream z => IndexStream (z:.Subword I) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++-- | @Subword O@ (outside).+--+-- Note: @streamUp@ really needs to use @streamDownMk@ / @streamDownStep@+-- for the right order of indices!++instance IndexStream z => IndexStream (z:.Subword O) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++-- | @Subword C@ (complement)++instance IndexStream z => IndexStream (z:.Subword C) where+  streamUp   (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamUpMk     h) (streamUpStep   l h) $ streamUp   ls hs+  streamDown (ls:..LtSubword l) (hs:..LtSubword h) = flatten (streamDownMk l h) (streamDownStep   h) $ streamDown ls hs+  {-# Inline streamUp #-}+  {-# Inline streamDown #-}++-- | generic @mk@ for @streamUp@ / @streamDown@++streamUpMk h z = return (z,h,h)+{-# Inline [0] streamUpMk #-}++streamUpStep l h (z,i,j)+  | i < l     = return $ Done+  | j > h     = return $ Skip (z,i-1,i-1)+  | otherwise = return $ Yield (z:.subword i j) (z,i,j+1)+{-# Inline [0] streamUpStep #-}++streamDownMk l h z = return (z,l,h)+{-# Inline [0] streamDownMk #-}++streamDownStep h (z,i,j)+  | i > h     = return $ Done+  | j < i     = return $ Skip (z,i+1,h)+  | otherwise = return $ Yield (z:.subword i j) (z,i,j-1)+{-# Inline [0] streamDownStep #-}++instance (IndexStream (Z:.Subword t)) => IndexStream (Subword t) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++instance Arbitrary (Subword t) where+  arbitrary = do+    a <- choose (0,20)+    b <- choose (0,20)+    return $ Subword (min a b :. max a b)+  shrink (Subword (i:.j))+    | i<j       = [Subword (i:.j-1), Subword (i+1:.j)]+    | otherwise = []++instance Monad m => Serial m (Subword t) where+  series = do+    i <- TS.getNonNegative <$> series+    j <- TS.getNonNegative <$> series+    guard $ i<=j+    return $ subword i j+    {-+    let nns :: Series m Int = TS.getNonNegative <$> series+    ps <- nns >< nns+    let qs = [ subword i j | (i,j) <- ps, i<=j ]+    return qs+    -}+
+ lib/Data/PrimitiveArray/Index/Unit.hs view
@@ -0,0 +1,78 @@++-- | Unit indices admit a single element to be memoized. We can't use @()@+-- because we want to attach phantom types.++module Data.PrimitiveArray.Index.Unit where++import Control.Applicative (pure)+import Control.DeepSeq (NFData(..))+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey)+import Data.Binary (Binary)+import Data.Hashable (Hashable)+import Data.Serialize (Serialize)+import Data.Vector.Fusion.Stream.Monadic (Step(..), map)+import Data.Vector.Unboxed.Deriving+import GHC.Generics (Generic)+import Prelude hiding (map)+import Test.QuickCheck (Arbitrary(..), choose)++import Data.PrimitiveArray.Index.Class++++data Unit t = Unit+  deriving (Eq,Ord,Show,Generic,Read)++derivingUnbox "Unit"+  [t| forall t . Unit t -> () |]+  [| \ Unit -> ()   |]+  [| \ ()   -> Unit |]++instance Binary       (Unit t)+instance Serialize    (Unit t)+instance FromJSON     (Unit t)+instance FromJSONKey  (Unit t)+instance ToJSON       (Unit t)+instance ToJSONKey    (Unit t)+instance Hashable     (Unit t)++instance NFData (Unit t) where+  rnf Unit = ()+  {-# Inline rnf #-}++instance Index (Unit t) where+  data LimitType (Unit t) = LtUnit+  linearIndex _ _ = 0+  {-# Inline linearIndex #-}+  size _ = 1+  {-# Inline size #-}+  inBounds _ _ = True+  {-# Inline inBounds #-}+  zeroBound = Unit+  {-# Inline zeroBound #-}+  zeroBound' = LtUnit+  {-# Inline zeroBound' #-}+  totalSize LtUnit = return 1+  {-# Inline [0] totalSize #-}++deriving instance Eq      (LimitType (Unit t))+deriving instance Generic (LimitType (Unit t))+deriving instance Read    (LimitType (Unit t))+deriving instance Show    (LimitType (Unit t))++instance IndexStream z => IndexStream (z:.Unit t) where+  streamUp (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamUp ls hs+  {-# Inline streamUp #-}+  streamDown (ls:..LtUnit) (hs:..LtUnit) = map (\z -> z:.Unit) $ streamDown ls hs+  {-# Inline streamDown #-}++instance (IndexStream (Z:.Unit t)) => IndexStream (Unit t) where+  streamUp l h = map (\(Z:.i) -> i) $ streamUp (ZZ:..l) (ZZ:..h)+  {-# INLINE streamUp #-}+  streamDown l h = map (\(Z:.i) -> i) $ streamDown (ZZ:..l) (ZZ:..h)+  {-# INLINE streamDown #-}++instance Arbitrary (Unit t) where+  arbitrary = pure Unit+  shrink Unit = []+
+ lib/Data/PrimitiveArray/ScoreMatrix.hs view
@@ -0,0 +1,123 @@++-- | Simple score and distance matrices. These are two-dimensional tables+-- together with row and column vectors of names.++module Data.PrimitiveArray.ScoreMatrix where++import           Control.Monad (when,unless)+import           Data.Text (Text)+import           Data.Vector.Unboxed (Unbox)+import           Numeric.Log+import qualified Data.Text as T+import qualified Data.Vector as V+import           System.Exit (exitFailure)++import           Data.PrimitiveArray hiding (map)+import qualified Data.PrimitiveArray as PA++++-- | NxN sized score matrices+--+-- TODO needs a vector with the column names!++data ScoreMatrix t = ScoreMatrix+  { scoreMatrix :: !(Unboxed (Z:.Int:.Int) t)+  , scoreNodes  :: !(Unboxed Int t)+  , rowNames    :: !(V.Vector Text)+  , colNames    :: !(V.Vector Text)+  } deriving (Show)++-- | Get the distance between edges @(From,To)@.++(.!.) :: Unbox t => ScoreMatrix t -> (Int,Int) -> t+ScoreMatrix mat _ _ _ .!. (f,t) = mat ! (Z:.f:.t)+{-# Inline (.!.) #-}++-- | If the initial node has a "distance", it'll be here++nodeDist :: Unbox t => ScoreMatrix t -> Int -> t+nodeDist ScoreMatrix{..} k = scoreNodes ! k++-- | Get the name of the node at an row index++rowNameOf :: ScoreMatrix t -> Int -> Text+rowNameOf ScoreMatrix{..} k = rowNames V.! k+{-# Inline rowNameOf #-}++-- | Get the name of the node at an column index++colNameOf :: ScoreMatrix t -> Int -> Text+colNameOf ScoreMatrix{..} k = colNames V.! k+{-# Inline colNameOf #-}++-- | Number of rows in a score matrix.++numRows :: Unbox t => ScoreMatrix t -> Int+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 (_:.._:..LtInt n') = upperBound scoreMatrix in n' + 1+{-# Inline numCols #-}++listOfRowNames :: ScoreMatrix t -> [Text]+listOfRowNames ScoreMatrix{..} = V.toList rowNames++listOfColNames :: ScoreMatrix t -> [Text]+listOfColNames ScoreMatrix{..} = V.toList colNames++-- | Turns a @ScoreMatrix@ for distances into one scaled by "temperature" for+-- Inside/Outside calculations. Each value is scaled by+-- @\k -> exp $ negate k / r * t@ where+-- r = (n-1) * d+-- d = mean of genetic distance+--+-- Node scores are turned directly into probabilities.+--+-- TODO Again, there is overlap and we should really have @newtype+-- Distance@ and friends.+--+-- TODO @newtype Temperature = Temperature Double@+--+-- TODO fix for rows /= cols!!!++toPartMatrix+  :: Double+  -- ^ temperature+  -> ScoreMatrix Double+  -> ScoreMatrix (Log Double)+toPartMatrix t scoreMat@(ScoreMatrix mat sn rns cns) = ScoreMatrix p psn rns cns+  where p = PA.map (\k -> Exp {- . log . exp -} $ negate k / (r * t)) mat+        psn = PA.map (\k -> Exp $ negate k) sn+        n = numRows scoreMat+        d = Prelude.sum [ mat ! (Z:.i:.j) | i <- [0..n-1], j <- [i+1..n-1] ] / fromIntegral (n*(n-1))+        r = fromIntegral (n-1) * d++-- | Import data.+--+-- TODO Should be generalized because @Lib-BiobaseBlast@ does almost the+-- same thing.++fromFile :: FilePath -> IO (ScoreMatrix Double)+fromFile fp = do+  ls <- lines <$> readFile fp+  when (null ls) $ do+    putStrLn $ fp ++ " is empty"+    exitFailure+  let mat' = map (map read . tail . words) $ tail ls+  let n = length mat'+  unless (all ((==n) . length) mat') $ do+    putStrLn $ fp ++ " is not a NxN matrix"+    print mat'+    exitFailure+  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 (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)+