packages feed

PrimitiveArray 0.5.0.0 → 0.5.2.0

raw patch · 6 files changed

+412/−25 lines, 6 files

Files

+ Data/Array/Repa/Index/Outside.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++-- | 'Outside' covers subwords for outside calculations. These types of+-- calculations requires quite "weird" index movements if you want to stay with+-- usual grammars. This remains true if grammars are transformed to Chomsky+-- normal form, only that in said form it is easier to write down the+-- recursions.+--+-- TODO basically untested!++module Data.Array.Repa.Index.Outside where++import Control.Applicative+import Control.DeepSeq+import Data.Array.Repa.Index+import Data.Array.Repa.Shape+import GHC.Base (quotInt, remInt)+import Test.QuickCheck+import Test.QuickCheck.All+import qualified Data.Vector.Unboxed as VU+import Data.Vector.Unboxed.Deriving++import Data.Array.Repa.ExtShape+import Data.Array.Repa.Index.Subword hiding (upperTri, subwordIndex, subwordFromIndex)+import qualified Data.Array.Repa.Index.Subword as SW++++stage = "Data.Array.Repa.Index.Outside"++-- | 'Outside' inverts the usual subword (i,j) system.+--+-- TODO do I need to store N ?++newtype Outside = Outside (Int:.Int)+  deriving (Eq,Ord,Show)++derivingUnbox "Outside"+  [t| Outside -> (Int,Int) |]+  [| \ (Outside (i:.j)) -> (i,j) |]+  [| \ (i,j) -> Outside (i:.j) |]++outside :: Int -> Int -> Outside+outside i j = Outside (i:.j)+{-# INLINE outside #-}++-- | Size of an upper triangle starting at 'i' and ending at 'j'. "(0,N)" what+-- be the normal thing to use. Internally, we stell upper triangular matrices.++upperTri :: Outside -> Int+upperTri (Outside (i:.j)) = triangularNumber $ j-i+{-# INLINE upperTri #-}++-- | Outside indexing. Given the longest subword and the current subword,+-- calculate a linear index "[0,..]". "(l,n)" in this case means "l"ower bound,+-- length "n". And "(i,j)" is the normal index.+--+-- TODO probably doesn't work right with non-zero base ?!++subwordIndex :: Outside -> Outside -> Int+subwordIndex (Outside (l:.n)) (Outside (i:.j)) = adr n (i,j) -- - adr n (l,n)+  where+    adr n (i,j) = n*i - triangularNumber i + j+{-# INLINE subwordIndex #-}++subwordFromIndex :: Outside -> Int -> Outside+subwordFromIndex = error "not implemented"+{-# INLINE subwordFromIndex #-}++++-- | Some weird things are going on here. Adding subwords (i,j) and (k,l)+-- yields (i+k,j+l). Normally i==k==0 when calculating space requirements. If+-- you have a subword (3,10) and want the next outer one add (-1,1) and you get+-- what you want. We make NO(!) check that the final subword contains only+-- non-negative indices.++instance Shape sh => Shape (sh :. Outside) where+  {-# INLINE [1] rank #-}+  rank   (sh  :. _)+    = rank sh + 1+  {-# INLINE [1] zeroDim #-}+  zeroDim = zeroDim :. Outside (0:.0)++  {-# INLINE [1] unitDim #-}+  unitDim = unitDim :. Outside (0:.1)++  {-# INLINE [1] intersectDim #-}+  intersectDim (sh1 :. Outside (i:.j)) (sh2 :. Outside (k:.l))+    = (intersectDim sh1 sh2 :. Outside (max i k :. min j l))++  {-# INLINE [1] addDim #-}+  addDim (sh1 :. Outside (i:.j)) (sh2 :. Outside (k:.l))+    = addDim sh1 sh2 :. Outside (i+k:.j+l)++  {-# INLINE [1] size #-}+  size  (sh1 :. sw) = size sh1 * upperTri sw++  {-# INLINE [1] sizeIsValid #-}+  sizeIsValid (sh1 :. Outside (i:.j))+    | size sh1 > 0+    = i>=0 && i<=j && j <= maxBound `div` size sh1+    | otherwise+    = False++  {-# INLINE [1] toIndex #-}+  toIndex (sh1 :. sh2) (sh1' :. sh2')+    = toIndex sh1 sh1' * upperTri sh2 + subwordIndex sh2 sh2'++  {-# INLINE [1] fromIndex #-}+  fromIndex (ds :. d) n  = undefined -- fromIndex ds (n `quotInt` d) :. r+    where+      r = subwordFromIndex d n+    -- If we assume that the index is in range, there is no point+    -- in computing the remainder for the highest dimension since+    -- n < d must hold. This saves one remInt per element access which+    -- is quite a big deal.+    {-+    r       | rank ds == 0  = n+            | otherwise     = n `remInt` d -}++  -- | TODO fix for lower bounds check!+  {-# INLINE [1] inShapeRange #-}+  inShapeRange (zs :. Outside (_:._)) (sh1 :. Outside (l:.n)) (sh2 :. Outside (i:.j))+    = i<=j && l<=i && j<n && (inShapeRange zs sh1 sh2)++  {-# NOINLINE listOfShape #-}+  listOfShape (sh :. Outside (i:.j)) = i : j : listOfShape sh++  {-# NOINLINE shapeOfList #-}+  shapeOfList xx+   = case xx of+    []     -> error $ stage ++ ".toList: empty list when converting to  (_ :. Int)"+    [x]    -> error $ stage ++ ".toList: only single element remaining!"+    i:j:xs -> shapeOfList xs :. Outside (i:.j)++  {-# INLINE deepSeq #-}+  deepSeq (sh :. n) x = deepSeq sh (n `seq` x)++-- |++instance ExtShape sh => ExtShape (sh:.Outside) where+  subDim (sh1:.Outside (i:.j)) (sh2:.Outside (k:.l)) = subDim sh1 sh2 :. Outside (i-k:.j-l)+  {-# INLINE subDim #-}+  rangeList (sh1:.Outside (i:.j)) (sh2:.Outside (k:.l)) = error "not implemented" -- [sh:.Outside (m,n) | sh <- rangeList sh1 sh2, m <- [i .. [i+k], n <- [ n <- [n1 .. (n1+n2) ] ]+  {-# INLINE rangeList #-}++-- |++instance NFData Outside where+  rnf (Outside (i:.j)) = i `seq` rnf j++-- |++instance Arbitrary Outside where+  arbitrary = do+    a <- choose (0,100)+    b <- choose (0,100)+    return $ Outside (min a b :. max a b)+  shrink (Outside (i:.j))+    | i<j       = [Outside (i:.j-1)]+    | otherwise = []++instance Arbitrary z => Arbitrary (z:.Outside) where+  arbitrary = (:.) <$> arbitrary <*> arbitrary+  shrink (z:.s) = (:.) <$> shrink z <*> shrink s+
+ Data/Array/Repa/Index/Points.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++-- | Index structures for left- and right-linear grammars. Do not use this+-- index for general linear- or context-free grammars.+--+-- Internally, both 'PointL' and 'PointR' work a lot like 'Subword's, but in+-- non-terminals we only store the left- or right part.++module Data.Array.Repa.Index.Points where++import Control.Applicative+import Control.DeepSeq+import Data.Array.Repa.Index+import Data.Array.Repa.Shape+import Data.Vector.Unboxed.Deriving+import GHC.Base (quotInt, remInt)+import qualified Data.Vector.Unboxed as VU+import Test.QuickCheck+import Test.QuickCheck.All++import Data.Array.Repa.ExtShape+import Data.Array.Repa.Index.Subword++++-- | A point in left-linear grammars. In @(i:.j)@, @j@ is the non-terminal+-- storage point, @i==0@ always for the non-terminal, while @i>=0@ for+-- terminals, which are on the right of the non-terminal. (This is why+-- left-linear grammars are called left-linear: they recurse on the left).+--+-- PS: all this left/right talk deals with the RHS of a production rule, the+-- LHS is always a non-terminal ;-)++newtype PointL = PointL (Int:.Int)+  deriving (Eq,Read,Show)++pointL :: Int -> Int -> PointL+pointL i j = PointL (i:.j)+{-# INLINE pointL #-}++-- | A point in right-linear grammars.++newtype PointR = PointR (Int:.Int)++pointR :: Int -> Int -> PointR+pointR i j = PointR (i:.j)+{-# INLINE pointR #-}++++-- * Instances++derivingUnbox "PointL"+  [t| PointL -> (Int,Int) |]+  [| \ (PointL (i:.j)) -> (i,j) |]+  [| \ (i,j) -> PointL (i:.j) |]++derivingUnbox "PointR"+  [t| PointR -> (Int,Int) |]+  [| \ (PointR (i:.j)) -> (i,j) |]+  [| \ (i,j) -> PointR (i:.j) |]++instance Shape sh => Shape (sh :. PointL) where+  {-# INLINE [1] rank #-}+  rank   (sh  :. _)+    = rank sh + 1++  {-# INLINE [1] zeroDim #-}+  zeroDim = zeroDim :. PointL (0:.0)++  {-# INLINE [1] unitDim #-}+  unitDim = unitDim :. PointL (0:.1)++  {-# INLINE [1] intersectDim #-}+  intersectDim (sh1 :. PointL (i:.j)) (sh2 :. PointL (k:.l))+    = (intersectDim sh1 sh2 :. PointL (max i k :. min j l))++  {-# INLINE [1] addDim #-}+  addDim (sh1 :. PointL (i:.j)) (sh2 :. PointL (k:.l))+    = addDim sh1 sh2 :. PointL (i+k:.j+l)++  -- NOTE size is calculated NOT as upper-triangular, but linear!+  {-# INLINE [1] size #-}+  size  (sh1 :. PointL (i:.j)) = size sh1 * (j-i)++  {-# INLINE [1] sizeIsValid #-}+  sizeIsValid (sh1 :. PointL (i:.j))+    | size sh1 > 0+    = i>=0 && i<=j && j <= maxBound `div` size sh1+    | otherwise+    = False++  -- NOTE only the @j@ coordinate is used for indexing NTs, @i@ is just for+  -- convenience. @l@ however restricts the NT to some value @>0@ if desired.+  {-# INLINE [1] toIndex #-}+  toIndex (sh1 :. PointL(l:.r)) (sh1' :. PointL(i:.j))+    = toIndex sh1 sh1' * (r-l) + (j-l)++  {-# INLINE [1] fromIndex #-}+  fromIndex (ds :. d) n  = undefined -- fromIndex ds (n `quotInt` d) :. r+    where+      r = undefined++  -- | TODO fix for lower bounds check!+  {-# INLINE [1] inShapeRange #-}+  inShapeRange (zs :. PointL (_:._)) (sh1 :. PointL (l:.n)) (sh2 :. PointL (i:.j))+    = i<=j && l<=i && j<n && (inShapeRange zs sh1 sh2)++  {-# NOINLINE listOfShape #-}+  listOfShape (sh :. PointL (i:.j)) = i : j : listOfShape sh++  {-# NOINLINE shapeOfList #-}+  shapeOfList xx+   = case xx of+    []     -> error $ stage ++ ".toList: empty list when converting to  (_ :. Int)"+    [x]    -> error $ stage ++ ".toList: only single element remaining!"+    i:j:xs -> shapeOfList xs :. PointL (i:.j)++  {-# INLINE deepSeq #-}+  deepSeq (sh :. n) x = deepSeq sh (n `seq` x)++instance ExtShape sh => ExtShape (sh:.PointL) where+  {-# INLINE [1] subDim #-}+  subDim (sh1:.PointL (i:.j)) (sh2:.PointL (k:.l)) = subDim sh1 sh2 :. PointL (i-k:.j-l)+  {-# INLINE [1] rangeList #-}+  rangeList _ _ = error "PointL:rangeList not implemented"++instance NFData PointL where+  rnf (PointL (i:.j)) = i `seq` rnf j+  {-# INLINE rnf #-}++-- TODO maybe vary the left border, too? Since this invalidates that @i==0@ in+-- @PointL (i:.j)@, we would need to make sure that the memoizers for NTs get+-- notified ...++instance Arbitrary PointL where+  arbitrary = do+    b <- choose (0,100)+    return $ pointL 0 b+  shrink (PointL (i:.j))+    | i<j = [pointL i $ j-1]+    | otherwise = []++instance Arbitrary z => Arbitrary (z:.PointL) where+  arbitrary = (:.) <$> arbitrary <*> arbitrary+  shrink (z:.s) = (:.) <$> shrink z <*> shrink s+
Data/PrimitiveArray/FillTables.hs view
@@ -21,6 +21,8 @@   +-- * Driver classes for table filling system.+ -- Upper triangular table filling. Right now, only a serial option 'upperTriS' -- is available. --@@ -29,18 +31,28 @@ class UpperTriS m stack where   upperTriS :: stack -> m () --- |---+-- | Defines how a single index in a stack of arrays + evaluation functions is+-- handled. The instances *should* work for any index @ix@.++class Stack m sh xs where+  writeStack :: xs -> sh -> m ()++++-- * Instances++-- ** 1-tape grammars with 'Subword' indices.+ -- TODO Insert check that all extends are the same!  instance   ( Monad m-  , MPrimArrayOps arr Subword e-  , Stack m Subword (xs:.MutArr m (arr Subword e))-  ) => UpperTriS m (xs:.MutArr m (arr Subword e)) where-  upperTriS xs@(_:.x) = do+  , MPrimArrayOps arr (Z:.Subword) e+  , Stack m Subword (xs :. SubwordNonTerminal m arr e)+  ) => UpperTriS m  (xs :. SubwordNonTerminal m arr e) where+  upperTriS xs@(_:.(x,f)) = do     -- TODO missing extends check-    let (Subword (l:._),Subword (u:._)) = boundsM x+    let (Z:.Subword (l:._),Z:.Subword (u:._)) = boundsM x     S.mapM_ (go xs) $ unfolder l u     where       -- Write all table values at a certain subword. Note that tables are@@ -60,13 +72,15 @@       {-# INLINE unfolder #-}   {-# INLINE upperTriS #-} ----- | Defines how a single index in a stack of arrays + evaluation functions is--- handled.+instance+  ( PrimMonad m+  , Stack m Subword xs+  , MPrimArrayOps arr (Z:.Subword) e+  ) => Stack m Subword (xs :. SubwordNonTerminal m arr e) where+  writeStack (xs:.(x,f)) i = writeStack xs i >> f i >>= writeM x (Z:.i)+  {-# INLINE writeStack #-} -class Stack m sh xs where-  writeStack :: xs -> sh -> m ()+-- ** Multi-tape indices.  instance (Monad m) => Stack m sh Z where   writeStack _ _ = return ()@@ -74,9 +88,16 @@  instance   ( PrimMonad m-  , Stack m Subword xs-  , MPrimArrayOps arr Subword e-  ) => Stack m Subword (xs:.(MutArr m (arr Subword e),(Subword -> m e))) where+  , Stack m ix xs+  , MPrimArrayOps arr ix e+  ) => Stack m ix (xs :. GeneralNonTerminal m arr ix e) where   writeStack (xs:.(x,f)) i = writeStack xs i >> f i >>= writeM x i   {-# INLINE writeStack #-}++++-- Wrap non-terminal symbol type, corresponding rule type.++type SubwordNonTerminal m arr e = (MutArr m (arr (Z:.Subword) e), Subword -> m e)+type GeneralNonTerminal m arr ix e = (MutArr m (arr ix e), ix -> m e)
+ Data/PrimitiveArray/QuickCheck.hs view
@@ -0,0 +1,5 @@++module Data.PrimitiveArray.QuickCheck where+++
Data/PrimitiveArray/Zero.hs view
@@ -41,7 +41,7 @@     ma <- newM inLb inUb     let exUb = inUb `addDim` unitDim     let (MUnboxed _ mba) = ma-    zipWithM_ (\k x -> assert (length xs == size exUb) $ unsafeWrite mba k x) [0.. toIndex exUb inUb] xs+    zipWithM_ (\k x -> assert (length xs == size exUb) $ unsafeWrite mba k x) [0.. size exUb -1] xs     return ma   newM inLb inUb = let exUb = inUb `addDim` unitDim in     unless (inLb == zeroDim) (error "MArr0 lb/=zeroDim") >>@@ -50,7 +50,7 @@     let exUb = inUb `addDim` unitDim     ma <- newM inLb inUb     let (MUnboxed _ mba) = ma-    forM_ [0 .. toIndex exUb inUb] $ \k -> unsafeWrite mba k def+    forM_ [0 .. size exUb -1] $ \k -> unsafeWrite mba k def     return ma   readM (MUnboxed exUb mba) idx = assert (inShape exUb idx) $ unsafeRead mba (toIndex exUb idx)   writeM (MUnboxed exUb mba) idx elm = assert (inShape exUb idx) $ unsafeWrite mba (toIndex exUb idx) elm@@ -77,7 +77,48 @@  -- * Boxed, multidimensional arrays. --- data Boxed sh e = Boxed !sh !(V.Vector e)+data Boxed sh e = Boxed !sh !(V.Vector e)+  deriving (Read,Show,Eq)++data instance MutArr m (Boxed sh e) = MBoxed !sh (V.MVector (PrimState m) e)++instance (Shape sh, ExtShape sh, VUM.Unbox elm) => MPrimArrayOps Boxed sh elm where+  boundsM (MBoxed exUb _) = (zeroDim,exUb `subDim` unitDim)+  fromListM inLb inUb xs = do+    ma <- newM inLb inUb+    let exUb = inUb `addDim` unitDim+    let (MBoxed _ mba) = ma+    zipWithM_ (\k x -> assert (length xs == size exUb) $ unsafeWrite mba k x) [0 .. size exUb - 1] xs -- [0.. toIndex exUb inUb] xs+    return ma+  newM inLb inUb = let exUb = inUb `addDim` unitDim in+    unless (inLb == zeroDim) (error "MArr0 lb/=zeroDim") >>+    MBoxed exUb `liftM` new (size exUb)+  newWithM inLb inUb def = do+    let exUb = inUb `addDim` unitDim+    ma <- newM inLb inUb+    let (MBoxed _ mba) = ma+    forM_ [0 .. size exUb -1] $ \k -> unsafeWrite mba k def+    return ma+  readM (MBoxed exUb mba) idx = assert (inShape exUb idx) $ unsafeRead mba (toIndex exUb idx)+  writeM (MBoxed exUb mba) idx elm = assert (inShape exUb idx) $ unsafeWrite mba (toIndex exUb idx) elm+  {-# INLINE boundsM #-}+  {-# INLINE fromListM #-}+  {-# INLINE newM #-}+  {-# INLINE newWithM #-}+  {-# INLINE readM #-}+  {-# INLINE writeM #-}++instance (Shape sh, ExtShape sh, VUM.Unbox elm) => PrimArrayOps Boxed sh elm where+  bounds (Boxed exUb _) = (zeroDim,exUb `subDim` unitDim)+  freeze (MBoxed exUb mba) = Boxed exUb `liftM` unsafeFreeze mba+  index (Boxed exUb ba) idx = assert (inShape exUb idx) $ unsafeIndex ba (toIndex exUb idx)+  {-# INLINE bounds #-}+  {-# INLINE freeze #-}+  {-# INLINE index #-}++instance (Shape sh, ExtShape sh) => PrimArrayMap Boxed sh e e' where+  map f (Boxed sh xs) = Boxed sh (V.map f xs)+  {-# INLINE map #-}   {-
PrimitiveArray.cabal view
@@ -1,5 +1,5 @@ Name:           PrimitiveArray-Version:        0.5.0.0+Version:        0.5.2.0 License:        BSD3 License-file:   LICENSE Author:         Christian Hoener zu Siederdissen@@ -18,19 +18,17 @@                 In general all operations are (highly) unsafe, no                 bounds-checking or other sanity-checking is performed.                 Operations are aimed toward efficiency as much as possible.-                Goals of the library are to have arrays according to three-                ideas: immutable/mutable arrays, strict/lazy arrays,-                zero-based/lower-bound arrays. Zero-based arrays save one-                addition on each access if the lower bound or the array is-                always zero.  Library   Exposed-modules:     Data.Array.Repa.ExtShape+    Data.Array.Repa.Index.Outside     Data.Array.Repa.Index.Point+    Data.Array.Repa.Index.Points     Data.Array.Repa.Index.Subword     Data.PrimitiveArray     Data.PrimitiveArray.FillTables+    Data.PrimitiveArray.QuickCheck     Data.PrimitiveArray.Zero   Build-depends:     base            >= 4 && <5  ,