packages feed

comfort-array (empty) → 0.0

raw patch · 6 files changed

+505/−0 lines, 6 filesdep +basedep +utility-htsetup-changed

Dependencies added: base, utility-ht

Files

+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Henning Thielemann 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ comfort-array.cabal view
@@ -0,0 +1,66 @@+Name:             comfort-array+Version:          0.0+License:          BSD3+License-File:     LICENSE+Author:           Henning Thielemann <haskell@henning-thielemann.de>+Maintainer:       Henning Thielemann <haskell@henning-thielemann.de>+Homepage:         http://hub.darcs.net/thielema/comfort-array/+Category:         Data Structures+Synopsis:         Arrays where the index type is a function of the shape type+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+  with free choice of the lower bounds (0, 1, or whatever you like).+  .+  This package goes one step further:+  The shape and the index type are different,+  but the index type is a type function of the shape type.+  This offers much more flexibility and type safety.+  .+  Some examples are:+  .+  * @Range@:+    Allow dynamic choice of lower and upper array bounds+    such as in the 'Array's from the @array@ package.+    You can combine it with other shapes in other dimensions.+    It allows you to describe the bounds of each dimension individually.+  .+  * @Shifted@:+    Describe array bounds by start index and length.+    It is sometimes more natural to use these parameters.+    E.g. a non-negative index type like 'Word' cannot represent @-1@+    and thus cannot encode an empty range starting with index @0@.+  .+  * @Square@:+    An 2D array where both dimensions always have equal size.+  .+  * @ZeroBased, OneBased@:+    Arrays with fixed lower bound, either 0 or 1, respectively.+  .+  * Arrays with indices like 'LT', 'EQ', 'GT' and dummy shape.++Tested-With:      GHC==7.4.2, GHC==7.8.4, GHC==8.2.2+Cabal-Version:    >=1.6+Build-Type:       Simple++Source-Repository this+  Tag:         0.0+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/comfort-array/++Source-Repository head+  Type:        darcs+  Location:    http://hub.darcs.net/thielema/comfort-array/++Library+  Build-Depends:+    utility-ht >=0.0.10 && <0.1,+    base >=4.5 && <5++  GHC-Options:      -Wall+  Hs-Source-Dirs:   src+  Exposed-Modules:+    Data.Array.Comfort.Shape+    Data.Array.Comfort.Storable+    Data.Array.Comfort.Storable.Internal
+ src/Data/Array/Comfort/Shape.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-+Tests:+   map offset (indices sh) = [0..]+   length (indices sh) = size sh+   sizeOffset sh ix = (size sh, offset sh ix)+-}+module Data.Array.Comfort.Shape (+   C(..),++   ZeroBased(..),+   OneBased(..),++   Range(..),+   Shifted(..),+   (:+:)(..),+   ) where++import Foreign.Storable+         (Storable, sizeOf, alignment, poke, peek, pokeElemOff, peekElemOff)+import Foreign.Ptr (Ptr, castPtr)++import qualified GHC.Arr as Ix++import qualified Control.Monad.HT as Monad++import Data.Tuple.HT (mapFst, mapPair)+++class C sh where+   {-# MINIMAL indices, size, (sizeOffset|offset), inBounds #-}+   type Index sh :: *+   -- Ix.range+   indices :: sh -> [Index sh]+   -- Ix.index+   offset :: sh -> Index sh -> Int+   offset sh ix = snd $ sizeOffset sh ix+   -- Ix.unsafeIndex+   uncheckedOffset :: sh -> Index sh -> Int+   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)+++instance C () where+   type Index () = ()+   indices () = [()]+   offset () () = 0+   uncheckedOffset () () = 0+   inBounds () () = True+   size () = 1+   uncheckedSize () = 1+++{- |+'ZeroBased' denotes a range starting at zero and has a certain length.+-}+newtype ZeroBased n = ZeroBased {zeroBasedSize :: n}+   deriving (Eq, Show)++instance (Integral n) => C (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<len+   size (ZeroBased len) = fromIntegral len+   uncheckedSize (ZeroBased len) = fromIntegral len++{- |+'OneBased' denotes a range starting at zero and has a certain length.+-}+newtype OneBased n = OneBased {oneBasedSize :: n}+   deriving (Eq, Show)++instance (Integral n) => C (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<ix && ix<=len+   size (OneBased len) = fromIntegral len+   uncheckedSize (OneBased len) = fromIntegral len+++{- |+'Range' denotes an inclusive range like+those of the Haskell 98 standard @Array@ type from the @array@ package.+E.g. the shape type @(Range Int32, Range Int64)@+is equivalent to the ix type @(Int32, Int64)@ for @Array@s.+-}+data Range n = Range {rangeFrom, rangeTo :: n}+   deriving (Eq, Show)++instance (Ix.Ix n) => C (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)++-- cf. sample-frame:Stereo+instance Storable n => Storable (Range n) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(Range l r) = sizeOf l + mod (- sizeOf l) (alignment r) + sizeOf r+   alignment ~(Range l _) = alignment l+   poke p (Range l r) =+      let q = castToElemPtr p+      in  poke q l >> pokeElemOff q 1 r+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Range (peek q) (peekElemOff q 1)+++{- |+'Shifted' denotes a range defined by the start index and the length.+-}+data Shifted n = Shifted {shiftedOffset, shiftedSize :: n}+   deriving (Eq, Show)++instance (Integral n) => C (Shifted n) where+   type Index (Shifted n) = n+   indices (Shifted offs len) =+      map snd $+      takeWhile ((>0) . fst) $+      zip+         (iterate (subtract 1) len)+         (iterate (1+) offs)+   offset (Shifted offs len) ix =+      if ix<offs+        then error "Shape.Shifted: array index too small"+        else+          let k = ix-offs+          in  if k<len+                then fromIntegral k+                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++-- cf. sample-frame:Stereo+instance Storable n => Storable (Shifted n) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n+   alignment ~(Shifted l _) = alignment l+   poke p (Shifted l n) =+      let q = castToElemPtr p+      in  poke q l >> pokeElemOff q 1 n+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)+++{-# INLINE castToElemPtr #-}+castToElemPtr :: Ptr (f a) -> Ptr a+castToElemPtr = castPtr++++{- |+Row-major composition of two dimensions.+-}+instance (C sh0, C sh1) => C (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) =+      offset sh0 ix0 `combineOffset` sizeOffset sh1 ix1+   uncheckedOffset (sh0,sh1) (ix0,ix1) =+      uncheckedOffset sh0 ix0 `combineOffset` uncheckedSizeOffset sh1 ix1+   sizeOffset (sh0,sh1) (ix0,ix1) =+      sizeOffset sh0 ix0 `combineSizeOffset` sizeOffset sh1 ix1+   uncheckedSizeOffset (sh0,sh1) (ix0,ix1) =+      uncheckedSizeOffset sh0 ix0+      `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 (C sh0, C sh1, C sh2) => C (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)+   uncheckedOffset (sh0,sh1,sh2) (ix0,ix1,ix2) =+      uncheckedOffset sh0 ix0+      `combineOffset`+      uncheckedSizeOffset sh1 ix1+      `combineSizeOffset`+      uncheckedSizeOffset sh2 ix2+   sizeOffset (sh0,sh1,sh2) (ix0,ix1,ix2) =+      sizeOffset sh0 ix0+      `combineSizeOffset`+      sizeOffset sh1 ix1+      `combineSizeOffset`+      sizeOffset sh2 ix2+   uncheckedSizeOffset (sh0,sh1,sh2) (ix0,ix1,ix2) =+      uncheckedSizeOffset sh0 ix0+      `combineSizeOffset`+      uncheckedSizeOffset sh1 ix1+      `combineSizeOffset`+      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+++infixr 7 `combineOffset`, `combineSizeOffset`++{-# INLINE combineOffset #-}+combineOffset :: Num a => a -> (a, a) -> a+combineOffset offset0 (size1,offset1) = offset0 * size1 + offset1++{-# INLINE combineSizeOffset #-}+combineSizeOffset :: Num a => (a, a) -> (a, a) -> (a, a)+combineSizeOffset (size0,offset0) (size1,offset1) =+   (size0*size1, offset0 * size1 + offset1)++++infixr 5 :+:++data sh0:+:sh1 = sh0:+:sh1+   deriving (Eq, Show)++{-+-- cf. sample-frame:Stereo+instance (Storable sh0, Storable sh1) => Storable (sh0:+:sh1) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(sh0:+:sh1) = sizeOf sh0 + mod (- sizeOf sh0) (alignment sh1) + sizeOf sh1+   alignment ~(sh0:+:sh1) = alignment sh0+   poke p (sh0:+:sh1) =+      let q = castToElemPtr p+      in  poke q sh0 >> pokeElemOff q 1 sh1+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)+-}++instance (C sh0, C sh1) => C (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 =+      case ix of+         Left ix0 -> offset sh0 ix0+         Right ix1 -> size sh0 + offset sh1 ix1+   uncheckedOffset (sh0:+:sh1) ix =+      case ix of+         Left ix0 -> uncheckedOffset sh0 ix0+         Right ix1 -> uncheckedSize sh0 + uncheckedOffset sh1 ix1+   sizeOffset (sh0:+:sh1) ix =+      case ix of+         Left ix0 -> mapFst (+ size sh1) $ sizeOffset sh0 ix0+         Right ix1 ->+            let size0 = size sh0+            in  mapPair ((size0+), (size0+)) $ sizeOffset sh1 ix1+   uncheckedSizeOffset (sh0:+:sh1) ix =+      case ix of+         Left ix0 -> mapFst (+ uncheckedSize sh1) $ uncheckedSizeOffset sh0 ix0+         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
+ src/Data/Array/Comfort/Storable.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Array.Comfort.Storable (+   Array,+   shape,+   (!),+   toList,+   fromList,+   vectorFromList,+   ) where++import Data.Array.Comfort.Storable.Internal
+ src/Data/Array/Comfort/Storable/Internal.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE TypeFamilies #-}+module Data.Array.Comfort.Storable.Internal (+   Array(Array, shape, buffer),+   reshape,+   mapShape,++   (!),+   unsafeCreate,+   toList,+   fromList,+   vectorFromList,++   createIO,+   createWithSizeIO,+   showIO,+   readIO,+   toListIO,+   fromListIO,+   vectorFromListIO,+   ) where++import qualified Data.Array.Comfort.Shape as Shape++import Foreign.Marshal.Array (pokeArray, peekArray, )+import Foreign.Storable (Storable, peekElemOff, )+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, mallocForeignPtrArray, )+import Foreign.Ptr (Ptr, )++import System.IO.Unsafe (unsafePerformIO, )++import Prelude hiding (readIO, )+++data Array sh a =+   Array {+      shape :: sh,+      buffer :: ForeignPtr a+   }++instance (Shape.C sh, Show sh, Storable a, Show a) => Show (Array sh a) where+   show = unsafePerformIO . showIO++-- add assertion, at least in an exposed version+reshape :: sh1 -> Array sh0 a -> Array sh1 a+reshape sh (Array _ fptr) = Array sh fptr++mapShape :: (sh0 -> sh1) -> Array sh0 a -> Array sh1 a+mapShape f (Array sh fptr) = Array (f sh) fptr+++infixl 9 !++unsafeCreate ::+   (Shape.C sh, Storable a) => sh -> (Ptr a -> IO ()) -> Array sh a+unsafeCreate sh = unsafePerformIO . createIO sh++(!) :: (Shape.C sh, Storable a) => Array sh a -> Shape.Index sh -> a+(!) arr = unsafePerformIO . readIO arr++toList :: (Shape.C sh, Storable a) => Array sh a -> [a]+toList = unsafePerformIO . toListIO++fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Array sh a+fromList sh = unsafePerformIO . fromListIO sh++vectorFromList :: (Storable a) => [a] -> Array (Shape.ZeroBased Int) a+vectorFromList = unsafePerformIO . vectorFromListIO+++createIO ::+   (Shape.C sh, Storable a) => sh -> (Ptr a -> IO ()) -> IO (Array sh a)+createIO sh f = createWithSizeIO sh $ const f++createWithSizeIO ::+   (Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO ()) -> IO (Array sh a)+createWithSizeIO sh f = do+   let size = Shape.size sh+   fptr <- mallocForeignPtrArray size+   withForeignPtr fptr $ f size+   return $ Array sh fptr++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 (Array sh fptr) ix =+   withForeignPtr fptr $ flip peekElemOff (Shape.offset sh ix)++toListIO :: (Shape.C sh, Storable a) => Array sh a -> IO [a]+toListIO (Array sh fptr) =+   withForeignPtr fptr $ peekArray (Shape.size sh)++fromListIO ::+   (Shape.C sh, Storable a) =>+   sh -> [a] -> IO (Array sh a)+fromListIO sh xs =+   createWithSizeIO sh $ \size ptr ->+      pokeArray ptr $ take size $+      xs +++      repeat (error "Array.Comfort.Storable.fromList: list too short for shape")++vectorFromListIO :: (Storable a) => [a] -> IO (Array (Shape.ZeroBased Int) a)+vectorFromListIO xs =+   createIO (Shape.ZeroBased $ length xs) $ flip pokeArray xs