diff --git a/comfort-array.cabal b/comfort-array.cabal --- a/comfort-array.cabal +++ b/comfort-array.cabal @@ -1,5 +1,5 @@ Name: comfort-array -Version: 0.0.1.1 +Version: 0.1 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -10,7 +10,8 @@ Description: Arrays from the basic @array@ package are already very powerful compared with arrays in other languages. - It provides arrays of any dimension in a type safe and uniform way + They may have any number of dimensions, are type safe + and defined in a uniform way using the Ix class with free choice of the lower bounds (0, 1, or whatever you like). . This package goes one step further: @@ -38,14 +39,21 @@ * @ZeroBased, OneBased@: Arrays with fixed lower bound, either 0 or 1, respectively. . + * @(:+:)@: + The Append type constructor allows to respresent block arrays, + e.g. block matrices. + . * Arrays with indices like 'LT', 'EQ', 'GT' and dummy shape. + . + The @lapack@ package defines even more fancy shapes + like tall rectangular matrices, triangular matrices and banded matrices. Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.2.2 -Cabal-Version: >=1.6 +Cabal-Version: 1.14 Build-Type: Simple Source-Repository this - Tag: 0.0.1.1 + Tag: 0.1 Type: darcs Location: http://hub.darcs.net/thielema/comfort-array/ @@ -55,12 +63,32 @@ Library Build-Depends: + guarded-allocation >=0.0 && <0.1, + QuickCheck >=2 && <3, + transformers >=0.3 && <0.6, utility-ht >=0.0.10 && <0.1, base >=4.5 && <5 GHC-Options: -Wall + Default-Language: Haskell98 Hs-Source-Dirs: src Exposed-Modules: Data.Array.Comfort.Shape + Data.Array.Comfort.Shape.Test Data.Array.Comfort.Storable Data.Array.Comfort.Storable.Internal + +Test-Suite comfort-array-test + Type: exitcode-stdio-1.0 + Build-Depends: + comfort-array, + QuickCheck, + base + + GHC-Options: -Wall + Default-Language: Haskell98 + Hs-Source-Dirs: test + Main-Is: Main.hs + Other-Modules: + Test.Shape + Test.Utility diff --git a/src/Data/Array/Comfort/Shape.hs b/src/Data/Array/Comfort/Shape.hs --- a/src/Data/Array/Comfort/Shape.hs +++ b/src/Data/Array/Comfort/Shape.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeOperators #-} module Data.Array.Comfort.Shape ( C(..), + Indexed(..), + InvIndexed(..), ZeroBased(..), OneBased(..), @@ -17,13 +19,25 @@ import qualified GHC.Arr as Ix +import qualified Control.Monad.Trans.State as MS import qualified Control.Monad.HT as Monad +import qualified Control.Applicative.Backwards as Back +import Control.Applicative (liftA2, liftA3) -import Data.Tuple.HT (mapFst, mapPair) +import Text.Printf (printf) +import Data.Tuple.HT (mapFst, mapPair, swap) + class C sh where - {-# MINIMAL indices, size, (sizeOffset|offset), inBounds #-} + -- Ix.rangeSize + size :: sh -> Int + -- Ix.unsafeRangeSize + uncheckedSize :: sh -> Int + uncheckedSize = size + +class C sh => Indexed sh where + {-# MINIMAL indices, (sizeOffset|offset), inBounds #-} type Index sh :: * -- Ix.range indices :: sh -> [Index sh] @@ -35,28 +49,43 @@ uncheckedOffset = offset -- Ix.inRange inBounds :: sh -> Index sh -> Bool - -- Ix.rangeSize - size :: sh -> Int - -- Ix.unsafeRangeSize - uncheckedSize :: sh -> Int - uncheckedSize = size sizeOffset :: sh -> Index sh -> (Int,Int) sizeOffset sh ix = (size sh, offset sh ix) uncheckedSizeOffset :: sh -> Index sh -> (Int,Int) uncheckedSizeOffset sh ix = (uncheckedSize sh, uncheckedOffset sh ix) +class Indexed sh => InvIndexed sh where + {- | + It should hold @indexFromOffset sh k == indices sh !! k@, + but 'indexFromOffset' should generally be faster. + -} + indexFromOffset :: sh -> Int -> Index sh + uncheckedIndexFromOffset :: sh -> Int -> Index sh + uncheckedIndexFromOffset = indexFromOffset +errorIndexFromOffset :: String -> Int -> a +errorIndexFromOffset name k = + error $ printf "indexFromOffset (%s): index %d out of range" name k + + instance C () where + size () = 1 + uncheckedSize () = 1 + +instance Indexed () where type Index () = () indices () = [()] offset () () = 0 uncheckedOffset () () = 0 inBounds () () = True - size () = 1 - uncheckedSize () = 1 +instance InvIndexed () where + indexFromOffset () 0 = () + indexFromOffset () k = errorIndexFromOffset "()" k + uncheckedIndexFromOffset () _ = () + {- | 'ZeroBased' denotes a range starting at zero and has a certain length. -} @@ -64,14 +93,25 @@ deriving (Eq, Show) instance (Integral n) => C (ZeroBased n) where + size (ZeroBased len) = fromIntegral len + uncheckedSize (ZeroBased len) = fromIntegral len + +instance (Integral n) => Indexed (ZeroBased n) where type Index (ZeroBased n) = n indices (ZeroBased len) = indices $ Shifted 0 len offset (ZeroBased len) = offset $ Shifted 0 len uncheckedOffset _ ix = fromIntegral ix inBounds (ZeroBased len) ix = 0<=ix && ix InvIndexed (ZeroBased n) where + indexFromOffset (ZeroBased len) k0 = + let k = fromIntegral k0 + in if 0<=k && k C (OneBased n) where + size (OneBased len) = fromIntegral len + uncheckedSize (OneBased len) = fromIntegral len + +instance (Integral n) => Indexed (OneBased n) where type Index (OneBased n) = n indices (OneBased len) = indices $ Shifted 1 len offset (OneBased len) = offset $ Shifted 1 len uncheckedOffset _ ix = fromIntegral ix - 1 inBounds (OneBased len) ix = 0 InvIndexed (OneBased n) where + indexFromOffset (OneBased len) k0 = + let k = fromIntegral k0 + in if 0<=k && k C (Range n) where + size (Range from to) = Ix.rangeSize (from,to) + uncheckedSize (Range from to) = Ix.unsafeRangeSize (from,to) + +instance (Ix.Ix n) => Indexed (Range n) where type Index (Range n) = n indices (Range from to) = Ix.range (from,to) offset (Range from to) ix = Ix.index (from,to) ix uncheckedOffset (Range from to) ix = Ix.unsafeIndex (from,to) ix inBounds (Range from to) ix = Ix.inRange (from,to) ix - size (Range from to) = Ix.rangeSize (from,to) - uncheckedSize (Range from to) = Ix.unsafeRangeSize (from,to) +-- pretty inefficient when we rely solely on Ix +instance (Ix.Ix n) => InvIndexed (Range n) where + indexFromOffset (Range from to) k = + if 0<=k && k < Ix.rangeSize (from,to) + then Ix.range (from,to) !! k + else errorIndexFromOffset "Range" k + uncheckedIndexFromOffset (Range from to) k = Ix.range (from,to) !! k + -- cf. sample-frame:Stereo instance Storable n => Storable (Range n) where {-# INLINE sizeOf #-} @@ -129,6 +189,10 @@ deriving (Eq, Show) instance (Integral n) => C (Shifted n) where + size (Shifted _offs len) = fromIntegral len + uncheckedSize (Shifted _offs len) = fromIntegral len + +instance (Integral n) => Indexed (Shifted n) where type Index (Shifted n) = n indices (Shifted offs len) = map snd $ @@ -146,9 +210,15 @@ else error "Shape.Shifted: array index too big" uncheckedOffset (Shifted offs _len) ix = fromIntegral $ ix-offs inBounds (Shifted offs len) ix = ix < offs+len - size (Shifted _offs len) = fromIntegral len - uncheckedSize (Shifted _offs len) = fromIntegral len +instance (Integral n) => InvIndexed (Shifted n) where + indexFromOffset (Shifted offs len) k0 = + let k = fromIntegral k0 + in if 0<=k && k Storable (Shifted n) where {-# INLINE sizeOf #-} @@ -175,6 +245,10 @@ Row-major composition of two dimensions. -} instance (C sh0, C sh1) => C (sh0,sh1) where + size (sh0,sh1) = size sh0 * size sh1 + uncheckedSize (sh0,sh1) = uncheckedSize sh0 * uncheckedSize sh1 + +instance (Indexed sh0, Indexed sh1) => Indexed (sh0,sh1) where type Index (sh0,sh1) = (Index sh0, Index sh1) indices (sh0,sh1) = Monad.lift2 (,) (indices sh0) (indices sh1) offset (sh0,sh1) (ix0,ix1) = @@ -188,10 +262,20 @@ `combineSizeOffset` uncheckedSizeOffset sh1 ix1 inBounds (sh0,sh1) (ix0,ix1) = inBounds sh0 ix0 && inBounds sh1 ix1 - size (sh0,sh1) = size sh0 * size sh1 - uncheckedSize (sh0,sh1) = uncheckedSize sh0 * uncheckedSize sh1 +instance (InvIndexed sh0, InvIndexed sh1) => InvIndexed (sh0,sh1) where + indexFromOffset (sh0,sh1) k = + runInvIndex k $ liftA2 (,) (pickLastIndex sh0) (pickIndex sh1) + uncheckedIndexFromOffset (sh0,sh1) k = + runInvIndex k $ liftA2 (,) (uncheckedPickLastIndex sh0) (pickIndex sh1) + + instance (C sh0, C sh1, C sh2) => C (sh0,sh1,sh2) where + size (sh0,sh1,sh2) = size sh0 * size sh1 * size sh2 + uncheckedSize (sh0,sh1,sh2) = + uncheckedSize sh0 * uncheckedSize sh1 * uncheckedSize sh2 + +instance (Indexed sh0, Indexed sh1, Indexed sh2) => Indexed (sh0,sh1,sh2) where type Index (sh0,sh1,sh2) = (Index sh0, Index sh1, Index sh2) indices (sh0,sh1,sh2) = Monad.lift3 (,,) (indices sh0) (indices sh1) (indices sh2) @@ -215,11 +299,37 @@ uncheckedSizeOffset sh2 ix2 inBounds (sh0,sh1,sh2) (ix0,ix1,ix2) = inBounds sh0 ix0 && inBounds sh1 ix1 && inBounds sh2 ix2 - size (sh0,sh1,sh2) = size sh0 * size sh1 * size sh2 - uncheckedSize (sh0,sh1,sh2) = - uncheckedSize sh0 * uncheckedSize sh1 * uncheckedSize sh2 +instance + (InvIndexed sh0, InvIndexed sh1, InvIndexed sh2) => + InvIndexed (sh0,sh1,sh2) where + indexFromOffset (sh0,sh1,sh2) k = + runInvIndex k $ + liftA3 (,,) (pickLastIndex sh0) (pickIndex sh1) (pickIndex sh2) + uncheckedIndexFromOffset (sh0,sh1,sh2) k = + runInvIndex k $ + liftA3 (,,) (uncheckedPickLastIndex sh0) (pickIndex sh1) (pickIndex sh2) +runInvIndex :: s -> Back.Backwards (MS.State s) a -> a +runInvIndex k = flip MS.evalState k . Back.forwards + +pickLastIndex :: + (InvIndexed sh) => sh -> Back.Backwards (MS.State Int) (Index sh) +pickLastIndex sh = + Back.Backwards $ MS.gets $ indexFromOffset sh + +uncheckedPickLastIndex :: + (InvIndexed sh) => sh -> Back.Backwards (MS.State Int) (Index sh) +uncheckedPickLastIndex sh = + Back.Backwards $ MS.gets $ uncheckedIndexFromOffset sh + +pickIndex :: (InvIndexed sh) => sh -> Back.Backwards (MS.State Int) (Index sh) +pickIndex sh = + fmap (uncheckedIndexFromOffset sh) $ + Back.Backwards $ MS.state $ \k -> swap $ divMod k $ size sh + + + infixr 7 `combineOffset`, `combineSizeOffset` {-# INLINE combineOffset #-} @@ -239,6 +349,10 @@ deriving (Eq, Show) instance (C sh0, C sh1) => C (sh0:+:sh1) where + size (sh0:+:sh1) = size sh0 + size sh1 + uncheckedSize (sh0:+:sh1) = uncheckedSize sh0 + uncheckedSize sh1 + +instance (Indexed sh0, Indexed sh1) => Indexed (sh0:+:sh1) where type Index (sh0:+:sh1) = Either (Index sh0) (Index sh1) indices (sh0:+:sh1) = map Left (indices sh0) ++ map Right (indices sh1) offset (sh0:+:sh1) ix = @@ -261,9 +375,16 @@ Right ix1 -> let size0 = uncheckedSize sh0 in mapPair ((size0+), (size0+)) $ uncheckedSizeOffset sh1 ix1 - inBounds (sh0:+:sh1) ix = - case ix of - Left ix0 -> inBounds sh0 ix0 - Right ix1 -> inBounds sh1 ix1 - size (sh0:+:sh1) = size sh0 + size sh1 - uncheckedSize (sh0:+:sh1) = uncheckedSize sh0 + uncheckedSize sh1 + inBounds (sh0:+:sh1) = either (inBounds sh0) (inBounds sh1) + +instance (InvIndexed sh0, InvIndexed sh1) => InvIndexed (sh0:+:sh1) where + indexFromOffset (sh0:+:sh1) k = + let pivot = size sh0 + in if k < pivot + then Left $ indexFromOffset sh0 k + else Right $ indexFromOffset sh1 $ k-pivot + uncheckedIndexFromOffset (sh0:+:sh1) k = + let pivot = size sh0 + in if k < pivot + then Left $ uncheckedIndexFromOffset sh0 k + else Right $ uncheckedIndexFromOffset sh1 $ k-pivot diff --git a/src/Data/Array/Comfort/Shape/Test.hs b/src/Data/Array/Comfort/Shape/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Shape/Test.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.Array.Comfort.Shape.Test (tests) where + +import qualified Data.Array.Comfort.Shape as Shape + +import qualified Test.QuickCheck as QC + + +uncheckedSize :: (Shape.C sh) => sh -> Bool +uncheckedSize sh = Shape.size sh == Shape.uncheckedSize sh + +inBounds :: (Shape.Indexed sh) => sh -> Bool +inBounds sh = all (Shape.inBounds sh) $ Shape.indices sh + + +forAllIndices :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix, QC.Testable prop) => + sh -> (ix -> prop) -> QC.Property +forAllIndices sh f = + let ixs = Shape.indices sh + in not (null ixs) QC.==> QC.forAll (QC.elements ixs) f + +sizeOffset :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property +sizeOffset sh = + forAllIndices sh $ \ix -> + Shape.sizeOffset sh ix == (Shape.size sh, Shape.offset sh ix) + +uncheckedSizeOffset :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property +uncheckedSizeOffset sh = + forAllIndices sh $ \ix -> + Shape.uncheckedSizeOffset sh ix == + (Shape.uncheckedSize sh, Shape.uncheckedOffset sh ix) + +uncheckedOffset :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property +uncheckedOffset sh = + forAllIndices sh $ \ix -> + Shape.offset sh ix == Shape.uncheckedOffset sh ix + +lengthIndices :: (Shape.Indexed sh) => sh -> Bool +lengthIndices sh = length (Shape.indices sh) == Shape.size sh + +indexOffsets :: (Shape.Indexed sh) => sh -> Bool +indexOffsets sh = + map (Shape.offset sh) (Shape.indices sh) == take (Shape.size sh) [0..] + +invIndices :: (Shape.InvIndexed sh, Shape.Index sh ~ ix, Eq ix) => sh -> Bool +invIndices sh = + Shape.indices sh == + map (Shape.indexFromOffset sh) (take (Shape.size sh) [0..]) + +uncheckedInvIndices :: + (Shape.InvIndexed sh, Shape.Index sh ~ ix, Eq ix) => sh -> Bool +uncheckedInvIndices sh = + Shape.indices sh == + map (Shape.uncheckedIndexFromOffset sh) (take (Shape.size sh) [0..]) + + +tests :: + (Shape.InvIndexed sh, Show sh, Shape.Index sh ~ ix, Eq ix, Show ix) => + QC.Gen sh -> [(String, QC.Property)] +tests gen = + ("uncheckedSize", QC.forAll gen uncheckedSize) : + ("inBounds", QC.forAll gen inBounds) : + ("sizeOffset", QC.forAll gen sizeOffset) : + ("uncheckedSizeOffset", QC.forAll gen uncheckedSizeOffset) : + ("uncheckedOffset", QC.forAll gen uncheckedOffset) : + ("lengthIndices", QC.forAll gen lengthIndices) : + ("indexOffsets", QC.forAll gen indexOffsets) : + ("invIndices", QC.forAll gen invIndices) : + ("uncheckedInvIndices", QC.forAll gen uncheckedInvIndices) : + [] diff --git a/src/Data/Array/Comfort/Storable/Internal.hs b/src/Data/Array/Comfort/Storable/Internal.hs --- a/src/Data/Array/Comfort/Storable/Internal.hs +++ b/src/Data/Array/Comfort/Storable/Internal.hs @@ -7,6 +7,7 @@ (!), unsafeCreate, unsafeCreateWithSize, + unsafeCreateWithSizeAndResult, toList, fromList, vectorFromList, @@ -15,6 +16,7 @@ createIO, createWithSizeIO, + createWithSizeAndResultIO, showIO, readIO, toListIO, @@ -24,13 +26,18 @@ import qualified Data.Array.Comfort.Shape as Shape +import qualified Foreign.Marshal.Array.Guarded as Alloc import Foreign.Marshal.Array (pokeArray, peekArray, advancePtr, ) import Foreign.Storable (Storable, poke, peek, peekElemOff, ) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, ) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, ) import Foreign.Ptr (Ptr, ) import System.IO.Unsafe (unsafePerformIO, ) +import Control.Applicative ((<$>)) + +import Data.Tuple.HT (mapFst) + import Prelude hiding (map, readIO, ) @@ -60,7 +67,12 @@ (Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO ()) -> Array sh a unsafeCreateWithSize sh = unsafePerformIO . createWithSizeIO sh -(!) :: (Shape.C sh, Storable a) => Array sh a -> Shape.Index sh -> a +unsafeCreateWithSizeAndResult :: + (Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO b) -> (Array sh a, b) +unsafeCreateWithSizeAndResult sh = + unsafePerformIO . createWithSizeAndResultIO sh + +(!) :: (Shape.Indexed sh, Storable a) => Array sh a -> Shape.Index sh -> a (!) arr = unsafePerformIO . readIO arr toList :: (Shape.C sh, Storable a) => Array sh a -> [a] @@ -92,18 +104,22 @@ createWithSizeIO :: (Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO ()) -> IO (Array sh a) -createWithSizeIO sh f = do +createWithSizeIO sh f = + fst <$> createWithSizeAndResultIO sh f + +createWithSizeAndResultIO :: + (Shape.C sh, Storable a) => + sh -> (Int -> Ptr a -> IO b) -> IO (Array sh a, b) +createWithSizeAndResultIO sh f = let size = Shape.size sh - fptr <- mallocForeignPtrArray size - withForeignPtr fptr $ f size - return $ Array sh fptr + in fmap (mapFst (Array sh)) $ Alloc.create size $ f size showIO :: (Shape.C sh, Show sh, Storable a, Show a) => Array sh a -> IO String showIO arr = do xs <- toListIO arr return $ "fromList " ++ showsPrec 11 (shape arr) (' ' : show xs) -readIO :: (Shape.C sh, Storable a) => Array sh a -> Shape.Index sh -> IO a +readIO :: (Shape.Indexed sh, Storable a) => Array sh a -> Shape.Index sh -> IO a readIO (Array sh fptr) ix = withForeignPtr fptr $ flip peekElemOff (Shape.offset sh ix) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeFamilies #-} +module Main where + +import qualified Test.Shape as TestShape +import Test.Utility (prefix) + +import qualified Test.QuickCheck as QC + + +main :: IO () +main = + mapM_ (\(name,prop) -> putStr (name ++ ": ") >> QC.quickCheck prop) $ + prefix "Shape" TestShape.tests ++ + [] diff --git a/test/Test/Shape.hs b/test/Test/Shape.hs new file mode 100644 --- /dev/null +++ b/test/Test/Shape.hs @@ -0,0 +1,38 @@ +module Test.Shape where + +import qualified Data.Array.Comfort.Shape.Test as ShapeTest +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((:+:)((:+:))) + +import qualified Test.QuickCheck as QC +import Test.Utility (prefix) + +import Control.Applicative (liftA2, liftA3) + + +genZeroBased :: Int -> QC.Gen (Shape.ZeroBased Int) +genZeroBased n = fmap Shape.ZeroBased $ QC.choose (0,n) + +tests :: [(String, QC.Property)] +tests = + prefix "ZeroBased" + (ShapeTest.tests $ genZeroBased 10) ++ + prefix "OneBased" + (ShapeTest.tests $ fmap Shape.OneBased $ QC.choose (0,10::Int)) ++ + prefix "Range" + (ShapeTest.tests $ do + from <- QC.choose (0,10::Int) + to <- QC.choose (from-1, 10) + return $ Shape.Range from to) ++ + prefix "Shifted" + (ShapeTest.tests $ + liftA2 Shape.Shifted + (QC.choose (-10,10::Int)) (QC.choose (0,10::Int))) ++ + prefix "Pair" + (ShapeTest.tests $ liftA2 (,) (genZeroBased 10) (genZeroBased 10)) ++ + prefix "Triple" + (ShapeTest.tests $ + liftA3 (,,) (genZeroBased 10) (genZeroBased 10) (genZeroBased 10)) ++ + prefix "Append" + (ShapeTest.tests $ liftA2 (:+:) (genZeroBased 10) (genZeroBased 10)) ++ + [] diff --git a/test/Test/Utility.hs b/test/Test/Utility.hs new file mode 100644 --- /dev/null +++ b/test/Test/Utility.hs @@ -0,0 +1,5 @@ +module Test.Utility where + +prefix :: String -> [(String, test)] -> [(String, test)] +prefix msg = + map (\(str,test) -> (msg ++ "." ++ str, test))