PrimitiveArray 0.7.1.0 → 0.8.0.0

raw patch · 15 files changed

+503/−136 lines, 15 filesdep +containersdep +log-domaindep +textdep ~DPutilsdep ~QuickCheckdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, log-domain, text

Dependency ranges changed: DPutils, QuickCheck, aeson, binary, bits, cereal, cereal-vector, deepseq, hashable, primitive, smallcheck, vector, vector-binary-instances, vector-th-unbox

API changes (from Hackage documentation)

Files

• Data/PrimitiveArray/Dense.hs +7/−4
• Data/PrimitiveArray/Index.hs +2/−1
• Data/PrimitiveArray/Index/Class.hs +3/−0
• Data/PrimitiveArray/Index/EdgeBoundary.hs +141/−0
• Data/PrimitiveArray/Index/PhantomInt.hs +9/−7
• Data/PrimitiveArray/Index/Point.hs +7/−5
• Data/PrimitiveArray/Index/Set.hs +114/−77
• Data/PrimitiveArray/Index/Subword.hs +16/−6
• Data/PrimitiveArray/Index/Unit.hs +8/−6
• Data/PrimitiveArray/ScoreMatrix.hs +123/−0
• PrimitiveArray.cabal +24/−17
• changelog.md +15/−0
• tests/Common.hs +17/−5
• tests/QuickCheck.hs +7/−2
• tests/SmallCheck.hs +10/−6

@@ -32,6 +32,7 @@ import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as VU hiding (forM_, length, zipWithM_) import           Data.Hashable (Hashable)+import           Data.Typeable (Typeable)   import           Data.PrimitiveArray.Class@@ -42,7 +43,7 @@ -- * Unboxed, multidimensional arrays.  data Unboxed sh e = Unboxed !sh !sh !(VU.Vector e)-  deriving (Read,Show,Eq,Generic)+  deriving (Read,Show,Eq,Generic,Typeable)  instance (Binary    sh, Binary    e, Unbox e) => Binary    (Unboxed sh e) instance (Serialize sh, Serialize e, Unbox e) => Serialize (Unboxed sh e)@@ -55,6 +56,7 @@   {-# Inline rnf #-}  data instance MutArr m (Unboxed sh e) = MUnboxed !sh !sh !(VU.MVector (PrimState m) e)+  deriving (Generic,Typeable)  instance (NFData sh) => NFData (MutArr m (Unboxed sh e)) where   rnf (MUnboxed l h xs) = rnf l `seq` rnf h `seq` rnf xs@@ -77,7 +79,7 @@   writeM (MUnboxed l h mba) idx elm = unsafeWrite mba (linearIndex l h idx) elm   {-# INLINE boundsM #-}   {-# INLINE fromListM #-}-  {-# INLINE newM #-}+  {-# NoInline newM #-}   {-# INLINE newWithM #-}   {-# INLINE readM #-}   {-# INLINE writeM #-}@@ -103,7 +105,7 @@ -- * Boxed, multidimensional arrays.  data Boxed sh e = Boxed !sh !sh !(V.Vector e)-  deriving (Read,Show,Eq,Generic)+  deriving (Read,Show,Eq,Generic,Typeable)  instance (Binary    sh, Binary    e)  => Binary    (Boxed sh e) instance (Serialize sh, Serialize e)  => Serialize (Boxed sh e)@@ -116,6 +118,7 @@   {-# Inline rnf #-}  data instance MutArr m (Boxed sh e) = MBoxed !sh !sh !(V.MVector (PrimState m) e)+  deriving (Generic,Typeable)  instance (NFData sh) => NFData (MutArr m (Boxed sh e)) where   rnf (MBoxed l h _) = rnf l `seq` rnf h -- no rnf for the data !@@ -139,7 +142,7 @@   writeM (MBoxed l h mba) idx elm = assert (inBounds l h idx) $ GM.write mba (linearIndex l h idx) elm   {-# INLINE boundsM #-}   {-# INLINE fromListM #-}-  {-# INLINE newM #-}+  {-# NoInline newM #-}   {-# INLINE newWithM #-}   {-# INLINE readM #-}   {-# INLINE writeM #-}

@@ -1,7 +1,7 @@  module Data.PrimitiveArray.Index   ( module Data.PrimitiveArray.Index.Class-  , module Data.PrimitiveArray.Index.Int+  , module Data.PrimitiveArray.Index.EdgeBoundary   , module Data.PrimitiveArray.Index.IOC   , module Data.PrimitiveArray.Index.PhantomInt   , module Data.PrimitiveArray.Index.Point@@ -11,6 +11,7 @@   ) 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)

@@ -35,6 +35,9 @@ 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

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

@@ -4,7 +4,7 @@ module Data.PrimitiveArray.Index.PhantomInt where  import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey) import Data.Binary (Binary) import Data.Data import Data.Hashable (Hashable)@@ -44,12 +44,14 @@ 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 ToJSON    (PInt t p)-instance Hashable  (PInt t p)-instance NFData    (PInt t p)+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   linearIndex _ _ (PInt k) = k

@@ -60,11 +60,13 @@   [| \ (PointL i) -> i |]   [| \ i -> PointL i   |] -instance Binary    (PointL t)-instance Serialize (PointL t)-instance FromJSON  (PointL t)-instance ToJSON    (PointL t)-instance Hashable  (PointL t)+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

@@ -7,7 +7,7 @@  import           Control.Applicative ((<$>),(<*>)) import           Control.DeepSeq (NFData(..))-import           Data.Aeson (FromJSON,ToJSON)+import           Data.Aeson (FromJSON,ToJSON,FromJSONKey,ToJSONKey) import           Data.Binary (Binary) import           Data.Bits import           Data.Bits.Extras@@ -37,11 +37,11 @@ -- These include a @First@ element and a @Last@ element. We phantom-type -- these to reduce programming overhead. -newtype Interface t = Iter { getIter :: Int }+newtype Boundary i t = Boundary { getBoundary :: Int }   deriving (Eq,Ord,Generic,Num) -instance Show (Interface t) where-  show (Iter i) = "(I:" ++ show i ++ ")"+instance Show (Boundary i t) where+  show (Boundary i) = "(I:" ++ show i ++ ")"  -- | Declare the interface to be the start of a path. @@ -65,6 +65,11 @@ newtype BitSet t = BitSet { getBitSet :: Int }   deriving (Eq,Ord,Read,Generic,FiniteBits,Ranked,Num,Bits) +instance FromJSON     (BitSet t)+instance FromJSONKey  (BitSet t)+instance ToJSON       (BitSet t)+instance ToJSONKey    (BitSet t)+ bitSetI :: Int -> BitSet I bitSetI = BitSet {-# Inline bitSetI #-}@@ -79,17 +84,17 @@  -- | A bitset with one interface. --- type BS1 t i = BitSet t :> Interface i+-- type BS1 t i = BitSet t :> Boundary i -data BS1 i t = BS1 !(BitSet t) !(Interface i)+data BS1 i t = BS1 !(BitSet t) !(Boundary i t)  deriving instance Show (BS1 i t)  -- | A bitset with two interfaces. --- type BS2 t i j = BitSet t :> Interface i :> Interface j+-- type BS2 t i j = BitSet t :> Boundary i :> Boundary j -data BS2 i j t = BS2 !(BitSet t) !(Interface i) !(Interface j)+data BS2 i j t = BS2 !(BitSet t) !(Boundary i t) !(Boundary j t)  deriving instance Show (BS2 i j t) @@ -145,35 +150,63 @@   -derivingUnbox "Interface"-  [t| forall t . Interface t -> Int |]-  [| \(Iter i) -> i            |]-  [| Iter                      |]+derivingUnbox "Boundary"+  [t| forall i t . Boundary i t -> Int |]+  [| \(Boundary i) -> i                |]+  [| Boundary                          |] -instance Binary    (Interface t)-instance Serialize (Interface t)-instance ToJSON    (Interface t)-instance FromJSON  (Interface t)-instance Hashable  (Interface t)+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 (Interface t) where-  rnf (Iter i) = rnf i+instance NFData (Boundary i t) where+  rnf (Boundary i) = rnf i   {-# Inline rnf #-} -instance Index (Interface i) where-  linearIndex l _ (Iter z) = z - smallestLinearIndex l+instance Index (Boundary i t) where+  linearIndex l _ (Boundary z) = z - smallestLinearIndex l   {-# INLINE linearIndex #-}-  smallestLinearIndex (Iter l) = l+  smallestLinearIndex (Boundary l) = l   {-# INLINE smallestLinearIndex #-}-  largestLinearIndex (Iter h) = h+  largestLinearIndex (Boundary h) = h   {-# INLINE largestLinearIndex #-}-  size (Iter l) (Iter h) = h - l + 1+  size (Boundary l) (Boundary h) = h - l + 1   {-# INLINE size #-}   inBounds l h z = l <= z && z <= h   {-# INLINE inBounds #-} +instance IndexStream z => IndexStream (z:.Boundary k I) where+  streamUp   (ls:.l) (hs:.h) = flatten (streamUpBndMk   l h) (streamUpBndStep   l h) $ streamUp   ls hs+  streamDown (ls:.l) (hs:.h) = flatten (streamDownBndMk l h) (streamDownBndStep l h) $ streamDown ls hs+  {-# Inline streamUp   #-}+  {-# Inline streamDown #-} +instance IndexStream (Z:.Boundary k I) => IndexStream (Boundary k I) +streamUpBndMk :: (Monad m) => Boundary k i -> Boundary k i -> t -> m (t, Boundary k i)+streamUpBndMk l h z = return (z, l)+{-# Inline [0] streamUpBndMk #-}++streamUpBndStep :: (Monad m) => Boundary k i -> Boundary k i -> (t, Boundary k i) -> m (SM.Step (t, Boundary k i) (t :. Boundary k i))+streamUpBndStep l h (z , k)+  | k > h     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.k) (z, k+1)+{-# Inline [0] streamUpBndStep #-}++streamDownBndMk :: (Monad m) => Boundary k i -> Boundary k i -> t -> m (t, Boundary k i)+streamDownBndMk l h z = return (z, h)+{-# Inline [0] streamDownBndMk #-}++streamDownBndStep :: (Monad m) => Boundary k i -> Boundary k i -> (t, Boundary k i) -> m (SM.Step (t, Boundary k i) (t :. Boundary k i))+streamDownBndStep l h (z , k)+  | k < l     = return $ SM.Done+  | otherwise = return $ SM.Yield (z:.k) (z,k-1)+{-# Inline [0] streamDownBndStep #-}+++ derivingUnbox "BitSet"   [t| forall t . BitSet t -> Int |]   [| \(BitSet s) -> s   |]@@ -184,8 +217,6 @@  instance Binary    (BitSet t) instance Serialize (BitSet t)-instance ToJSON    (BitSet t)-instance FromJSON  (BitSet t) instance Hashable  (BitSet t)  instance NFData (BitSet t) where@@ -247,8 +278,14 @@  -- ** @BS1@ +-- |+--+-- @linearIndex@ explicitly maps @BS1 0 whatever@ to @0@.+ instance Index (BS1 i t) where-  linearIndex (BS1 ls li) (BS1 hs hi) (BS1 s i) = linearIndex (ls:.li) (hs:.hi) (s:.i)+  linearIndex (BS1 ls li) (BS1 hs hi) (BS1 s i)+    | s == 0    = 0+    | otherwise = linearIndex (ls:.li) (hs:.hi) (s:.i)   {-# INLINE linearIndex #-}   smallestLinearIndex (BS1 s i) = smallestLinearIndex (s:.i)   {-# INLINE smallestLinearIndex #-}@@ -280,7 +317,7 @@ instance IndexStream (Z:.BS1 i t) => IndexStream (BS1 i t)  streamUpBsIMk :: (Monad m) => BS1 a i -> BS1 b i -> z -> m (z, Maybe (BS1 c i))-streamUpBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sl (Iter . max 0 $ lsbZ sl)) else Nothing)+streamUpBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sl (Boundary . max 0 $ lsbZ sl)) else Nothing) {-# Inline [0] streamUpBsIMk #-}  streamUpBsIStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))@@ -289,7 +326,7 @@ {-# Inline [0] streamUpBsIStep #-}  streamDownBsIMk :: (Monad m) => BS1 a i -> BS1 b i -> z -> m (z, Maybe (BS1 c i))-streamDownBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sl (Iter . max 0 $ lsbZ sh)) else Nothing)+streamDownBsIMk (BS1 sl _) (BS1 sh _) z = return (z, if sl <= sh then Just (BS1 sh (Boundary . max 0 $ lsbZ sh)) else Nothing) {-# Inline [0] streamDownBsIMk #-}  streamDownBsIStep :: (Monad m, SetPredSucc s) => s -> s -> (t, Maybe s) -> m (SM.Step (t, Maybe s) (t :. s))@@ -338,9 +375,9 @@   | sl > sh   = return (z , Nothing)   | cl == 0   = return (z , Just (BS2 0 0 0))   | cl == 1   = let i = lsbZ sl-                in  return (z , Just (BS2 sl (Iter i) (Iter i)))+                in  return (z , Just (BS2 sl (Boundary i) (Boundary i)))   | otherwise = let i = lsbZ sl; j = lsbZ (sl `clearBit` i)-                in  return (z , Just (BS2 sl (Iter i) (Iter j)))+                in  return (z , Just (BS2 sl (Boundary i) (Boundary j)))   where cl = popCount sl {-# Inline [0] streamUpBsIiMk #-} @@ -354,9 +391,9 @@   | sl > sh   = return (z , Nothing)   | ch == 0   = return (z , Just (BS2 0 0 0))   | ch == 1   = let i = lsbZ sh-                in  return (z , Just (BS2 sh (Iter i) (Iter i)))+                in  return (z , Just (BS2 sh (Boundary i) (Boundary i)))   | otherwise = let i = lsbZ sh; j = lsbZ sh-                in  return (z , Just (BS2 sh (Iter i) (Iter j)))+                in  return (z , Just (BS2 sh (Boundary i) (Boundary j)))   where ch = popCount sh {-# Inline [0] streamDownBsIiMk #-} @@ -389,28 +426,28 @@   {-# Inline setPred #-}  instance SetPredSucc (BS1 i t) where-  setSucc (BS1 l il) (BS1 h ih) (BS1 s (Iter is))+  setSucc (BS1 l il) (BS1 h ih) (BS1 s (Boundary is))     | cs > ch                          = Nothing-    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Iter is')-    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Iter $ lsbZ s')+    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Boundary is')+    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Boundary $ lsbZ s')     | cs >= ch                         = Nothing-    | cs < ch                          = let s' = BitSet $ 2^(cs+1)-1 in Just (BS1 s' (Iter (lsbZ s')))+    | cs < ch                          = let s' = BitSet $ 2^(cs+1)-1 in Just (BS1 s' (Boundary (lsbZ s')))     where ch = popCount h           cs = popCount s   {-# Inline setSucc #-}-  setPred (BS1 l il) (BS1 h ih) (BS1 s (Iter is))+  setPred (BS1 l il) (BS1 h ih) (BS1 s (Boundary is))     | cs < cl                          = Nothing-    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Iter is')-    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Iter  $ lsbZ s')+    | Just is' <- maybeNextActive is s = Just $ BS1 s  (Boundary is')+    | Just s'  <- popPermutation ch s  = Just $ BS1 s' (Boundary  $ lsbZ s')     | cs <= cl                         = Nothing-    | cs > cl                          = let s' = BitSet $ 2^(cs-1)-1 in Just (BS1 s' (Iter (max 0 $ lsbZ s')))+    | cs > cl                          = let s' = BitSet $ 2^(cs-1)-1 in Just (BS1 s' (Boundary (max 0 $ lsbZ s')))     where cl = popCount l           ch = popCount h           cs = popCount s   {-# Inline setPred #-}  instance SetPredSucc (BS2 i j t) where-  setSucc (BS2 l il jl) (BS2 h ih jh) (BS2 s (Iter is) (Iter js))+  setSucc (BS2 l il jl) (BS2 h ih jh) (BS2 s (Boundary is) (Boundary js))     -- early termination     | cs > ch                         = Nothing     -- in case nothing was set, set initial set @1@ with both interfaces@@ -420,27 +457,27 @@     -- and set the single interface     | cs == 1     , Just s'  <- popPermutation ch s-    , let is' = lsbZ s'          = Just (BS2 s' (Iter is') (Iter is'))+    , let is' = lsbZ s'          = Just (BS2 s' (Boundary is') (Boundary is'))     -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Iter is) (Iter js'))+    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Boundary is) (Boundary js'))     -- advance other interface,      | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Iter is') (Iter js'))+    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Boundary is') (Boundary js'))     -- find another permutation of the population     | Just s'  <- popPermutation ch s     , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Iter is') (Iter js'))+    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary js'))     -- increasing the population forbidden by upper limit     | cs >= ch                        = Nothing     -- increase population     | cs < ch     , let s' = BitSet $ 2^(cs+1)-1     , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Iter is') (Iter js'))+    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary js'))     where ch = popCount h           cs = popCount s   {-# Inline setSucc #-}-  setPred (BS2 l il jl) (BS2 h ih jh) (BS2 s (Iter is) (Iter js))+  setPred (BS2 l il jl) (BS2 h ih jh) (BS2 s (Boundary is) (Boundary js))     -- early termination     | cs < cl                         = Nothing     -- in case nothing was set, set initial set @1@ with both interfaces@@ -450,25 +487,25 @@     -- and set the single interface     | cs == 1     , Just s'  <- popPermutation ch s-    , let is' = lsbZ s'          = Just (BS2 s' (Iter is') (Iter is'))+    , let is' = lsbZ s'          = Just (BS2 s' (Boundary is') (Boundary is'))     -- return the single @0@ set     | cs == 1                         = Just (BS2 0 0 0)     -- try advancing only one of the interfaces, doesn't collide with @is@-    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Iter is) (Iter js'))+    | Just js' <- maybeNextActive js (s `clearBit` is) = Just (BS2 s (Boundary is) (Boundary js'))     -- advance other interface,      | Just is' <- maybeNextActive is s-    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Iter is') (Iter js'))+    , let js' = lsbZ (s `clearBit` is')      = Just (BS2 s (Boundary is') (Boundary js'))     -- find another permutation of the population     | Just s'  <- popPermutation ch s     , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Iter is') (Iter js'))+    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary js'))     -- decreasing the population forbidden by upper limit     | cs <= cl                        = Nothing     -- decrease population     | cs > cl && cs > 2     , let s' = BitSet $ 2^(cs-1)-1     , let is' = lsbZ s'-    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Iter is') (Iter js'))+    , Just js' <- maybeNextActive is' s'   = Just (BS2 s' (Boundary is') (Boundary js'))     -- decrease population to single-element sets     | cs > cl && cs == 2              = Just (BS2 1 0 0)     where cl = popCount l@@ -535,30 +572,30 @@  instance SetPredSucc (Fixed (BS1 i t)) where   setPred (Fixed _ (BS1 l li)) (Fixed _ (BS1 h hi)) (Fixed !m (BS1 s i))-    | s `testBit` getIter i = (Fixed m . (`BS1` i) . ( `setBit` getIter i)) <$> setPred l h (s .&. complement m)+    | s `testBit` getBoundary i = (Fixed m . (`BS1` i) . ( `setBit` getBoundary i)) <$> setPred l h (s .&. complement m)     | otherwise             = (Fixed m) <$> setPred (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)   {-# Inline setPred #-}   setSucc (Fixed _ (BS1 l li)) (Fixed _ (BS1 h hi)) (Fixed !m (BS1 s i))-    | s `testBit` getIter i = (Fixed m . (`BS1` i) . ( `setBit` getIter i)) <$> setSucc l h (s .&. complement m)+    | s `testBit` getBoundary i = (Fixed m . (`BS1` i) . ( `setBit` getBoundary i)) <$> setSucc l h (s .&. complement m)     | otherwise             = (Fixed m) <$> setSucc (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)   {-# Inline setSucc #-}  instance SetPredSucc (Fixed (BS2 i j t)) where   setPred (Fixed _ (BS2 l li lj)) (Fixed _ (BS2 h hi hj)) (Fixed !m (BS2 s i j))-    | s `testBit` getIter i && s `testBit` getIter j-    = (Fixed m . (\z       -> BS2 (z `setBit` getIter i `setBit` getIter j) i j)) <$> setPred l h (s .&. complement m)-    | s `testBit` getIter i-    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getIter i) i j')) <$> setPred (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)-    | s `testBit` getIter j-    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getIter j) i' j)) <$> setPred (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)+    | s `testBit` getBoundary i && s `testBit` getBoundary j+    = (Fixed m . (\z       -> BS2 (z `setBit` getBoundary i `setBit` getBoundary j) i j)) <$> setPred l h (s .&. complement m)+    | s `testBit` getBoundary i+    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getBoundary i) i j')) <$> setPred (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)+    | s `testBit` getBoundary j+    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getBoundary j) i' j)) <$> setPred (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)   {-# Inline setPred #-}   setSucc (Fixed _ (BS2 l li lj)) (Fixed _ (BS2 h hi hj)) (Fixed !m (BS2 s i j))-    | s `testBit` getIter i && s `testBit` getIter j-    = (Fixed m . (\z       -> BS2 (z `setBit` getIter i `setBit` getIter j) i j)) <$> setSucc l h (s .&. complement m)-    | s `testBit` getIter i-    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getIter i) i j')) <$> setSucc (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)-    | s `testBit` getIter j-    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getIter j) i' j)) <$> setSucc (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)+    | s `testBit` getBoundary i && s `testBit` getBoundary j+    = (Fixed m . (\z       -> BS2 (z `setBit` getBoundary i `setBit` getBoundary j) i j)) <$> setSucc l h (s .&. complement m)+    | s `testBit` getBoundary i+    = (Fixed m . (\(BS1 z j') -> BS2 (z `setBit` getBoundary i) i j')) <$> setSucc (BS1 l lj) (BS1 h hj) (BS1 (s .&. complement m) j)+    | s `testBit` getBoundary j+    = (Fixed m . (\(BS1 z i') -> BS2 (z `setBit` getBoundary j) i' j)) <$> setSucc (BS1 l li) (BS1 h hi) (BS1 (s .&. complement m) i)   {-# Inline setSucc #-}  @@ -570,17 +607,17 @@ instance ApplyMask (BS1 i t) where   applyMask m (BS1 s i)     | popCount s == 0 = BS1 0 0-    | otherwise       = BS1 (popShiftL m s) (Iter . getBitSet . popShiftL m . BitSet $ 2 ^ getIter i)+    | otherwise       = BS1 (popShiftL m s) (Boundary . lsbZ . popShiftL m . BitSet . bit $ getBoundary i)   {-# Inline applyMask #-}  instance ApplyMask (BS2 i j t) where   applyMask m (BS2 s i j)     | popCount s == 0 = BS2 0 0 0-    | popCount s == 1 = BS2 s' i' (Iter $ getIter i')+    | popCount s == 1 = BS2 s' i' (Boundary $ getBoundary i')     | otherwise       = BS2 s' i' j'     where s' = popShiftL m s-          i' = Iter . getBitSet . popShiftL m $ (BitSet $ 2 ^ getIter i :: BitSet t)-          j' = Iter . getBitSet . popShiftL m $ (BitSet $ 2 ^ getIter j :: BitSet t)+          i' = Boundary . getBitSet . popShiftL m $ (BitSet $ 2 ^ getBoundary i :: BitSet t)+          j' = Boundary . getBitSet . popShiftL m $ (BitSet $ 2 ^ getBoundary j :: BitSet t)   {-# Inline applyMask #-}  @@ -602,11 +639,11 @@     if s==0       then return (BS1 s 0)       else do i <- elements $ activeBitsL s-              return (BS1 s $ Iter i)+              return (BS1 s $ Boundary i)   shrink (BS1 s i) =     let s' = [ BS1 (s `clearBit` a) i              | a <- activeBitsL s-             , Iter a /= i ]+             , Boundary a /= i ]              ++ [ BS1 0 0 | popCount s == 1 ]     in  s' ++ concatMap shrink s' @@ -616,15 +653,15 @@     case (popCount s) of       0 -> return (BS2 s 0 0)       1 -> do i <- elements $ activeBitsL s-              return (BS2 s (Iter i) (Iter i))+              return (BS2 s (Boundary i) (Boundary i))       _ -> do i <- elements $ activeBitsL s               j <- elements $ activeBitsL (s `clearBit` i)-              return (BS2 s (Iter i) (Iter j))+              return (BS2 s (Boundary i) (Boundary j))   shrink (BS2 s i j) =     let s' = [ BS2 (s `clearBit` a) i j              | a <- activeBitsL s-             , Iter a /= i, Iter a /= j ]-             ++ [ BS2 (0 `setBit` a) (Iter a) (Iter a)+             , Boundary a /= i, Boundary a /= j ]+             ++ [ BS2 (0 `setBit` a) (Boundary a) (Boundary a)                 | popCount s == 2                 , a <- activeBitsL s ]              ++ [ BS2 0 0 0

@@ -7,7 +7,7 @@ import Control.Applicative ((<$>)) import Control.DeepSeq (NFData(..)) import Control.Monad (filterM, guard)-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Serialize (Serialize)@@ -37,16 +37,26 @@ 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 ToJSON    (Subword t)-instance Hashable  (Subword t)+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

@@ -6,7 +6,7 @@  import Control.Applicative (pure) import Control.DeepSeq (NFData(..))-import Data.Aeson (FromJSON,ToJSON)+import Data.Aeson (FromJSON,FromJSONKey,ToJSON,ToJSONKey) import Data.Binary (Binary) import Data.Hashable (Hashable) import Data.Serialize (Serialize)@@ -28,11 +28,13 @@   [| \ Unit -> ()   |]   [| \ ()   -> Unit |] -instance Binary    (Unit t)-instance Serialize (Unit t)-instance FromJSON  (Unit t)-instance ToJSON    (Unit t)-instance Hashable  (Unit t)+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 = ()

@@ -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 (Eq,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 ((Z:.0:.0),(Z:.n':._)) = bounds scoreMatrix in n' + 1+{-# Inline numRows #-}++-- | Number of columns in a score matrix.++numCols :: Unbox t => ScoreMatrix t -> Int+numCols ScoreMatrix{..} = let ((Z:.0:.0),(Z:._:.n')) = bounds scoreMatrix in n' + 1+{-# 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 (Z:.0:.0) (Z:.n-1:.n-1) 0+          $ concatMap (\(r,es) -> [ ((Z:.r:.c),e) | (c,e) <- zip [0..] es ])+          $ zip [0..] mat' -- rows+  let scoreNodes = PA.fromAssocs 0 (n-1) 0 []+  let rowNames = V.fromList . map T.pack . drop 1 . words $ head ls+  let colNames = V.fromList . map (T.pack . head . words) $ tail ls+  return $ ScoreMatrix{..} -- mat rowNames colNames (V.fromList $ replicate n 0)+

@@ -1,5 +1,5 @@ Name:           PrimitiveArray-Version:        0.7.1.0+Version:        0.8.0.0 License:        BSD3 License-file:   LICENSE Maintainer:     choener@bioinf.uni-leipzig.de@@ -49,6 +49,7 @@     Data.PrimitiveArray.FillTables     Data.PrimitiveArray.Index     Data.PrimitiveArray.Index.Class+    Data.PrimitiveArray.Index.EdgeBoundary     Data.PrimitiveArray.Index.Int     Data.PrimitiveArray.Index.IOC     Data.PrimitiveArray.Index.PhantomInt@@ -56,23 +57,26 @@     Data.PrimitiveArray.Index.Set     Data.PrimitiveArray.Index.Subword     Data.PrimitiveArray.Index.Unit+    Data.PrimitiveArray.ScoreMatrix     Data.PrimitiveArray.Vector.Compat   build-depends: base                     >= 4.7      &&  < 5.0-               , aeson                    >= 0.8      &&  < 1.1-               , binary                   >= 0.7      &&  < 0.9-               , bits                     >= 0.4      &&  < 0.6-               , cereal                   >= 0.4      &&  < 0.6-               , cereal-vector            >= 0.2      &&  < 0.3-               , deepseq                  >= 1.3      &&  < 1.5-               , hashable                 >= 1.2      &&  < 1.3-               , primitive                >= 0.5.4    &&  < 0.7-               , QuickCheck               >= 2.7      &&  < 2.9-               , smallcheck               >= 1.1      &&  < 1.2-               , vector                   >= 0.10     &&  < 0.12-               , vector-binary-instances  >= 0.2      &&  < 0.3-               , vector-th-unbox          >= 0.2      &&  < 0.3+               , aeson                    >= 0.8+               , binary                   >= 0.7+               , bits                     >= 0.4+               , cereal                   >= 0.4+               , cereal-vector            >= 0.2+               , deepseq                  >= 1.3+               , hashable                 >= 1.2+               , log-domain               >= 0.10+               , primitive                >= 0.5.4+               , QuickCheck               >= 2.7+               , smallcheck               >= 1.1+               , text                     >= 1.0+               , vector                   >= 0.10+               , vector-binary-instances  >= 0.2+               , vector-th-unbox          >= 0.2                ---               , DPutils                  == 0.0.0.*+               , DPutils                  == 0.0.1.*                , OrderedBits              == 0.0.1.*   default-extensions: BangPatterns                     , CPP@@ -85,6 +89,7 @@                     , GeneralizedNewtypeDeriving                     , MultiParamTypeClasses                     , RankNTypes+                    , RecordWildCards                     , ScopedTypeVariables                     , StandaloneDeriving                     , TemplateHaskell@@ -109,7 +114,7 @@     SmallCheck     Common   ghc-options:-    -threaded -rtsopts -with-rtsopts=-N+    -O2 -threaded -rtsopts -with-rtsopts=-N   hs-source-dirs:     tests   default-language:@@ -118,13 +123,15 @@                     , ScopedTypeVariables                     , TemplateHaskell   build-depends: base-               , PrimitiveArray+               , containers                , QuickCheck                , smallcheck                , tasty              >= 0.11                , tasty-quickcheck   >= 0.8                , tasty-smallcheck   >= 0.8                , tasty-th           >= 0.1+               --+               , PrimitiveArray   

@@ -1,3 +1,18 @@+0.8.0.0+-------++- renamed Interface (Iter) to Boundary (Boundary)+- Typeable instances for Dense primitive arrays+- EdgeBoundary index structure+- changes and fixes to quickcheck/smallcheck+- added ScoreMatrix module with simple score and distance matrix structure+  (requires log-domain)++0.7.2.0+-------++- JSONKey (To/From) for index types.+ 0.7.1.0 ------- 

@@ -1,10 +1,12 @@  module Common where -import Data.List (nub, sort, group)-import Control.Arrow ((&&&))+import           Control.Arrow ((&&&), second)+import           Data.List (nub, sort, group)+import qualified Data.Map.Strict as M+import qualified Data.Set as S -import Data.PrimitiveArray.Index.Class+import           Data.PrimitiveArray.Index.Class   -- * generic functions@@ -13,16 +15,26 @@ -- the @linearIndex@. Within each group, there should only be @PointL@s -- with the same value. -uniquenessTest :: (Ord a, Index a) => a -> [a] -> Bool+uniquenessTest :: (Ord a, Index a) => a -> a -> [a] -> Bool+uniquenessTest low hgh xs = all allEq ys && all allEq zs+  where ys  = M.fromListWith S.union . map (second S.singleton) . map (linearIndex low hgh &&& id) $ xs+        zs  = M.fromListWith S.union . map (second S.singleton) . map (id &&& linearIndex low hgh) $ xs+{-# Inlineable uniquenessTest #-}+{- uniquenessTest low xs = all allEq ys && all allEq zs   where hgh = maximum xs         ys  = group . sort . map (linearIndex low hgh &&& id) $ xs         zs  = group . sort . map (id &&& linearIndex low hgh) $ xs+-}  -- | are all @xs@ equal to each other +allEq = (1==) . S.size+{-# Inline allEq #-}++{- allEq [] = True allEq (x:xs) = all (x==) xs-+-}  

@@ -1,11 +1,14 @@  module QuickCheck where +import Data.List (maximumBy)+import Data.Ord (comparing) import Test.QuickCheck import Test.Tasty.QuickCheck import Test.Tasty.TH  import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.EdgeBoundary import Data.PrimitiveArray.Index.IOC import Data.PrimitiveArray.Index.Point import Data.PrimitiveArray.Index.Set@@ -17,9 +20,11 @@  -- * Uniqueness tests -prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) xs+prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) (maximum xs) xs -prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) xs+prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) (maximumBy (comparing fromSubwordSnd) xs) xs++prop_EdgeBoundary_I_unique (xs :: [EdgeBoundary I]) = uniquenessTest (0 :-> 0) (maximumBy (comparing fromEdgeBoundarySnd) xs) xs   

@@ -3,18 +3,20 @@  import Control.Applicative import Data.Bits-import Data.List (nub, sort, group)+import Data.List (nub, sort, group, maximumBy)+import Data.Ord (comparing) import Data.Word (Word) import Debug.Trace+import Test.SmallCheck import Test.Tasty-import Test.Tasty.TH import Test.Tasty.SmallCheck-import Test.SmallCheck+import Test.Tasty.TH +import Data.PrimitiveArray.Index.Class+import Data.PrimitiveArray.Index.EdgeBoundary import Data.PrimitiveArray.Index.IOC import Data.PrimitiveArray.Index.Point import Data.PrimitiveArray.Index.Set-import Data.PrimitiveArray.Index.Class import Data.PrimitiveArray.Index.Subword  import Common@@ -23,9 +25,11 @@  -- * Uniqueness tests. The @xs@ lists are fairly small. -prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) xs+prop_PointL_I_unique (xs :: [PointL I]) = uniquenessTest (pointLI 0) (maximum xs) xs -prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) xs+prop_Subword_I_unique (xs :: [Subword I]) = uniquenessTest (subword 0 0) (maximumBy (comparing fromSubwordSnd) xs) xs++prop_EdgeBoundary_I_unique (xs :: [EdgeBoundary I]) = uniquenessTest (0 :-> 0) (maximumBy (comparing fromEdgeBoundarySnd) xs) xs