diff --git a/Changes.md b/Changes.md --- a/Changes.md +++ b/Changes.md @@ -1,5 +1,23 @@ # Change log for the `comfort-array` package +## 0.5 + + * `Array.Boxed`.`map`, `zipWith`, `toList`: make lazy + + * add `unified` methods to `Shape` classes: + `unifiedSize`, `unifiedOffset`, `unifiedSizeOffset`, + `uncheckedIndexFromOffset`. + They simplify to share code between checked and unchecked variants. + Actually, many implementations of these methods + recursively call themselves on part shapes. + However, the default methods have changed. + + * `Shape.:+:` -> `Shape.::+`. + This resolves the name clash with the `:+:` operator from `tfp`. + It also highlights the right associativity and non-commutativity. + + * `Shape.Simplex` + ## 0.4.1 * use `doctest-extract` for tests 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.4.1 +Version: 0.5.5 License: BSD3 License-File: LICENSE Author: Henning Thielemann @@ -19,7 +19,7 @@ but the index type is a type function of the shape type. This offers much more flexibility and type safety. . - Some examples are: + Some @Shape@ example types are: . * @Range@: Allow dynamic choice of lower and upper array bounds @@ -45,36 +45,61 @@ * @Enumeration@: Arrays with indices like 'LT', 'EQ', 'GT' and a shape of fixed size. . - * @(:+:)@: + * @NestedTuple@: + Arrays with shapes that are compatible to nested tuples + like @(a,(a,a))@ and indices like @fst@ and @fst.snd@. + . + * @(::+)@: The Append type constructor allows to respresent block arrays, e.g. block matrices. - It also allows to represent non-empty arrays via @():+:sh@. + It also allows to represent non-empty arrays via @()::+sh@. . * @Set@: Use an arbitrary ordered set as index set. . * @Map@: Concatenate a set of shapes. + In a higher dimensional array it can be used for block matrices + with a dynamic number of blocks but block sizes of the same shape type. . * @Triangular@: A 2D array with the shape of a lower or upper triangular matrix. . + * @Simplex@: + Simplices of any dimension, where the dimension is encoded in the type. + An index is a tuple of monotonic ordered sub-indices. + . * @Square@: A 2D array where both dimensions always have equal size. . * @Cube@: A 3D array where all three dimensions always have equal size. . * @Tagged@: Statically distinguish shapes and indices that are isomorphic. . - The @lapack@ package defines even more fancy shapes - like tall rectangular matrices, triangular matrices and banded matrices. + With our @Array@ type you can perform + . + * Fast Linear Algebra using the packages @comfort-blas@ and @lapack@. + The @lapack@ package defines even more fancy shapes + like tall rectangular matrices, triangular matrices and banded matrices. + . + * Fast Fourier Transforms using the package @comfort-fftw@ + . + * Fast Linear Programming using the packages + @comfort-glpk@, @coinor-clp@, @highs-lp@ + . + * Efficient Array Processing via LLVM Just-In-Time code generation + using the package @knead@. + . + See also @comfort-graph@ for a Graph data structure, + with non-Int node identifiers and flexible edge types. -Tested-With: GHC==7.4.2, GHC==7.8.4, GHC==8.2.2 +Tested-With: GHC==7.4.2, GHC==7.8.4 +Tested-With: GHC==8.2.2, GHC==8.6.5, GHC==8.10.4 +Tested-With: GHC==9.4.5, GHC==9.6.2 Cabal-Version: 1.14 Build-Type: Simple Extra-Source-Files: Changes.md - test-module.list Source-Repository this - Tag: 0.4.1 + Tag: 0.5.5 Type: darcs Location: https://hub.darcs.net/thielema/comfort-array/ @@ -88,15 +113,20 @@ Library Build-Depends: - primitive >=0.6.4 && <0.8, + storablevector >=0.2 && <0.3, + -- 0.7.1 required for arrayFromList, arrayFromListN + primitive >=0.7.1 && <0.10, guarded-allocation >=0.0.1 && <0.1, storable-record >=0.0.1 && <0.1, tagged >=0.7 && <0.9, - deepseq >=1.3 && <1.5, + deepseq >=1.3 && <1.6, QuickCheck >=2 && <3, semigroups >=0.18.3 && <1.0, - containers >=0.4 && <0.7, - transformers >=0.3 && <0.6, + containers >=0.4 && <0.8, + -- transformers-compat required for Functor.Classes in GHC-7.8.4 + transformers-compat >=0.6.6 && <0.8, + transformers >=0.3 && <0.7, + bifunctors >=5.5 && <5.7, non-empty >=0.3.2 && <0.4, utility-ht >=0.0.10 && <0.1, prelude-compat >=0.0 && <0.1, @@ -114,19 +144,25 @@ Exposed-Modules: Data.Array.Comfort.Shape Data.Array.Comfort.Shape.Test + Data.Array.Comfort.Shape.SubSize Data.Array.Comfort.Storable + Data.Array.Comfort.Storable.Dim2 Data.Array.Comfort.Storable.Unchecked Data.Array.Comfort.Storable.Unchecked.Monadic + Data.Array.Comfort.Storable.Unchecked.Creator Data.Array.Comfort.Storable.Private Data.Array.Comfort.Storable.Mutable Data.Array.Comfort.Storable.Mutable.Unchecked Data.Array.Comfort.Storable.Mutable.Private Data.Array.Comfort.Boxed + Data.Array.Comfort.Boxed.Unchecked + Data.Array.Comfort.Bool Data.Array.Comfort.Container Other-Modules: + Data.Array.Comfort.Shape.Tuple Data.Array.Comfort.Shape.Set Data.Array.Comfort.Shape.Utility - Data.Array.Comfort.Boxed.Unchecked + Data.Array.Comfort.Boxed.Strict.Unchecked Data.Array.Comfort.Storable.Memory Data.Array.Comfort.Check @@ -135,11 +171,13 @@ Build-Depends: comfort-array, doctest-exitcode-stdio >=0.0 && <0.1, - doctest-lib >=0.1 && <0.1.1, + doctest-lib >=0.1 && <0.1.2, ChasingBottoms >=1.2.2 && <1.4, tagged, containers, QuickCheck, + utility-ht >=0.0.13, + deepseq, base GHC-Options: -Wall @@ -150,6 +188,9 @@ DocTest.Data.Array.Comfort.Shape DocTest.Data.Array.Comfort.Storable.Unchecked DocTest.Data.Array.Comfort.Storable + DocTest.Data.Array.Comfort.Storable.Dim2 + DocTest.Data.Array.Comfort.Boxed.Unchecked + DocTest.Data.Array.Comfort.Boxed DocTest.Main Test.Shape Test.Utility diff --git a/set/0.4.0/Data/Array/Comfort/Shape/Set.hs b/set/0.4.0/Data/Array/Comfort/Shape/Set.hs --- a/set/0.4.0/Data/Array/Comfort/Shape/Set.hs +++ b/set/0.4.0/Data/Array/Comfort/Shape/Set.hs @@ -5,24 +5,20 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.Tuple.HT (fst3) +import Data.Maybe.HT (toMaybe) -offset :: Ord a => Set a -> a -> Int +offset :: Ord a => Set a -> a -> Maybe Int offset set ix = case Set.splitMember ix set of - (less, hit, _) -> - if hit - then Set.size less - else error "Shape.Set: array index not member of the index set" + (less, hit, _) -> toMaybe hit (Set.size less) uncheckedOffset :: Ord a => Set a -> a -> Int uncheckedOffset set = Set.size . fst3 . flip Set.splitMember set -indexFromOffset :: Set a -> Int -> a -indexFromOffset set k = - if 0<=k - then uncheckedIndexFromOffset set k - else errorIndexFromOffset "Set" k + +indexFromOffset :: Set a -> Int -> Maybe a +indexFromOffset set k = toMaybe (0<=k) (uncheckedIndexFromOffset set k) uncheckedIndexFromOffset :: Set a -> Int -> a uncheckedIndexFromOffset set k = diff --git a/set/0.5.4/Data/Array/Comfort/Shape/Set.hs b/set/0.5.4/Data/Array/Comfort/Shape/Set.hs --- a/set/0.5.4/Data/Array/Comfort/Shape/Set.hs +++ b/set/0.5.4/Data/Array/Comfort/Shape/Set.hs @@ -2,12 +2,19 @@ import qualified Data.Set as Set import Data.Set (Set) +import Data.Maybe.HT (toMaybe) -offset, uncheckedOffset :: Ord a => Set a -> a -> Int -offset = flip Set.findIndex -uncheckedOffset = offset +offset :: Ord a => Set a -> a -> Maybe Int +offset = flip Set.lookupIndex -indexFromOffset, uncheckedIndexFromOffset :: Set a -> Int -> a -indexFromOffset = flip Set.elemAt -uncheckedIndexFromOffset = indexFromOffset +uncheckedOffset :: Ord a => Set a -> a -> Int +uncheckedOffset = flip Set.findIndex + + +indexFromOffset :: Set a -> Int -> Maybe a +indexFromOffset set k = + toMaybe (0<=k && k Int -> a +uncheckedIndexFromOffset = flip Set.elemAt diff --git a/src/Data/Array/Comfort/Bool.hs b/src/Data/Array/Comfort/Bool.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Bool.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{- | +Can be an alternative to the @enumset@ package. +-} +module Data.Array.Comfort.Bool ( + Array, + shape, + reshape, + mapShape, + + fromList, + toList, + fromSet, + toSet, + + member, + union, + difference, + intersection, + ) where + +import qualified Data.Array.Comfort.Shape as Shape +import qualified Data.Array.Comfort.Check as Check + +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import qualified Data.List as List +import Data.IntSet (IntSet) +import Data.Set (Set) + + +data Array sh = + Array { + shape_ :: sh, + _intSet :: IntSet + } + + +shape :: Array sh -> sh +shape = shape_ + +reshape :: (Shape.C sh0, Shape.C sh1) => sh1 -> Array sh0 -> Array sh1 +reshape = Check.reshape "Storable" shape (\sh arr -> arr{shape_ = sh}) + +mapShape :: + (Shape.C sh0, Shape.C sh1) => (sh0 -> sh1) -> Array sh0 -> Array sh1 +mapShape f arr = reshape (f $ shape arr) arr + + + +fromList :: (Shape.Indexed sh) => sh -> [Shape.Index sh] -> Array sh +fromList sh = Array sh . IntSet.fromList . List.map (Shape.offset sh) + +toList :: (Shape.InvIndexed sh) => Array sh -> [Shape.Index sh] +toList (Array sh set) = map (Shape.indexFromOffset sh) $ IntSet.toList set + +fromSet :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Ord ix) => sh -> Set ix -> Array sh +fromSet sh = fromList sh . Set.toList + +toSet :: + (Shape.InvIndexed sh, Shape.Index sh ~ ix, Ord ix) => Array sh -> Set ix +toSet = Set.fromList . toList + + +errorArray :: String -> String -> a +errorArray name msg = + error ("Array.Comfort.Bool." ++ name ++ ": " ++ msg) + + +member :: (Shape.Indexed sh) => Shape.Index sh -> Array sh -> Bool +member ix (Array sh set) = IntSet.member (Shape.offset sh ix) set + + +lift2 :: (Shape.Indexed sh, Eq sh) => + String -> (IntSet -> IntSet -> IntSet) -> + Array sh -> Array sh -> Array sh +lift2 name op (Array shA setA) (Array shB setB) = + if shA == shB + then Array shA $ op setA setB + else errorArray name "shapes mismatch" + +union :: (Shape.Indexed sh, Eq sh) => Array sh -> Array sh -> Array sh +union = lift2 "union" IntSet.union + +intersection :: (Shape.Indexed sh, Eq sh) => Array sh -> Array sh -> Array sh +intersection = lift2 "intersection" IntSet.intersection + +difference :: (Shape.Indexed sh, Eq sh) => Array sh -> Array sh -> Array sh +difference = lift2 "difference" IntSet.difference diff --git a/src/Data/Array/Comfort/Boxed.hs b/src/Data/Array/Comfort/Boxed.hs --- a/src/Data/Array/Comfort/Boxed.hs +++ b/src/Data/Array/Comfort/Boxed.hs @@ -3,47 +3,84 @@ shape, reshape, mapShape, - (!), + accessMaybe, (!), Array.toList, Array.fromList, Array.vectorFromList, toAssociations, fromMap, toMap, + fromTuple, + toTuple, + fromRecord, + toRecord, fromContainer, toContainer, indices, Array.replicate, + cartesian, Array.map, zipWith, (//), accumulate, fromAssociations, + + pick, + Array.append, + Array.take, Array.drop, + Array.takeLeft, Array.takeRight, Array.split, + Array.takeCenter, ) where import qualified Data.Array.Comfort.Boxed.Unchecked as Array import qualified Data.Array.Comfort.Container as Container import qualified Data.Array.Comfort.Check as Check +import qualified Data.Array.Comfort.Shape.Tuple as TupleShape import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Boxed.Unchecked (Array(Array)) import qualified Data.Primitive.Array as Prim import qualified Control.Monad.Primitive as PrimM +import qualified Control.Monad.Trans.State as MS import Control.Monad.ST (runST) -import Control.Applicative ((<$>)) +import Control.Applicative (liftA2, (<$>)) import qualified Data.Foldable as Fold import qualified Data.Map as Map import qualified Data.Set as Set import Data.Map (Map) import Data.Set (Set) +import Data.Traversable (Traversable, traverse) import Data.Foldable (forM_) +import Data.Either.HT (maybeRight) import Prelude hiding (zipWith, replicate) +{- $setup +>>> import qualified Data.Array.Comfort.Boxed as Array +>>> import qualified Data.Array.Comfort.Shape as Shape +>>> import Data.Array.Comfort.Boxed (Array, (!)) +>>> +>>> import qualified Test.QuickCheck as QC +>>> +>>> type ShapeInt = Shape.ZeroBased Int +>>> +>>> genArray2 :: QC.Gen (Array (ShapeInt,ShapeInt) Char) +>>> genArray2 = do +>>> xs <- QC.arbitrary +>>> let n = length xs +>>> (k,m) <- +>>> if n == 0 +>>> then QC.elements [(,) 0, flip (,) 0] <*> QC.choose (1,20) +>>> else fmap (\m -> (div n m, m)) $ QC.choose (1,n) +>>> return $ +>>> Array.fromList (Shape.ZeroBased k, Shape.ZeroBased m) $ take (k*m) xs +-} + + shape :: Array.Array sh a -> sh shape = Array.shape @@ -64,6 +101,39 @@ toMap :: (Ord k) => Array (Set k) a -> Map k a toMap arr = Map.fromAscList $ zip (Set.toAscList $ shape arr) (Array.toList arr) +fromTuple :: + (TupleShape.NestedTuple tuple) => + Shape.DataTuple tuple a -> Array (Shape.NestedTuple ixtype tuple) a +fromTuple tuple = + case MS.evalState (TupleShape.decons tuple) (Shape.Element 0) of + (sh, xs) -> Array.fromList (Shape.NestedTuple sh) xs + +toTuple :: + (TupleShape.NestedTuple tuple) => + Array (Shape.NestedTuple ixtype tuple) a -> Shape.DataTuple tuple a +toTuple arr = + MS.evalState + (TupleShape.cons $ Shape.getNestedTuple $ shape arr) + (Array.toList arr) + +fromRecord :: + (Traversable f) => + f a -> Array (Shape.Record f) a +fromRecord xs = + Array.fromList + (Shape.Record $ flip MS.evalState (Shape.Element 0) $ + traverse (const TupleShape.next) xs) + (Fold.toList xs) + +toRecord :: + (Traversable f) => + Array (Shape.Record f) a -> f a +toRecord arr = + MS.evalState + (traverse (const TupleShape.get) $ + (\(Shape.Record record) -> record) $ shape arr) + (Array.toList arr) + fromContainer :: (Container.C f) => f a -> Array (Container.Shape f) a fromContainer xs = Array.fromList (Container.toShape xs) (Fold.toList xs) @@ -74,12 +144,18 @@ infixl 9 ! (!) :: (Shape.Indexed sh) => Array sh a -> Shape.Index sh -> a -(!) (Array sh arr) ix = - if Shape.inBounds sh ix - then Prim.indexArray arr $ Shape.offset sh ix - else error "Array.Comfort.Boxed.!: index out of bounds" +(!) arr = + either (error . ("Array.Comfort.Boxed.!: " ++)) id . accessEither arr +accessMaybe :: (Shape.Indexed sh) => Array sh a -> Shape.Index sh -> Maybe a +accessMaybe arr = maybeRight . accessEither arr +accessEither :: + (Shape.Indexed sh) => Array sh a -> Shape.Index sh -> Either String a +accessEither (Array sh arr) ix = + fmap (Prim.indexArray arr) $ Shape.getChecked $ Shape.unifiedOffset sh ix + + zipWith :: (Shape.C sh, Eq sh) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c @@ -118,3 +194,30 @@ marr <- Prim.newArray (Shape.size sh) a forM_ xs $ \(ix,x) -> Prim.writeArray marr (Shape.offset sh ix) x Array sh <$> Prim.unsafeFreezeArray marr) + + + +{- | +prop> :{ + QC.forAll genArray2 $ \xs -> + let shape = Array.shape xs in + Shape.size shape > 0 QC.==> + QC.forAll (QC.elements $ Shape.indices shape) $ \(ix0,ix1) -> + Array.pick xs ix0 ! ix1 == xs!(ix0,ix1) +:} +-} +pick :: + (Shape.Indexed sh0, Shape.C sh1) => + Array (sh0,sh1) a -> Shape.Index sh0 -> Array sh1 a +pick (Array (sh0,sh1) x) ix0 = + Array sh1 $ + let k = Shape.size sh1 + in Prim.cloneArray x (Shape.offset sh0 ix0 * k) k + + +cartesian :: + (Shape.C sh0, Shape.C sh1) => + Array sh0 a -> Array sh1 b -> Array (sh0,sh1) (a,b) +cartesian a b = + Array.fromList (shape a, shape b) $ + liftA2 (,) (Array.toList a) (Array.toList b) diff --git a/src/Data/Array/Comfort/Boxed/Strict/Unchecked.hs b/src/Data/Array/Comfort/Boxed/Strict/Unchecked.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Boxed/Strict/Unchecked.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.Array.Comfort.Boxed.Strict.Unchecked where + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Boxed.Unchecked (Array(Array)) + +import qualified Data.Primitive.Array as Prim + +import qualified Control.Monad.ST.Strict as STStrict +import qualified Control.Monad.Trans.Class as MT +import qualified Control.Monad.Trans.State as MS + +import Prelude hiding (map, zipWith) + + +toList :: (Shape.C sh) => Array sh a -> [a] +toList (Array sh arr) = + STStrict.runST (mapM (Prim.indexArrayM arr) $ take (Shape.size sh) [0..]) + +map :: (Shape.C sh) => (a -> b) -> Array sh a -> Array sh b +map f (Array sh arr) = Array sh $ Prim.mapArray' f arr + +zipWith :: + (Shape.C sh) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c +zipWith f (Array sha arra) (Array _shb arrb) = + Array sha $ + STStrict.runST + (flip MS.evalStateT 0 $ + Prim.traverseArrayP + (\a -> do + k <- MS.get + b <- MT.lift $ Prim.indexArrayM arrb k + MS.put (k+1) + return $ f a b) + arra) diff --git a/src/Data/Array/Comfort/Boxed/Unchecked.hs b/src/Data/Array/Comfort/Boxed/Unchecked.hs --- a/src/Data/Array/Comfort/Boxed/Unchecked.hs +++ b/src/Data/Array/Comfort/Boxed/Unchecked.hs @@ -1,12 +1,30 @@ {-# LANGUAGE TypeFamilies #-} -module Data.Array.Comfort.Boxed.Unchecked where +{-# LANGUAGE TypeOperators #-} +module Data.Array.Comfort.Boxed.Unchecked ( + Array(..), + reshape, + mapShape, + (!), + toList, + fromList, + vectorFromList, + replicate, + map, + zipWith, + append, + take, drop, + takeLeft, takeRight, split, + takeCenter, + ) where + import qualified Data.Array.Comfort.Shape as Shape import qualified Data.Primitive.Array as Prim +import Data.Array.Comfort.Shape ((::+)((::+))) -import qualified Control.Monad.ST.Strict as STStrict -import qualified Control.Monad.Trans.Class as MT -import qualified Control.Monad.Trans.State as MS +-- FixMe: In GHC-7.4.2 there is no instance PrimMonad (Lazy.ST s) +-- import qualified Control.Monad.ST.Lazy as ST +import qualified Control.Monad.ST.Strict as ST import Control.Monad (liftM) import Control.Applicative (Applicative, pure, (<*>), (<$>)) import Control.DeepSeq (NFData, rnf) @@ -14,14 +32,43 @@ import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.List as List -import Prelude hiding (map, zipWith, replicate) +import Prelude hiding (map, zipWith, replicate, take, drop) +{- $setup +>>> import qualified Data.Array.Comfort.Boxed as Array +>>> import qualified Data.Array.Comfort.Shape as Shape +>>> import Data.Array.Comfort.Boxed (Array, (!)) +>>> import Data.Tuple.HT (swap) +>>> import Control.Applicative ((<$>)) +>>> +>>> import qualified Test.QuickCheck as QC +>>> +>>> type ShapeInt = Shape.ZeroBased Int +>>> +>>> genArray :: QC.Gen (Array ShapeInt Char) +>>> genArray = Array.vectorFromList <$> QC.arbitrary +>>> +>>> newtype ArrayChar = ArrayChar (Array ShapeInt Char) +>>> deriving (Show) +>>> +>>> instance QC.Arbitrary ArrayChar where +>>> arbitrary = fmap ArrayChar genArray +>>> +>>> +>>> transpose :: +>>> (Shape.Indexed sh0, Shape.Indexed sh1) => +>>> Array (sh0,sh1) a -> Array (sh1,sh0) a +>>> transpose a = +>>> fmap (\(i,j) -> a!(j,i)) $ Array.indices $ swap $ Array.shape a +-} + + data Array sh a = Array { shape :: sh, buffer :: Prim.Array a - } + } deriving (Eq) instance (Shape.C sh, Show sh, Show a) => Show (Array sh a) where showsPrec p arr = @@ -29,11 +76,11 @@ showString "BoxedArray.fromList " . showsPrec 11 (shape arr) . showChar ' ' . - shows (toListLazy arr) + shows (toList arr) instance (Shape.C sh, NFData sh, NFData a) => NFData (Array sh a) where - rnf a@(Array sh _arr) = rnf (sh, toListLazy a) + rnf a@(Array sh _arr) = rnf (sh, toList a) instance (Shape.C sh) => Functor (Array sh) where fmap = map @@ -61,7 +108,6 @@ sequence (Array sh arr) = liftM (Array sh) $ Trav.sequence arr --- add assertion, at least in an exposed version reshape :: sh1 -> Array sh0 a -> Array sh1 a reshape sh (Array _ arr) = Array sh arr @@ -74,40 +120,95 @@ (!) :: (Shape.Indexed sh) => Array sh a -> Shape.Index sh -> a (!) (Array sh arr) ix = Prim.indexArray arr $ Shape.uncheckedOffset sh ix -toListLazy :: (Shape.C sh) => Array sh a -> [a] -toListLazy (Array sh arr) = - List.map (Prim.indexArray arr) $ take (Shape.size sh) [0..] - toList :: (Shape.C sh) => Array sh a -> [a] toList (Array sh arr) = - STStrict.runST (mapM (Prim.indexArrayM arr) $ take (Shape.size sh) [0..]) + List.map (Prim.indexArray arr) $ List.take (Shape.size sh) [0..] fromList :: (Shape.C sh) => sh -> [a] -> Array sh a -fromList sh xs = Array sh $ Prim.fromListN (Shape.size sh) xs +fromList sh xs = Array sh $ Prim.arrayFromListN (Shape.size sh) xs vectorFromList :: [a] -> Array (Shape.ZeroBased Int) a vectorFromList xs = - let arr = Prim.fromList xs + let arr = Prim.arrayFromList xs in Array (Shape.ZeroBased $ Prim.sizeofArray arr) arr replicate :: (Shape.C sh) => sh -> a -> Array sh a replicate sh a = Array sh $ - STStrict.runST (Prim.unsafeFreezeArray =<< Prim.newArray (Shape.size sh) a) + ST.runST (Prim.unsafeFreezeArray =<< Prim.newArray (Shape.size sh) a) map :: (Shape.C sh) => (a -> b) -> Array sh a -> Array sh b -map f (Array sh arr) = Array sh $ Prim.mapArray' f arr +map f (Array sh arr) = Array sh $ + let n = Shape.size sh + in Prim.arrayFromListN n $ List.map (f . Prim.indexArray arr) $ List.take n [0..] zipWith :: (Shape.C sh) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c -zipWith f (Array sha arra) (Array _shb arrb) = - Array sha $ - STStrict.runST - (flip MS.evalStateT 0 $ - Prim.traverseArrayP - (\a -> do - k <- MS.get - b <- MT.lift $ Prim.indexArrayM arrb k - MS.put (k+1) - return $ f a b) - arra) +zipWith f (Array sha arra) (Array _shb arrb) = Array sha $ + let n = Shape.size sha + in Prim.arrayFromListN n $ + List.map (\k -> f (Prim.indexArray arra k) (Prim.indexArray arrb k)) $ + List.take n [0..] + + + +infixr 5 `append` + +append :: + (Shape.C shx, Shape.C shy) => + Array shx a -> Array shy a -> Array (shx::+shy) a +append (Array shX x) (Array shY y) = + let sizeX = Shape.size shX in + let sizeY = Shape.size shY in + Array (shX::+shY) $ + ST.runST (do + arr <- + Prim.newArray (sizeX+sizeY) + (error "Boxed.append: uninitialized element") + Prim.copyArray arr 0 x 0 sizeX + Prim.copyArray arr sizeX y 0 sizeY + Prim.unsafeFreezeArray arr) + +{- | +prop> \(QC.NonNegative n) (ArrayChar x) -> x == Array.mapShape (Shape.ZeroBased . Shape.size) (Array.append (Array.take n x) (Array.drop n x)) +-} +take, drop :: + (Integral n) => + n -> Array (Shape.ZeroBased n) a -> Array (Shape.ZeroBased n) a +take n = takeLeft . splitN n +drop n = takeRight . splitN n + +splitN :: + (Integral n) => + n -> Array (Shape.ZeroBased n) a -> + Array (Shape.ZeroBased n ::+ Shape.ZeroBased n) a +splitN n = mapShape (Shape.zeroBasedSplit n) + +{- | +prop> \(ArrayChar x) (ArrayChar y) -> let xy = Array.append x y in x == Array.takeLeft xy && y == Array.takeRight xy +-} +takeLeft :: + (Shape.C sh0, Shape.C sh1) => + Array (sh0::+sh1) a -> Array sh0 a +takeLeft = + takeCenter . mapShape (\(sh0 ::+ sh1) -> (Shape.Zero ::+ sh0 ::+ sh1)) + +takeRight :: + (Shape.C sh0, Shape.C sh1) => + Array (sh0::+sh1) a -> Array sh1 a +takeRight = + takeCenter . mapShape (\(sh0 ::+ sh1) -> (sh0 ::+ sh1 ::+ Shape.Zero)) + +split :: + (Shape.C sh0, Shape.C sh1) => + Array (sh0::+sh1) a -> (Array sh0 a, Array sh1 a) +split x = (takeLeft x, takeRight x) + +{- | +prop> \(ArrayChar x) (ArrayChar y) (ArrayChar z) -> let xyz = Array.append x $ Array.append y z in y == Array.takeCenter xyz +-} +takeCenter :: + (Shape.C sh0, Shape.C sh1, Shape.C sh2) => + Array (sh0::+sh1::+sh2) a -> Array sh1 a +takeCenter (Array (sh0::+sh1::+_sh2) x) = + Array sh1 $ Prim.cloneArray x (Shape.size sh0) (Shape.size sh1) diff --git a/src/Data/Array/Comfort/Container.hs b/src/Data/Array/Comfort/Container.hs --- a/src/Data/Array/Comfort/Container.hs +++ b/src/Data/Array/Comfort/Container.hs @@ -5,7 +5,7 @@ while preserving the container structure. -} module Data.Array.Comfort.Container ( - C(..), EqShape(..), NFShape(..), + C(..), EqShape(..), NFShape(..), Indexed(..), ) where import qualified Data.Array.Comfort.Shape as Shape @@ -40,7 +40,14 @@ class (C f) => EqShape f where eqShape :: Shape f -> Shape f -> Bool +class (C f) => Indexed f where + type Index f + indices :: Shape f -> [Index f] + unifiedSizeOffset :: + (Shape.Checking check) => + Shape f -> (Int, Index f -> Shape.Result check Int) + instance (NFShape f) => NFData (Shape f) where rnf = rnfShape @@ -49,9 +56,13 @@ instance (C f) => Shape.C (Shape f) where size = shapeSize - uncheckedSize = shapeSize +instance (Indexed f) => Shape.Indexed (Shape f) where + type Index (Shape f) = Index f + indices = indices + unifiedSizeOffset = unifiedSizeOffset + instance C [] where data Shape [] = ShapeList Int deriving (Show) @@ -65,7 +76,16 @@ instance NFShape [] where rnfShape (ShapeList n) = rnf n +instance Indexed [] where + type Index [] = Int + indices (ShapeList len) = take len $ iterate (1+) 0 + unifiedSizeOffset (ShapeList len) = + (len, \ix -> do + Shape.assert "Shape.Container.[]: array index too small" $ ix>=0 + Shape.assert "Shape.Container.[]: array index too big" $ ix NFShape (NonEmpty.T f) where rnfShape (ShapeNonEmpty c) = rnfShape c +instance (C f) => Indexed (NonEmpty.T f) where + type Index (NonEmpty.T f) = Int + indices shape = take (shapeSize shape) $ iterate (1+) 0 + unifiedSizeOffset shape = + let len = shapeSize shape in + (len, \ix -> do + Shape.assert "Shape.Container.NonEmpty: array index too small" $ ix>=0 + Shape.assert "Shape.Container.NonEmpty: array index too big" $ ix NFShape (Map k) where rnfShape (ShapeMap set) = rnf set +instance (Ord k) => Indexed (Map k) where + type Index (Map k) = k + indices (ShapeMap set) = Set.toAscList set + unifiedSizeOffset (ShapeMap set) = Shape.unifiedSizeOffset set + instance (Ord k) => C (NonEmptyMap.T k) where data Shape (NonEmptyMap.T k) = ShapeNonEmptyMap (NonEmptySet.T k) deriving (Show) @@ -149,3 +184,10 @@ instance (NFData k, Ord k) => NFShape (NonEmptyMap.T k) where rnfShape (ShapeNonEmptyMap set) = rnf set + +instance (Ord k) => Indexed (NonEmptyMap.T k) where + type Index (NonEmptyMap.T k) = k + indices (ShapeNonEmptyMap set) = + NonEmpty.flatten $ NonEmptySet.toAscList set + unifiedSizeOffset (ShapeNonEmptyMap set) = + Shape.unifiedSizeOffset (NonEmptySet.flatten set) 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 @@ -1,1094 +1,1976 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module Data.Array.Comfort.Shape ( - C(..), - Indexed(..), - InvIndexed(..), - Static(..), - - Zero(Zero), - ZeroBased(..), zeroBasedSplit, - OneBased(..), - - Range(..), - Shifted(..), - Enumeration(..), - Deferred(..), DeferredIndex(..), deferIndex, revealIndex, - - (:+:)(..), - - Square(..), - Cube(..), - - Triangular(..), Lower(Lower), Upper(Upper), - LowerTriangular, UpperTriangular, - lowerTriangular, upperTriangular, - triangleSize, triangleRoot, - - Cyclic(..), - ) where - -import qualified Data.Array.Comfort.Shape.Set as ShapeSet -import Data.Array.Comfort.Shape.Utility (errorIndexFromOffset) - -import qualified Foreign.Storable.Newtype as Store -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.Trans.State as MS -import qualified Control.Monad.HT as Monad -import qualified Control.Applicative.Backwards as Back -import Control.DeepSeq (NFData, rnf) -import Control.Applicative (Applicative, pure, liftA2, liftA3, (<*>)) -import Control.Applicative (Const(Const, getConst)) - -import qualified Data.Traversable as Trav -import qualified Data.Foldable as Fold -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.NonEmpty as NonEmpty -import qualified Data.List as List -import Data.Functor.Identity (Identity(Identity), runIdentity) -import Data.Function.HT (compose2) -import Data.Tagged (Tagged(Tagged, unTagged)) -import Data.Map (Map) -import Data.Set (Set) -import Data.List.HT (tails) -import Data.Maybe (fromMaybe) -import Data.Tuple.HT (mapSnd, mapPair, swap, fst3, snd3, thd3) -import Data.Eq.HT (equating) - - -{- $setup ->>> import qualified Data.Array.Comfort.Shape as Shape ->>> import qualified Data.Map as Map ->>> import qualified Data.Set as Set ->>> import Data.Array.Comfort.Shape ((:+:)((:+:))) --} - - -class C sh where - -- 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] - -- Ix.index - offset :: sh -> Index sh -> Int - offset sh = snd $ sizeOffset sh - -- Ix.unsafeIndex - uncheckedOffset :: sh -> Index sh -> Int - uncheckedOffset = offset - -- Ix.inRange - inBounds :: sh -> Index sh -> Bool - - sizeOffset :: sh -> (Int, Index sh -> Int) - sizeOffset sh = (size sh, offset sh) - uncheckedSizeOffset :: sh -> (Int, Index sh -> Int) - uncheckedSizeOffset sh = (uncheckedSize sh, uncheckedOffset sh) - -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 - -class (C sh, Eq sh) => Static sh where - static :: sh - - -data Zero = Zero - deriving (Eq, Ord, Show) - -instance C Zero where - size Zero = 0 - uncheckedSize Zero = 0 - -instance Static Zero where - static = Zero - - -instance C () where - size () = 1 - uncheckedSize () = 1 - -{- | ->>> Shape.indices () -[()] --} -instance Indexed () where - type Index () = () - indices () = [()] - offset () () = 0 - uncheckedOffset () () = 0 - inBounds () () = True - -instance InvIndexed () where - indexFromOffset () 0 = () - indexFromOffset () k = errorIndexFromOffset "()" k - uncheckedIndexFromOffset () _ = () - -instance Static () where - static = () - - -{- | -'ZeroBased' denotes a range starting at zero and has a certain length. - ->>> Shape.indices (Shape.ZeroBased (7::Int)) -[0,1,2,3,4,5,6] --} -newtype ZeroBased n = ZeroBased {zeroBasedSize :: n} - deriving (Eq, Show) - -instance Functor ZeroBased where - fmap f (ZeroBased n) = ZeroBased $ f n - -instance Applicative ZeroBased where - pure = ZeroBased - ZeroBased f <*> ZeroBased n = ZeroBased $ f n - -instance (NFData n) => NFData (ZeroBased n) where - rnf (ZeroBased n) = rnf n - -instance (Storable n) => Storable (ZeroBased n) where - sizeOf = Store.sizeOf zeroBasedSize - alignment = Store.alignment zeroBasedSize - peek = Store.peek ZeroBased - poke = Store.poke zeroBasedSize - -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 n -> ZeroBased n -> ZeroBased n :+: ZeroBased n -zeroBasedSplit n (ZeroBased m) = - if n<0 - then error "Shape.zeroBasedSplit: negative number of elements" - else let k = min n m in ZeroBased k :+: ZeroBased (m-k) - - -{- | -'OneBased' denotes a range starting at one and has a certain length. - ->>> Shape.indices (Shape.OneBased (7::Int)) -[1,2,3,4,5,6,7] --} -newtype OneBased n = OneBased {oneBasedSize :: n} - deriving (Eq, Show) - -instance Functor OneBased where - fmap f (OneBased n) = OneBased $ f n - -instance Applicative OneBased where - pure = OneBased - OneBased f <*> OneBased n = OneBased $ f n - -instance (NFData n) => NFData (OneBased n) where - rnf (OneBased n) = rnf n - -instance (Storable n) => Storable (OneBased n) where - sizeOf = Store.sizeOf oneBasedSize - alignment = Store.alignment oneBasedSize - peek = Store.peek OneBased - poke = Store.poke oneBasedSize - -instance (Integral n) => 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>> Shape.indices (Shape.Range (-5) (5::Int)) -[-5,-4,-3,-2,-1,0,1,2,3,4,5] ->>> Shape.indices (Shape.Range (-1,-1) (1::Int,1::Int)) -[(-1,-1),(-1,0),(-1,1),(0,-1),(0,0),(0,1),(1,-1),(1,0),(1,1)] --} -data Range n = Range {rangeFrom, rangeTo :: n} - deriving (Eq, Show) - -instance Functor Range where - fmap f (Range from to) = Range (f from) (f to) - -instance (NFData n) => NFData (Range n) where - rnf (Range from to) = rnf (from,to) - -instance (Ix.Ix n) => 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 - --- 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 #-} - {-# 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. - ->>> Shape.indices (Shape.Shifted (-4) (8::Int)) -[-4,-3,-2,-1,0,1,2,3] --} -data Shifted n = Shifted {shiftedOffset, shiftedSize :: n} - deriving (Eq, Show) - -instance Functor Shifted where - fmap f (Shifted from to) = Shifted (f from) (f to) - -instance (NFData n) => NFData (Shifted n) where - rnf (Shifted from to) = rnf (from,to) - -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 $ - takeWhile ((>0) . fst) $ - zip - (iterate (subtract 1) len) - (iterate (1+) offs) - offset (Shifted offs len) ix = - if ix InvIndexed (Shifted n) where - indexFromOffset (Shifted offs len) k0 = - let k = fromIntegral k0 - in if 0<=k && k 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 - - - -{- | -'Enumeration' denotes a shape of fixed size -that is defined by 'Enum' and 'Bounded' methods. -For correctness it is necessary that the 'Enum' and 'Bounded' instances -are properly implemented. -Automatically derived instances are fine. - ->>> Shape.indices (Shape.Enumeration :: Shape.Enumeration Ordering) -[LT,EQ,GT] --} -data Enumeration n = Enumeration - deriving (Eq, Show) - -instance NFData (Enumeration n) where - rnf Enumeration = () - -instance (Enum n, Bounded n) => C (Enumeration n) where - size = uncheckedSize - uncheckedSize sh = intFromEnum sh maxBound - intFromEnum sh minBound + 1 - -instance (Enum n, Bounded n) => Indexed (Enumeration n) where - type Index (Enumeration n) = n - indices sh = [asEnumType sh minBound .. asEnumType sh maxBound] - offset = uncheckedOffset - uncheckedOffset sh ix = fromEnum ix - intFromEnum sh minBound - inBounds _sh _ix = True - -instance (Enum n, Bounded n) => InvIndexed (Enumeration n) where - indexFromOffset sh k = - if 0<=k && k <= intFromEnum sh maxBound - intFromEnum sh minBound - then uncheckedIndexFromOffset sh k - else errorIndexFromOffset "Enumeration" k - uncheckedIndexFromOffset sh k = toEnum $ intFromEnum sh minBound + k - -asEnumType :: Enumeration n -> n -> n -asEnumType Enumeration = id - -intFromEnum :: (Enum n) => Enumeration n -> n -> Int -intFromEnum Enumeration = fromEnum - -instance (Enum n, Bounded n) => Static (Enumeration n) where - static = Enumeration - -instance Storable (Enumeration n) where - {-# INLINE sizeOf #-} - {-# INLINE alignment #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - sizeOf ~Enumeration = 0 - alignment ~Enumeration = 1 - poke _p Enumeration = return () - peek _p = return Enumeration - - -instance (Ord n) => C (Set n) where - size = uncheckedSize - uncheckedSize = Set.size - -{- | -You can use an arbitrary 'Set' of indices as shape. -The array elements are ordered according to the index order in the 'Set'. - ->>> Shape.indices (Set.fromList "comfort") -"cfmort" --} -instance (Ord n) => Indexed (Set n) where - type Index (Set n) = n - indices = Set.toAscList - offset = ShapeSet.offset - uncheckedOffset = ShapeSet.uncheckedOffset - inBounds = flip Set.member - -instance (Ord n) => InvIndexed (Set n) where - indexFromOffset = ShapeSet.indexFromOffset - uncheckedIndexFromOffset = ShapeSet.uncheckedIndexFromOffset - - -{- | -Concatenate many arrays according to the shapes stored in a 'Map'. --} -instance (Ord k, C shape) => C (Map k shape) where - size = Fold.sum . Map.map size - uncheckedSize = Fold.sum . Map.map uncheckedSize - -{- | -The implementations of 'offset' et.al. -are optimized for frequent calls with respect to the same shape. - ->>> Shape.indices $ fmap Shape.ZeroBased $ Map.fromList [('b', (0::Int)), ('a', 5), ('c', 2)] -[('a',0),('a',1),('a',2),('a',3),('a',4),('c',0),('c',1)] --} -instance (Ord k, Indexed shape) => Indexed (Map k shape) where - type Index (Map k shape) = (k, Index shape) - indices = - Fold.fold . Map.mapWithKey (\k shape -> map ((,) k) $ indices shape) - offset m = - let mu = snd $ Trav.mapAccumL (\l sh -> (l + size sh, (l,sh))) 0 m - in \(k,ix) -> - case Map.lookup k mu of - Nothing -> error "Shape.Map.offset: unknown key" - Just (l,sh) -> l + offset sh ix - uncheckedOffset m = - let mu = - snd $ Trav.mapAccumL (\l sh -> (l + uncheckedSize sh, (l,sh))) 0 m - in \(k,ix) -> - case Map.lookup k mu of - Nothing -> error "Shape.Map.uncheckedOffset: unknown key" - Just (l,sh) -> l + uncheckedOffset sh ix - inBounds m (k,ix) = Fold.any (flip inBounds ix) $ Map.lookup k m - - sizeOffset = mapSizeOffset . Map.map sizeOffset - uncheckedSizeOffset = mapSizeOffset . Map.map uncheckedSizeOffset - -{-# INLINE mapSizeOffset #-} -mapSizeOffset :: (Ord k, Num i) => Map k (i, ix -> i) -> (i, (k, ix) -> i) -mapSizeOffset ms = - (Fold.sum $ Map.map fst ms, - let mu = snd $ Trav.mapAccumL (\l (sz,offs) -> (l + sz, (l+) . offs)) 0 ms - in \(k,ix) -> - fromMaybe (error "Shape.Map.sizeOffset: unknown key") - (Map.lookup k mu) ix) - -instance (Ord k, InvIndexed shape) => InvIndexed (Map k shape) where - indexFromOffset m i = - (\xs -> - case xs of - (_u,ix):_ -> ix - [] -> errorIndexFromOffset "Map" i) $ - dropWhile (\(u,_ix) -> u<=i) $ snd $ - List.mapAccumL - (\l (k,sh) -> - let u = l + size sh - in (u, (u, (k, indexFromOffset sh (i-l))))) 0 $ - Map.toAscList m - - uncheckedIndexFromOffset m i = - (\((_u,ix):_) -> ix) $ - dropWhile (\(u,_ix) -> u<=i) $ snd $ - List.mapAccumL - (\l (k,sh) -> - let u = l + size sh - in (u, (u, (k, uncheckedIndexFromOffset sh (i-l))))) 0 $ - Map.toAscList m - - -{- | -This data type wraps another array shape. -Its index type is a wrapped 'Int'. -The advantages are: -No conversion forth and back 'Int' and @Index sh@. -You can convert once using 'deferIndex' and 'revealIndex' -whenever you need your application specific index type. -No need for e.g. @Storable (Index sh)@, because 'Int' is already 'Storable'. -You get 'Indexed' and 'InvIndexed' instances -without the need for an 'Index' type. -The disadvantage is: -A deferred index should be bound to a specific shape, but this is not checked. -That is, you may obtain a deferred index for one shape -and accidentally abuse it for another shape without a warning. - -Example: - ->>> :{ -let sh2 = (Shape.ZeroBased (2::Int), Shape.ZeroBased (2::Int)) in -let sh3 = (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) in -(Shape.offset sh3 $ Shape.indexFromOffset sh2 3, - Shape.offset (Shape.Deferred sh3) $ - Shape.indexFromOffset (Shape.Deferred sh2) 3) -:} -(4,3) --} -newtype Deferred sh = Deferred sh - deriving (Eq, Show) - -{- | -'DeferredIndex' has an 'Ord' instance -that is based on the storage order in memory. -This way, you can put 'DeferredIndex' values -in a 'Set' or use them as keys in a 'Map' -even if @Index sh@ has no 'Ord' instance. -The downside is, that the ordering of @DeferredIndex sh@ -may differ from the one of @Index sh@. --} -newtype DeferredIndex sh = DeferredIndex Int - deriving (Eq, Ord, Show) - -instance (NFData sh) => NFData (Deferred sh) where - rnf (Deferred sh) = rnf sh - -instance (C sh) => C (Deferred sh) where - size (Deferred sh) = size sh - uncheckedSize (Deferred sh) = uncheckedSize sh - -instance (C sh) => Indexed (Deferred sh) where - type Index (Deferred sh) = DeferredIndex sh - indices (Deferred sh) = map DeferredIndex $ take (size sh) [0 ..] - offset (Deferred sh) (DeferredIndex k) = offset (ZeroBased $ size sh) k - uncheckedOffset _ (DeferredIndex k) = k - sizeOffset (Deferred sh) = - mapSnd (\offs (DeferredIndex k) -> offs k) $ - sizeOffset (ZeroBased $ size sh) - uncheckedSizeOffset (Deferred sh) = - mapSnd (\ _offs (DeferredIndex k) -> k) $ - uncheckedSizeOffset (ZeroBased $ size sh) - inBounds (Deferred sh) (DeferredIndex k) = - inBounds (ZeroBased $ size sh) k - -instance (C sh) => InvIndexed (Deferred sh) where - indexFromOffset (Deferred sh) k = - DeferredIndex $ indexFromOffset (ZeroBased $ size sh) k - uncheckedIndexFromOffset _sh = DeferredIndex - -deferIndex :: (Indexed sh, Index sh ~ ix) => sh -> ix -> DeferredIndex sh -deferIndex sh ix = DeferredIndex $ offset sh ix - -revealIndex :: (InvIndexed sh, Index sh ~ ix) => sh -> DeferredIndex sh -> ix -revealIndex sh (DeferredIndex ix) = indexFromOffset sh ix - -instance (Static sh) => Static (Deferred sh) where - static = Deferred static - -instance Storable (DeferredIndex sh) where - {-# INLINE sizeOf #-} - {-# INLINE alignment #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - sizeOf (DeferredIndex k) = sizeOf k - alignment (DeferredIndex k) = alignment k - poke p (DeferredIndex k) = poke (castPtr p) k - peek p = fmap DeferredIndex $ peek (castPtr p) - - - -instance (C sh) => C (Tagged s sh) where - size (Tagged sh) = size sh - uncheckedSize (Tagged sh) = uncheckedSize sh - -instance (Indexed sh) => Indexed (Tagged s sh) where - type Index (Tagged s sh) = Tagged s (Index sh) - indices (Tagged sh) = map Tagged $ indices sh - offset (Tagged sh) (Tagged k) = offset sh k - uncheckedOffset (Tagged sh) (Tagged k) = uncheckedOffset sh k - sizeOffset (Tagged sh) = mapSnd (. unTagged) $ sizeOffset sh - uncheckedSizeOffset (Tagged sh) = - mapSnd (. unTagged) $ uncheckedSizeOffset sh - inBounds (Tagged sh) (Tagged k) = inBounds sh k - -instance (InvIndexed sh) => InvIndexed (Tagged s sh) where - indexFromOffset (Tagged sh) k = Tagged $ indexFromOffset sh k - uncheckedIndexFromOffset (Tagged sh) k = - Tagged $ uncheckedIndexFromOffset sh k - -instance (Static sh) => Static (Tagged s sh) where - static = Tagged static - - - -instance (C sh0, C sh1) => C (sh0,sh1) where - size (sh0,sh1) = size sh0 * size sh1 - uncheckedSize (sh0,sh1) = uncheckedSize sh0 * uncheckedSize sh1 - -{- | -Row-major composition of two dimensions. - ->>> Shape.indices (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) -[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)] --} -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) = - offset sh0 . fst - `combineOffset` - mapSnd (.snd) (sizeOffset sh1) - uncheckedOffset (sh0,sh1) = - uncheckedOffset sh0 . fst - `combineOffset` - mapSnd (.snd) (uncheckedSizeOffset sh1) - sizeOffset (sh0,sh1) = - mapSnd (.fst) (sizeOffset sh0) - `combineSizeOffset` - mapSnd (.snd) (sizeOffset sh1) - uncheckedSizeOffset (sh0,sh1) = - mapSnd (.fst) (uncheckedSizeOffset sh0) - `combineSizeOffset` - mapSnd (.snd) (uncheckedSizeOffset sh1) - inBounds (sh0,sh1) (ix0,ix1) = inBounds sh0 ix0 && inBounds sh1 ix1 - -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 (Static sh0, Static sh1) => Static (sh0,sh1) where - static = (static, static) - - -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) - uncheckedOffset (sh0,sh1,sh2) = - uncheckedOffset sh0 . fst3 - `combineOffset` - mapSnd (.snd3) (uncheckedSizeOffset sh1) - `combineSizeOffset` - mapSnd (.thd3) (uncheckedSizeOffset sh2) - sizeOffset (sh0,sh1,sh2) = - mapSnd (.fst3) (sizeOffset sh0) - `combineSizeOffset` - mapSnd (.snd3) (sizeOffset sh1) - `combineSizeOffset` - mapSnd (.thd3) (sizeOffset sh2) - uncheckedSizeOffset (sh0,sh1,sh2) = - mapSnd (.fst3) (uncheckedSizeOffset sh0) - `combineSizeOffset` - mapSnd (.snd3) (uncheckedSizeOffset sh1) - `combineSizeOffset` - mapSnd (.thd3) (uncheckedSizeOffset sh2) - inBounds (sh0,sh1,sh2) (ix0,ix1,ix2) = - inBounds sh0 ix0 && inBounds sh1 ix1 && inBounds sh2 ix2 - -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) - -instance (Static sh0, Static sh1, Static sh2) => Static (sh0,sh1,sh2) where - static = (static, static, static) - -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 #-} -combineOffset :: Num a => (ix -> a) -> (a, ix -> a) -> ix -> a -combineOffset offset0 (size1,offset1) ix = offset0 ix * size1 + offset1 ix - -{-# INLINE combineSizeOffset #-} -combineSizeOffset :: Num a => (a, ix -> a) -> (a, ix -> a) -> (a, ix -> a) -combineSizeOffset (size0,offset0) (size1,offset1) = - (size0*size1, \ix -> offset0 ix * size1 + offset1 ix) - - - -{- | -'Square' is like a Cartesian product, -but it is statically asserted that both dimension shapes match. - ->>> Shape.indices $ Shape.Square $ Shape.ZeroBased (3::Int) -[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)] --} -newtype Square sh = Square {squareSize :: sh} - deriving (Eq, Show) - -instance Functor Square where - fmap f (Square sh) = Square $ f sh - -instance Applicative Square where - pure = Square - Square f <*> Square sh = Square $ f sh - -instance (NFData sh) => NFData (Square sh) where - rnf (Square sh) = rnf sh - -instance (Storable sh) => Storable (Square sh) where - sizeOf = Store.sizeOf squareSize - alignment = Store.alignment squareSize - peek = Store.peek Square - poke = Store.poke squareSize - -instance (C sh) => C (Square sh) where - size (Square sh) = size sh ^ (2::Int) - uncheckedSize (Square sh) = uncheckedSize sh ^ (2::Int) - -instance (Indexed sh) => Indexed (Square sh) where - type Index (Square sh) = (Index sh, Index sh) - indices (Square sh) = indices (sh,sh) - offset (Square sh) = offset (sh,sh) - uncheckedOffset (Square sh) = uncheckedOffset (sh,sh) - sizeOffset (Square sh) = - let szo = sizeOffset sh - in mapSnd (.fst) szo `combineSizeOffset` mapSnd (.snd) szo - uncheckedSizeOffset (Square sh) = - let szo = uncheckedSizeOffset sh - in mapSnd (.fst) szo `combineSizeOffset` mapSnd (.snd) szo - inBounds (Square sh) = inBounds (sh,sh) - -instance (InvIndexed sh) => InvIndexed (Square sh) where - indexFromOffset (Square sh) = indexFromOffset (sh,sh) - uncheckedIndexFromOffset (Square sh) = uncheckedIndexFromOffset (sh,sh) - - - -{- | -'Cube' is like a Cartesian product, -but it is statically asserted that both dimension shapes match. - ->>> Shape.indices $ Shape.Cube $ Shape.ZeroBased (2::Int) -[(0,0,0),(0,0,1),(0,1,0),(0,1,1),(1,0,0),(1,0,1),(1,1,0),(1,1,1)] --} -newtype Cube sh = Cube {cubeSize :: sh} - deriving (Eq, Show) - -instance Functor Cube where - fmap f (Cube sh) = Cube $ f sh - -instance Applicative Cube where - pure = Cube - Cube f <*> Cube sh = Cube $ f sh - -instance (NFData sh) => NFData (Cube sh) where - rnf (Cube sh) = rnf sh - -instance (Storable sh) => Storable (Cube sh) where - sizeOf = Store.sizeOf cubeSize - alignment = Store.alignment cubeSize - peek = Store.peek Cube - poke = Store.poke cubeSize - -instance (C sh) => C (Cube sh) where - size (Cube sh) = size sh ^ (3::Int) - uncheckedSize (Cube sh) = uncheckedSize sh ^ (3::Int) - -instance (Indexed sh) => Indexed (Cube sh) where - type Index (Cube sh) = (Index sh, Index sh, Index sh) - indices (Cube sh) = indices (sh,sh,sh) - offset (Cube sh) = offset (sh,sh,sh) - uncheckedOffset (Cube sh) = uncheckedOffset (sh,sh,sh) - sizeOffset (Cube sh) = - let szo = sizeOffset sh - in mapSnd (.fst3) szo - `combineSizeOffset` - mapSnd (.snd3) szo - `combineSizeOffset` - mapSnd (.thd3) szo - uncheckedSizeOffset (Cube sh) = - let szo = uncheckedSizeOffset sh - in mapSnd (.fst3) szo - `combineSizeOffset` - mapSnd (.snd3) szo - `combineSizeOffset` - mapSnd (.thd3) szo - inBounds (Cube sh) = inBounds (sh,sh,sh) - -instance (InvIndexed sh) => InvIndexed (Cube sh) where - indexFromOffset (Cube sh) = indexFromOffset (sh,sh,sh) - uncheckedIndexFromOffset (Cube sh) = uncheckedIndexFromOffset (sh,sh,sh) - - - -data Lower = Lower deriving (Eq, Show) -data Upper = Upper deriving (Eq, Show) - -class TriangularPart part where - switchTriangularPart :: f Lower -> f Upper -> f part -instance TriangularPart Lower where switchTriangularPart f _ = f -instance TriangularPart Upper where switchTriangularPart _ f = f - -getConstAs :: c -> Const a c -> a -getConstAs _ = getConst - -caseTriangularPart :: (TriangularPart part) => part -> a -> a -> a -caseTriangularPart part lo up = - getConstAs part $ switchTriangularPart (Const lo) (Const up) - -{- | ->>> Shape.indices $ Shape.Triangular Shape.Upper $ Shape.ZeroBased (3::Int) -[(0,0),(0,1),(0,2),(1,1),(1,2),(2,2)] ->>> Shape.indices $ Shape.Triangular Shape.Lower $ Shape.ZeroBased (3::Int) -[(0,0),(1,0),(1,1),(2,0),(2,1),(2,2)] --} -data Triangular part size = - Triangular { - triangularPart :: part, - triangularSize :: size - } deriving (Show) - -newtype Equal part = Equal {getEqual :: part -> part -> Bool} - -equalPart :: (TriangularPart part) => part -> part -> Bool -equalPart = getEqual $ switchTriangularPart (Equal (==)) (Equal (==)) - -instance (TriangularPart part, Eq size) => Eq (Triangular part size) where - x==y = compose2 equalPart triangularPart x y && equating triangularSize x y - -type LowerTriangular = Triangular Lower -type UpperTriangular = Triangular Upper - -lowerTriangular :: size -> LowerTriangular size -lowerTriangular = Triangular Lower - -upperTriangular :: size -> UpperTriangular size -upperTriangular = Triangular Upper - --- cf. Data.Bifunctor.Flip -newtype Flip f b a = Flip {getFlip :: f a b} - -instance - (TriangularPart part, NFData size) => NFData (Triangular part size) where - rnf (Triangular part sz) = - rnf - (flip getFlip part $ - switchTriangularPart (Flip $ \Lower -> ()) (Flip $ \Upper -> ()), - sz) - -instance (TriangularPart part, C size) => C (Triangular part size) where - size (Triangular _part sz) = triangleSize $ size sz - uncheckedSize (Triangular _part sz) = triangleSize $ uncheckedSize sz - -instance - (TriangularPart part, Indexed size) => - Indexed (Triangular part size) where - type Index (Triangular part size) = (Index size, Index size) - - indices (Triangular part sz) = - let ixs = indices sz - in concat $ - caseTriangularPart part - (zipWith (\cs r -> map ((,) r) cs) - (NonEmpty.tail $ NonEmpty.inits ixs) ixs) - (zipWith (\r cs -> map ((,) r) cs) ixs $ tails ixs) - - uncheckedOffset sh = snd $ uncheckedSizeOffset sh - - sizeOffset (Triangular part sz) = - let (n, getOffset) = sizeOffset sz - in (triangleSize n, \(rs,cs) -> - let r = getOffset rs - c = getOffset cs - in if compareIndices part r c - then triangleOffset part n (r,c) - else error "Shape.Triangular.sizeOffset: wrong array part") - - uncheckedSizeOffset (Triangular part sz) = - let (n, getOffset) = uncheckedSizeOffset sz - in (triangleSize n, \(rs,cs) -> - triangleOffset part n (getOffset rs, getOffset cs)) - - inBounds (Triangular part sz) ix@(r,c) = - inBounds (sz,sz) ix - && - let getOffset = offset sz - in compareIndices part (getOffset r) (getOffset c) - -triangleOffset :: TriangularPart part => part -> Int -> (Int, Int) -> Int -triangleOffset part n (r,c) = - caseTriangularPart part - (triangleSize r + c) - (triangleSize n - triangleSize (n-r) + c-r) - -compareIndices :: (TriangularPart part, Ord a) => part -> a -> a -> Bool -compareIndices part = caseTriangularPart part (>=) (<=) - -instance - (TriangularPart part, InvIndexed size) => - InvIndexed (Triangular part size) where - - indexFromOffset (Triangular part sz) k = - mapPair (indexFromOffset sz, indexFromOffset sz) $ - caseTriangularPart part - (let r = floor (triangleRootDouble k) - in (r, k - triangleSize r)) - (let n = size sz - triSize = triangleSize n - rr = ceiling (triangleRootDouble (triSize-k)) - r = n - rr - in (r, k+r - (triSize - triangleSize rr))) - -triangleSize :: Int -> Int -triangleSize n = div (n*(n+1)) 2 - -{- -n*(n+1)/2 = m -n^2 + n - 2m = 0 -n = -1/2 + sqrt(1/4+2m) - = (sqrt(8m+1) - 1) / 2 --} -triangleRoot :: Floating a => a -> a -triangleRoot sz = (sqrt (8*sz+1)-1)/2 - -triangleRootDouble :: Int -> Double -triangleRootDouble = triangleRoot . fromIntegral - - -instance - (TriangularPart part, Static size) => - Static (Triangular part size) where - static = Triangular autoPart static - -autoPart :: (TriangularPart part) => part -autoPart = runIdentity $ switchTriangularPart (Identity Lower) (Identity Upper) - - - -{- | -'Cyclic' is a shape, where the indices wrap around at the array boundaries. -E.g. - -prop> let shape = Shape.Cyclic (10::Int) in Shape.offset shape (-1) == Shape.offset shape 9 - -This also means that there are multiple indices -that address the same array element. - ->>> Shape.indices (Shape.Cyclic (7::Int)) -[0,1,2,3,4,5,6] --} -newtype Cyclic n = Cyclic {cyclicSize :: n} - deriving (Eq, Show) - -instance Functor Cyclic where - fmap f (Cyclic n) = Cyclic $ f n - -instance Applicative Cyclic where - pure = Cyclic - Cyclic f <*> Cyclic n = Cyclic $ f n - -instance (NFData n) => NFData (Cyclic n) where - rnf (Cyclic n) = rnf n - -instance (Storable n) => Storable (Cyclic n) where - sizeOf = Store.sizeOf cyclicSize - alignment = Store.alignment cyclicSize - peek = Store.peek Cyclic - poke = Store.poke cyclicSize - -instance (Integral n) => C (Cyclic n) where - size (Cyclic len) = fromIntegral len - uncheckedSize (Cyclic len) = fromIntegral len - -instance (Integral n) => Indexed (Cyclic n) where - type Index (Cyclic n) = n - indices (Cyclic len) = indices $ ZeroBased len - offset = uncheckedOffset - uncheckedOffset (Cyclic len) ix = fromIntegral $ mod ix len - inBounds (Cyclic len) _ix = len>0 - -instance (Integral n) => InvIndexed (Cyclic n) where - indexFromOffset (Cyclic len) k0 = - let k = fromIntegral k0 - in if 0<=k && k>> Shape.indices (Shape.ZeroBased (3::Int) :+: Shape.Range 'a' 'c') -[Left 0,Left 1,Left 2,Right 'a',Right 'b',Right 'c'] --} -data sh0:+:sh1 = sh0:+:sh1 - deriving (Eq, Show) - -instance (NFData sh0, NFData sh1) => NFData (sh0:+:sh1) where - rnf (sh0:+:sh1) = rnf (sh0,sh1) - -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 = - 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) = - let (n0, getOffset0) = sizeOffset sh0 - (n1, getOffset1) = sizeOffset sh1 - in (n0+n1, either getOffset0 ((n0+) . getOffset1)) - uncheckedSizeOffset (sh0:+:sh1) = - let (n0, getOffset0) = uncheckedSizeOffset sh0 - (n1, getOffset1) = uncheckedSizeOffset sh1 - in (n0+n1, either getOffset0 ((n0+) . getOffset1)) - 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 - -instance (Static sh0, Static sh1) => Static (sh0:+:sh1) where - static = static:+:static +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE GADTs #-} +module Data.Array.Comfort.Shape ( + C(..), + Indexed(..), + InvIndexed(..), messageIndexFromOffset, assertIndexFromOffset, + Static(..), + Pattern(..), + AppendSemigroup(..), + AppendMonoid(..), + + requireCheck, + CheckSingleton(..), + Checking(..), + Result(..), + runChecked, + runUnchecked, + assert, + throwOrError, + + Zero(Zero), + ZeroBased(..), zeroBasedSplit, + OneBased(..), + + Range(..), + Shifted(..), + Enumeration(..), + Deferred(..), DeferredIndex(..), deferIndex, revealIndex, + + (::+)(..), + + Square(..), cartesianFromSquare, + Cube(..), cartesianFromCube, + + Triangular(..), Lower(Lower), Upper(Upper), + LowerTriangular, UpperTriangular, + lowerTriangular, upperTriangular, + triangleSize, triangleRoot, + + Simplex(..), + SimplexAscending, simplexAscending, + SimplexDescending, simplexDescending, + Ascending, + Descending, + SimplexOrder(..), + SimplexOrderC, + AllDistinct(..), + SomeRepetitive(..), + Collision(..), + CollisionC, + + Cyclic(..), + + NestedTuple(..), + AccessorTuple(..), + StaticTuple(..), + Element(..), + TupleAccessor, + TupleIndex, + + ElementIndex, + ElementTuple(..), + indexTupleFromShape, + + Record(..), + FieldIndex, + indexRecordFromShape, + + Constructed, + ConsIndex, + Construction, + construct, + consIndex, + ) where + +import qualified Data.Array.Comfort.Shape.Set as ShapeSet +import Data.Array.Comfort.Shape.Utility (messageIndexFromOffset, isRight) + +import qualified Foreign.Storable.Newtype as Store +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.Trans.Writer as MW +import qualified Control.Monad.Trans.State as MS +import qualified Control.Monad.HT as Monad +import qualified Control.Applicative.HT as App +import qualified Control.Applicative.Backwards as Back +import Control.DeepSeq (NFData, rnf) +import Control.Monad (liftM) +import Control.Applicative (Applicative, pure, (<*>), (<$>)) +import Control.Applicative (Const(Const, getConst)) +import Control.Functor.HT (void) + +import qualified Data.Functor.Classes as FunctorC +import qualified Data.Traversable as Trav +import qualified Data.Foldable as Fold +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Traversable (Traversable) +import Data.Foldable (Foldable) +import Data.Functor.Identity (Identity(Identity), runIdentity) +import Data.Monoid (Sum(Sum, getSum)) +import Data.Function.HT (compose2) +import Data.Tagged (Tagged(Tagged, unTagged)) +import Data.Complex (Complex((:+)), realPart, imagPart) +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) +import Data.Map (Map) +import Data.Set (Set) +import Data.List.HT (tails) +import Data.Tuple.HT (mapFst, mapSnd, swap, fst3, snd3, thd3) +import Data.Eq.HT (equating) + +import Text.Printf (printf) + + +{- $setup +>>> import qualified Data.Array.Comfort.Shape as Shape +>>> import qualified Data.IntMap as IntMap +>>> import qualified Data.IntSet as IntSet +>>> import qualified Data.Map as Map +>>> import qualified Data.Set as Set +>>> import Data.Array.Comfort.Shape ((::+)((::+))) +>>> +>>> import Test.ChasingBottoms.IsBottom (isBottom) +>>> import Control.DeepSeq (rnf) +-} + + +data Checked +data Unchecked + +class Checking check where + data Result check a + switchCheck :: f Checked -> f Unchecked -> f check + +data CheckSingleton check where + Checked :: CheckSingleton Checked + Unchecked :: CheckSingleton Unchecked + +autoCheck :: (Checking check) => CheckSingleton check +autoCheck = switchCheck Checked Unchecked + +checkFromResult :: (Checking check) => Result check a -> CheckSingleton check +checkFromResult _ = autoCheck + +withCheck :: + (Checking check) => + (CheckSingleton check -> Result check a) -> Result check a +withCheck f = f autoCheck + +requireCheck :: CheckSingleton check -> Result check a -> Result check a +requireCheck _ = id + + +instance Checking Checked where + newtype Result Checked a = CheckedResult {getChecked :: Either String a} + switchCheck f _ = f + +runChecked :: String -> Result Checked a -> a +runChecked name (CheckedResult m) = + either (error . (("Shape." ++ name ++ ": ") ++)) id m + +instance Checking Unchecked where + newtype Result Unchecked a = UncheckedResult {getUnchecked :: a} + switchCheck _ f = f + +runUnchecked :: Result Unchecked a -> a +runUnchecked = getUnchecked + + +throw :: String -> Result Checked a +throw = CheckedResult . Left + +throwOrError :: (Checking check) => String -> Result check a +throwOrError msg = withCheck $ \check -> + case check of + Checked -> throw msg + Unchecked -> error msg + +assert :: (Checking check) => String -> Bool -> Result check () +assert msg cond = withCheck $ \check -> + case check of + Unchecked -> UncheckedResult () + Checked -> if cond then pure () else throw msg + + +instance (Checking check, Eq a) => Eq (Result check a) where + a0 == b0 = + case (checkFromResult a0, a0, b0) of + (Checked, CheckedResult a, CheckedResult b) -> a==b + (Unchecked, UncheckedResult a, UncheckedResult b) -> a==b + +instance (Checking check) => Functor (Result check) where + fmap f m = + case (checkFromResult m, m) of + (Checked, CheckedResult e) -> CheckedResult $ fmap f e + (Unchecked, UncheckedResult a) -> UncheckedResult $ f a + +instance (Checking check) => Applicative (Result check) where + pure a = withCheck $ \check -> + case check of + Checked -> CheckedResult $ Right a + Unchecked -> UncheckedResult a + f<*>a = + case (checkFromResult a, f, a) of + (Checked, CheckedResult ff, CheckedResult fa) -> + CheckedResult $ ff<*>fa + (Unchecked, UncheckedResult xf, UncheckedResult xa) -> + UncheckedResult $ xf xa + +instance (Checking check) => Monad (Result check) where + return = pure + a >>= b = + case (checkFromResult a, a) of + (Checked, CheckedResult e) -> CheckedResult $ getChecked . b =<< e + (Unchecked, UncheckedResult x) -> b x + + +{- | +Shape types, that is, instances of 'C', that are also instance of 'Eq', +must have proper 'Eq' instances, +otherwise evil memory corruption will occur. +At least, it must hold @sh0 == sh1 ==> Shape.size sh0 == Shape.size sh1@. +-} +class C sh where + {- + This is the counterpart to 'Ix.rangeSize'. + We do not support a counterpart to 'Ix.unsafeRangeSize' anymore. + First, there is hardly any speed advantage + of using 'Ix.unsafeRangeSize' instead of 'Ix.rangeSize'. + Second, I do not know of an 'Ix' instance + where 'Ix.rangeSize' and 'Ix.unsafeRangeSize' differ. + -} + size :: sh -> Int + +class C sh => Indexed sh where + {-# MINIMAL indices, (unifiedOffset|unifiedSizeOffset) #-} + type Index sh + -- Ix.range + indices :: sh -> [Index sh] + -- Ix.index + offset :: sh -> Index sh -> Int + offset sh = runChecked "offset" . unifiedOffset sh + -- Ix.unsafeIndex + uncheckedOffset :: sh -> Index sh -> Int + uncheckedOffset sh = getUnchecked . unifiedOffset sh + unifiedOffset :: (Checking check) => sh -> Index sh -> Result check Int + unifiedOffset sh = snd $ unifiedSizeOffset sh + -- Ix.inRange + inBounds :: sh -> Index sh -> Bool + inBounds sh = isRight . getChecked . unifiedOffset sh + + sizeOffset :: sh -> (Int, Index sh -> Int) + sizeOffset sh = (size sh, offset sh) + uncheckedSizeOffset :: sh -> (Int, Index sh -> Int) + uncheckedSizeOffset sh = (size sh, uncheckedOffset sh) + unifiedSizeOffset :: + (Checking check) => sh -> (Int, Index sh -> Result check Int) + unifiedSizeOffset sh = (size sh, unifiedOffset sh) + +class Indexed sh => InvIndexed sh where + {-# MINIMAL unifiedIndexFromOffset #-} + {- | + It should hold @indexFromOffset sh k == indices sh !! k@, + but 'indexFromOffset' should generally be faster. + -} + indexFromOffset :: sh -> Int -> Index sh + indexFromOffset sh = runChecked "indexFromOffset" . unifiedIndexFromOffset sh + uncheckedIndexFromOffset :: sh -> Int -> Index sh + uncheckedIndexFromOffset sh = getUnchecked . unifiedIndexFromOffset sh + unifiedIndexFromOffset :: + (Checking check) => sh -> Int -> Result check (Index sh) + +assertIndexFromOffset :: + (Checking check) => String -> Int -> Bool -> Result check () +assertIndexFromOffset name k cond = assert (messageIndexFromOffset name k) cond + +class (C sh, Eq sh) => Static sh where + static :: sh + +{- +We need superclass Indexed for Index type function. +But this disables the sensible instance Pattern Zero. +-} +class (Indexed sh) => Pattern sh where + type DataPattern sh x + indexPattern :: (Index sh -> x) -> sh -> DataPattern sh x + + + + +{- | +We cannot use 'Semigroup' +because 'Semigroup' instances for '()' and '(a,b)' are already defined in a way, +that is incompatible for our needs. +-} +class (C sh) => AppendSemigroup sh where + append :: sh -> sh -> sh + +class (AppendSemigroup sh) => AppendMonoid sh where + empty :: sh + + +data Zero = Zero + deriving (Eq, Ord, Show) + +instance C Zero where + size Zero = 0 + +instance Static Zero where + static = Zero + +{- +missing superclass Indexed + +instance Pattern Zero where + type DataPattern Zero x = () + indexPattern _ Zero = () +-} + +instance AppendSemigroup Zero where + append Zero Zero = Zero + +instance AppendMonoid Zero where + empty = Zero + + +instance C () where + size () = 1 + +{- | +>>> Shape.indices () +[()] +-} +instance Indexed () where + type Index () = () + indices () = [()] + unifiedOffset () () = pure 0 + inBounds () () = True + +instance InvIndexed () where + unifiedIndexFromOffset () k = assertIndexFromOffset "()" k (k==0) + +instance Static () where + static = () + +instance Pattern () where + type DataPattern () x = x + indexPattern extend = extend + + +{- | +'ZeroBased' denotes a range starting at zero and has a certain length. + +>>> Shape.indices (Shape.ZeroBased (7::Int)) +[0,1,2,3,4,5,6] +-} +newtype ZeroBased n = ZeroBased {zeroBasedSize :: n} + deriving (Eq, Show) + +instance Functor ZeroBased where + fmap f (ZeroBased n) = ZeroBased $ f n + +instance Applicative ZeroBased where + pure = ZeroBased + ZeroBased f <*> ZeroBased n = ZeroBased $ f n + +instance (NFData n) => NFData (ZeroBased n) where + rnf (ZeroBased n) = rnf n + +instance (Storable n) => Storable (ZeroBased n) where + sizeOf = Store.sizeOf zeroBasedSize + alignment = Store.alignment zeroBasedSize + peek = Store.peek ZeroBased + poke = Store.poke zeroBasedSize + +instance (Integral n) => C (ZeroBased n) where + size (ZeroBased len) = fromIntegral len + +instance (Integral n) => Indexed (ZeroBased n) where + type Index (ZeroBased n) = n + indices (ZeroBased len) = takeWhile ( InvIndexed (ZeroBased n) where + unifiedIndexFromOffset (ZeroBased len) k0 = do + let k = fromIntegral k0 + assertIndexFromOffset "ZeroBased" k0 $ 0<=k && k n -> ZeroBased n -> ZeroBased n ::+ ZeroBased n +zeroBasedSplit n (ZeroBased m) = + if n<0 + then error "Shape.zeroBasedSplit: negative number of elements" + else let k = min n m in ZeroBased k ::+ ZeroBased (m-k) + +instance (Integral n) => AppendSemigroup (ZeroBased n) where + append (ZeroBased n) (ZeroBased m) = ZeroBased (n+m) + +instance (Integral n) => AppendMonoid (ZeroBased n) where + empty = ZeroBased 0 + + +instance (Integral n) => Pattern (ZeroBased n) where + type DataPattern (ZeroBased n) x = n -> x + indexPattern extend (ZeroBased _n) = extend + + +{- | +'OneBased' denotes a range starting at one and has a certain length. + +>>> Shape.indices (Shape.OneBased (7::Int)) +[1,2,3,4,5,6,7] +-} +newtype OneBased n = OneBased {oneBasedSize :: n} + deriving (Eq, Show) + +instance Functor OneBased where + fmap f (OneBased n) = OneBased $ f n + +instance Applicative OneBased where + pure = OneBased + OneBased f <*> OneBased n = OneBased $ f n + +instance (NFData n) => NFData (OneBased n) where + rnf (OneBased n) = rnf n + +instance (Storable n) => Storable (OneBased n) where + sizeOf = Store.sizeOf oneBasedSize + alignment = Store.alignment oneBasedSize + peek = Store.peek OneBased + poke = Store.poke oneBasedSize + +instance (Integral n) => C (OneBased n) where + size (OneBased len) = fromIntegral len + +instance (Integral n) => Indexed (OneBased n) where + type Index (OneBased n) = n + indices (OneBased len) = takeWhile (<=len) $ iterate (+1) 1 + unifiedOffset (OneBased len) = unifiedOffset $ Shifted 1 len + inBounds (OneBased len) ix = 0 InvIndexed (OneBased n) where + unifiedIndexFromOffset (OneBased len) k0 = do + let k = fromIntegral k0 + assertIndexFromOffset "OneBased" k0 $ 0<=k && k AppendSemigroup (OneBased n) where + append (OneBased n) (OneBased m) = OneBased (n+m) + +instance (Integral n) => AppendMonoid (OneBased n) where + empty = OneBased 0 + + +{- | +'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. + +>>> Shape.indices (Shape.Range (-5) (5::Int)) +[-5,-4,-3,-2,-1,0,1,2,3,4,5] +>>> Shape.indices (Shape.Range (-1,-1) (1::Int,1::Int)) +[(-1,-1),(-1,0),(-1,1),(0,-1),(0,0),(0,1),(1,-1),(1,0),(1,1)] +-} +data Range n = Range {rangeFrom, rangeTo :: n} + deriving (Eq, Show) + +instance Functor Range where + fmap f (Range from to) = Range (f from) (f to) + +instance (NFData n) => NFData (Range n) where + rnf (Range from to) = rnf (from,to) + +instance (Ix.Ix n) => C (Range n) where + size (Range from to) = Ix.rangeSize (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 + unifiedOffset (Range from to) ix = do + assert "Shape.Range: index out of range" $ Ix.inRange (from,to) ix + return $ Ix.unsafeIndex (from,to) ix + inBounds (Range from to) ix = Ix.inRange (from,to) ix + +-- pretty inefficient when we rely solely on Ix +instance (Ix.Ix n) => InvIndexed (Range n) where + unifiedIndexFromOffset (Range from to) k = do + assertIndexFromOffset "Range" k $ 0<=k && k < Ix.rangeSize (from,to) + return $ Ix.range (from,to) !! k + +-- 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. + +>>> Shape.indices (Shape.Shifted (-4) (8::Int)) +[-4,-3,-2,-1,0,1,2,3] +-} +data Shifted n = Shifted {shiftedOffset, shiftedSize :: n} + deriving (Eq, Show) + +instance Functor Shifted where + fmap f (Shifted from to) = Shifted (f from) (f to) + +instance (NFData n) => NFData (Shifted n) where + rnf (Shifted from to) = rnf (from,to) + +instance (Integral n) => C (Shifted n) where + size (Shifted _offs len) = fromIntegral len + +instance (Integral n) => Indexed (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) + unifiedOffset (Shifted offs len) ix = do + assert + (printf "Shape.Shifted %d: array index too small (%d vs %d)" + (toInteger offs) (toInteger offs) (toInteger ix)) + (ix>=offs) + let k = ix-offs + assert + (printf "Shape.Shifted %d: array index too big (%d vs %d)" + (toInteger offs) (toInteger k) (toInteger len)) + (k InvIndexed (Shifted n) where + unifiedIndexFromOffset (Shifted offs len) k0 = do + let k = fromIntegral k0 + assertIndexFromOffset "Shifted" k0 $ 0<=k && k 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 + + + +{- | +'Enumeration' denotes a shape of fixed size +that is defined by 'Enum' and 'Bounded' methods. +For correctness it is necessary that the 'Enum' and 'Bounded' instances +are properly implemented. +Automatically derived instances are fine. + +>>> Shape.indices (Shape.Enumeration :: Shape.Enumeration Ordering) +[LT,EQ,GT] +-} +data Enumeration n = Enumeration + deriving (Eq, Show) + +instance NFData (Enumeration n) where + rnf Enumeration = () + +instance (Enum n, Bounded n) => C (Enumeration n) where + size sh = intFromEnum sh maxBound - intFromEnum sh minBound + 1 + +instance (Enum n, Bounded n) => Indexed (Enumeration n) where + type Index (Enumeration n) = n + indices sh = [asEnumType sh minBound .. asEnumType sh maxBound] + unifiedOffset sh ix = pure $ fromEnum ix - intFromEnum sh minBound + inBounds _sh _ix = True + +instance (Enum n, Bounded n) => InvIndexed (Enumeration n) where + unifiedIndexFromOffset sh k = do + let minBnd = intFromEnum sh minBound + assertIndexFromOffset "Enumeration" k $ + 0<=k && k <= intFromEnum sh maxBound - minBnd + return $ toEnum $ minBnd + k + +asEnumType :: Enumeration n -> n -> n +asEnumType Enumeration = id + +intFromEnum :: (Enum n) => Enumeration n -> n -> Int +intFromEnum Enumeration = fromEnum + +instance (Enum n, Bounded n) => Static (Enumeration n) where + static = Enumeration + +instance Storable (Enumeration n) where + {-# INLINE sizeOf #-} + {-# INLINE alignment #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + sizeOf ~Enumeration = 0 + alignment ~Enumeration = 1 + poke _p Enumeration = return () + peek _p = return Enumeration + + +instance (Ord n) => C (Set n) where + size = Set.size + +{- | +You can use an arbitrary 'Set' of indices as shape. +The array elements are ordered according to the index order in the 'Set'. + +An @Array (Set k) a@ is isomorphic to a @Map k a@, +however it is missing most 'Map' operations like @insert@, @delete@ and @union@. +An @Array (Set k, Set j) a@ has a cartesian structure +and thus is not isomorphic to @Map (k,j) a@. +This means, if the array has two elements with indices @(k0,j0)@ and @(k1,j1)@ +it has also an element with index @(k0,j1)@. + +Disadvantage is that combinators of different Set indexed arrays +have to compare whole sets. +However, the Set implementation may have low-level optimizations +for pointer equality. + +>>> Shape.indices (Set.fromList "comfort") +"cfmort" +-} +instance (Ord n) => Indexed (Set n) where + type Index (Set n) = n + indices = Set.toAscList + unifiedOffset sh ix = withCheck $ \check -> + case check of + Unchecked -> pure $ ShapeSet.uncheckedOffset sh ix + Checked -> + case ShapeSet.offset sh ix of + Just k -> pure k + Nothing -> + throw "Shape.Set: array index not member of the index set" + inBounds = flip Set.member + +instance (Ord n) => InvIndexed (Set n) where + unifiedIndexFromOffset sh k = withCheck $ \check -> + case check of + Unchecked -> pure $ ShapeSet.uncheckedIndexFromOffset sh k + Checked -> + case ShapeSet.indexFromOffset sh k of + Just ix -> pure ix + Nothing -> throw $ messageIndexFromOffset "Set" k + + + +instance C IntSet where + size = IntSet.size + +{- | +>>> Shape.indices (IntSet.fromList [3,1,4,1,5,9,2,6,5,3]) +[1,2,3,4,5,6,9] +-} +instance Indexed IntSet where + type Index IntSet = Int + indices = IntSet.toAscList + unifiedOffset set ix = + case IntSet.splitMember ix set of + (less, hit, _) -> do + assert "Shape.IntSet: array index not member of the index set" hit + pure $ IntSet.size less + inBounds = flip IntSet.member + +instance InvIndexed IntSet where + unifiedIndexFromOffset sh = + let m = IntMap.fromList $ zip [0..] $ indices sh + in \k -> + case IntMap.lookup k m of + Nothing -> throwOrError "Shape.IntSet.offset: unknown key" + Just ix -> pure ix + + + +{- | +Concatenate many arrays according to the shapes stored in a 'Map'. +-} +instance (Ord k, C shape) => C (Map k shape) where + size = Fold.sum . Map.map size + +{- | +The implementations of 'offset' et.al. +are optimized for frequent calls with respect to the same shape. + +>>> Shape.indices $ fmap Shape.ZeroBased $ Map.fromList [('b', (0::Int)), ('a', 5), ('c', 2)] +[('a',0),('a',1),('a',2),('a',3),('a',4),('c',0),('c',1)] +-} +instance (Ord k, Indexed shape) => Indexed (Map k shape) where + type Index (Map k shape) = (k, Index shape) + indices = + Fold.fold . Map.mapWithKey (\k shape -> map ((,) k) $ indices shape) + unifiedOffset m = + let ms = fmap unifiedSizeOffset m + mu = snd $ + Trav.mapAccumL (\l (sz,getOffset) -> (l + sz, (l,getOffset))) 0 ms + in \(k,ix) -> + case Map.lookup k mu of + Nothing -> throwOrError "Shape.Map.offset: unknown key" + Just (l,getOffset) -> (l+) <$> getOffset ix + inBounds m (k,ix) = Fold.any (flip inBounds ix) $ Map.lookup k m + + unifiedSizeOffset = mapSizeOffset . fmap unifiedSizeOffset + +{-# INLINE mapSizeOffset #-} +mapSizeOffset :: + (Checking check, Ord k, Num i) => + Map k (i, ix -> Result check i) -> (i, (k, ix) -> Result check i) +mapSizeOffset ms = + (Fold.sum $ Map.map fst ms, + let mu = snd $ + Trav.mapAccumL (\l (sz,offs) -> (l + sz, fmap (l+) . offs)) 0 ms + in \(k,ix) -> + maybe + (throwOrError "Shape.Map.sizeOffset: unknown key") + ($ix) + (Map.lookup k mu)) + +instance (Ord k, InvIndexed shape) => InvIndexed (Map k shape) where + unifiedIndexFromOffset m i = + (\xs -> + case xs of + (_u,ix):_ -> ix + [] -> throwOrError $ messageIndexFromOffset "Map" i) $ + dropWhile (\(u,_ix) -> u<=i) $ snd $ + List.mapAccumL + (\l (k,sh) -> + let u = l + size sh + in (u, (u, (,) k <$> unifiedIndexFromOffset sh (i-l)))) 0 $ + Map.toAscList m + + + +{- | +Concatenate many arrays according to the shapes stored in a 'IntMap'. +-} +instance (C shape) => C (IntMap shape) where + size = Fold.sum . IntMap.map size + +{- | +The implementations of 'offset' et.al. +are optimized for frequent calls with respect to the same shape. + +>>> Shape.indices $ IntMap.fromList [(2, Set.fromList "abc"), (0, Set.fromList "a"), (1, Set.fromList "d")] +[(0,'a'),(1,'d'),(2,'a'),(2,'b'),(2,'c')] +-} +instance (Indexed shape) => Indexed (IntMap shape) where + type Index (IntMap shape) = (Int, Index shape) + indices = + Fold.fold . IntMap.mapWithKey (\k shape -> map ((,) k) $ indices shape) + unifiedOffset m = + let ms = fmap unifiedSizeOffset m + mu = snd $ + Trav.mapAccumL (\l (sz,getOffset) -> (l + sz, (l,getOffset))) 0 ms + in \(k,ix) -> + case IntMap.lookup k mu of + Nothing -> throwOrError "Shape.IntMap.offset: unknown key" + Just (l,getOffset) -> (l+) <$> getOffset ix + inBounds m (k,ix) = Fold.any (flip inBounds ix) $ IntMap.lookup k m + + unifiedSizeOffset = intMapSizeOffset . fmap unifiedSizeOffset + +{-# INLINE intMapSizeOffset #-} +intMapSizeOffset :: + (Checking check, Num i) => + IntMap (i, ix -> Result check i) -> (i, (Int, ix) -> Result check i) +intMapSizeOffset ms = + (Fold.sum $ IntMap.map fst ms, + let mu = snd $ + Trav.mapAccumL (\l (sz,offs) -> (l + sz, fmap (l+) . offs)) 0 ms + in \(k,ix) -> + maybe + (throwOrError "Shape.IntMap.sizeOffset: unknown key") + ($ix) + (IntMap.lookup k mu)) + +-- ToDo: can be sped up using IntMap.lookupLT for containers>=0.5 +instance (InvIndexed shape) => InvIndexed (IntMap shape) where + unifiedIndexFromOffset m i = + (\xs -> + case xs of + (_u,ix):_ -> ix + [] -> throwOrError $ messageIndexFromOffset "IntMap" i) $ + dropWhile (\(u,_ix) -> u<=i) $ snd $ + List.mapAccumL + (\l (k,sh) -> + let u = l + size sh + in (u, (u, (,) k <$> unifiedIndexFromOffset sh (i-l)))) 0 $ + IntMap.toAscList m + + + +{- | +This data type wraps another array shape. +Its index type is a wrapped 'Int'. +The advantages are: +No conversion forth and back 'Int' and @Index sh@. +You can convert once using 'deferIndex' and 'revealIndex' +whenever you need your application specific index type. +No need for e.g. @Storable (Index sh)@, because 'Int' is already 'Storable'. +You get 'Indexed' and 'InvIndexed' instances +without the need for an 'Index' type. +The disadvantage is: +A deferred index should be bound to a specific shape, but this is not checked. +That is, you may obtain a deferred index for one shape +and accidentally abuse it for another shape without a warning. + +Example: + +>>> :{ + let sh2 = (Shape.ZeroBased (2::Int), Shape.ZeroBased (2::Int)) in + let sh3 = (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) in + (Shape.offset sh3 $ Shape.indexFromOffset sh2 3, + Shape.offset (Shape.Deferred sh3) $ + Shape.indexFromOffset (Shape.Deferred sh2) 3) +:} +(4,3) +-} +newtype Deferred sh = Deferred sh + deriving (Eq, Show) + +{- | +'DeferredIndex' has an 'Ord' instance +that is based on the storage order in memory. +This way, you can put 'DeferredIndex' values +in a 'Set' or use them as keys in a 'Map' +even if @Index sh@ has no 'Ord' instance. +The downside is, that the ordering of @DeferredIndex sh@ +may differ from the one of @Index sh@. +-} +newtype DeferredIndex sh = DeferredIndex Int + deriving (Eq, Ord, Show) + +instance (NFData sh) => NFData (Deferred sh) where + rnf (Deferred sh) = rnf sh + +instance (C sh) => C (Deferred sh) where + size (Deferred sh) = size sh + +instance (C sh) => Indexed (Deferred sh) where + type Index (Deferred sh) = DeferredIndex sh + indices (Deferred sh) = map DeferredIndex $ take (size sh) [0 ..] + unifiedOffset (Deferred sh) (DeferredIndex k) = withCheck $ \check -> + case check of + Checked -> unifiedOffset (ZeroBased $ size sh) k + Unchecked -> pure k + unifiedSizeOffset (Deferred sh) = + mapSnd (\offs (DeferredIndex k) -> offs k) $ + unifiedSizeOffset (ZeroBased $ size sh) + inBounds (Deferred sh) (DeferredIndex k) = + inBounds (ZeroBased $ size sh) k + +instance (C sh) => InvIndexed (Deferred sh) where + indexFromOffset (Deferred sh) k = + DeferredIndex $ indexFromOffset (ZeroBased $ size sh) k + uncheckedIndexFromOffset _sh = DeferredIndex + unifiedIndexFromOffset (Deferred sh) k = withCheck $ \check -> + case check of + Unchecked -> pure $ DeferredIndex k + Checked -> + DeferredIndex <$> unifiedIndexFromOffset (ZeroBased $ size sh) k + +deferIndex :: (Indexed sh, Index sh ~ ix) => sh -> ix -> DeferredIndex sh +deferIndex sh ix = DeferredIndex $ offset sh ix + +revealIndex :: (InvIndexed sh, Index sh ~ ix) => sh -> DeferredIndex sh -> ix +revealIndex sh (DeferredIndex ix) = indexFromOffset sh ix + +instance (Static sh) => Static (Deferred sh) where + static = Deferred static + +instance Storable (DeferredIndex sh) where + {-# INLINE sizeOf #-} + {-# INLINE alignment #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + sizeOf (DeferredIndex k) = sizeOf k + alignment (DeferredIndex k) = alignment k + poke p (DeferredIndex k) = poke (castPtr p) k + peek p = fmap DeferredIndex $ peek (castPtr p) + + + +instance (C sh) => C (Tagged s sh) where + size (Tagged sh) = size sh + +instance (Indexed sh) => Indexed (Tagged s sh) where + type Index (Tagged s sh) = Tagged s (Index sh) + indices (Tagged sh) = map Tagged $ indices sh + unifiedOffset (Tagged sh) = unifiedOffset sh . unTagged + unifiedSizeOffset (Tagged sh) = + mapSnd (. unTagged) $ unifiedSizeOffset sh + inBounds (Tagged sh) (Tagged k) = inBounds sh k + +instance (InvIndexed sh) => InvIndexed (Tagged s sh) where + unifiedIndexFromOffset (Tagged sh) k = + Tagged <$> unifiedIndexFromOffset sh k + +instance (Static sh) => Static (Tagged s sh) where + static = Tagged static + +instance (Pattern sh) => Pattern (Tagged s sh) where + type DataPattern (Tagged s sh) x = DataPattern sh x + indexPattern extend (Tagged sh) = indexPattern (extend . Tagged) sh + + + +instance (C sh0, C sh1) => C (sh0,sh1) where + size (sh0,sh1) = size sh0 * size sh1 + +{- | +Row-major composition of two dimensions. + +>>> Shape.indices (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) +[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)] +-} +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) + unifiedOffset (sh0,sh1) = + (unifiedOffset sh0 . fst) + `combineOffset` + (mapSnd (.snd) $ unifiedSizeOffset sh1) + unifiedSizeOffset (sh0,sh1) = + (mapSnd (.fst) $ unifiedSizeOffset sh0) + `combineSizeOffset` + (mapSnd (.snd) $ unifiedSizeOffset sh1) + inBounds (sh0,sh1) (ix0,ix1) = inBounds sh0 ix0 && inBounds sh1 ix1 + +instance (InvIndexed sh0, InvIndexed sh1) => InvIndexed (sh0,sh1) where + unifiedIndexFromOffset (sh0,sh1) k = do + let (rix0,ix1) = + runInvIndex k $ App.lift2 (,) (pickLastIndex sh0) (pickIndex sh1) + ix0 <- rix0 + return (ix0,ix1) + +instance (Static sh0, Static sh1) => Static (sh0,sh1) where + static = (static, static) + +instance + (AppendSemigroup sh0, C sh1, Eq sh1) => + AppendSemigroup (sh0,sh1) where + append (sh0a,sh1a) (sh0b,sh1b) = + if sh1a == sh1b + then (append sh0a sh0b, sh1a) + else error $ "Shape.append: column shapes mismatch" + +instance (Pattern sh0, Pattern sh1) => Pattern (sh0,sh1) where + type DataPattern (sh0,sh1) x = PatternRecord sh0 (DataPattern sh1 x) + indexPattern extend (sh0,sh1) = + PatternRecord $ + indexPattern (\i -> indexPattern (\j -> extend (i,j)) sh1) sh0 + + +instance (C sh0, C sh1, C sh2) => C (sh0,sh1,sh2) where + size (sh0,sh1,sh2) = size sh0 * size sh1 * size 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) + unifiedOffset (sh0,sh1,sh2) = + (unifiedOffset sh0 . fst3) + `combineOffset` + (mapSnd (.snd3) $ unifiedSizeOffset sh1) + `combineSizeOffset` + (mapSnd (.thd3) $ unifiedSizeOffset sh2) + unifiedSizeOffset (sh0,sh1,sh2) = + (mapSnd (.fst3) $ unifiedSizeOffset sh0) + `combineSizeOffset` + (mapSnd (.snd3) $ unifiedSizeOffset sh1) + `combineSizeOffset` + (mapSnd (.thd3) $ unifiedSizeOffset sh2) + inBounds (sh0,sh1,sh2) (ix0,ix1,ix2) = + inBounds sh0 ix0 && inBounds sh1 ix1 && inBounds sh2 ix2 + +instance + (InvIndexed sh0, InvIndexed sh1, InvIndexed sh2) => + InvIndexed (sh0,sh1,sh2) where + unifiedIndexFromOffset (sh0,sh1,sh2) k = do + let (rix0,ix1,ix2) = + runInvIndex k $ + App.lift3 (,,) (pickLastIndex sh0) (pickIndex sh1) (pickIndex sh2) + ix0 <- rix0 + return (ix0,ix1,ix2) + +instance (Static sh0, Static sh1, Static sh2) => Static (sh0,sh1,sh2) where + static = (static, static, static) + +instance + (AppendSemigroup sh0, C sh1, Eq sh1, C sh2, Eq sh2) => + AppendSemigroup (sh0,sh1,sh2) where + append (sh0a,sh1a,sh2a) (sh0b,sh1b,sh2b) = + if sh1a == sh1b && sh2a == sh2b + then (append sh0a sh0b, sh1a, sh2a) + else error $ "Shape.append: column shapes mismatch" + +runInvIndex :: s -> Back.Backwards (MS.State s) a -> a +runInvIndex k = flip MS.evalState k . Back.forwards + +pickLastIndex :: + (Checking check, InvIndexed sh) => + sh -> Back.Backwards (MS.State Int) (Result check (Index sh)) +pickLastIndex sh = + Back.Backwards $ MS.gets $ unifiedIndexFromOffset 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 #-} +combineOffset :: + (Applicative f, Num a) => + (ix -> f a) -> (a, ix -> f a) -> (ix -> f a) +combineOffset offset0 (size1,offset1) ix = + offset0 ix |* size1 |+| offset1 ix + +{-# INLINE combineSizeOffset #-} +combineSizeOffset :: + (Applicative f, Num a) => + (a, ix -> f a) -> (a, ix -> f a) -> (a, ix -> f a) +combineSizeOffset (size0,offset0) (size1,offset1) = + (size0*size1, \ix -> offset0 ix |* size1 |+| offset1 ix) + + + +{- | +'Square' is like a Cartesian product, +but it is statically asserted that both dimension shapes match. + +>>> Shape.indices $ Shape.Square $ Shape.ZeroBased (3::Int) +[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)] +-} +newtype Square sh = Square {squareSize :: sh} + deriving (Eq, Show) + +cartesianFromSquare :: Square sh -> (sh,sh) +cartesianFromSquare (Square sh) = (sh,sh) + +instance Functor Square where + fmap f (Square sh) = Square $ f sh + +instance Applicative Square where + pure = Square + Square f <*> Square sh = Square $ f sh + +instance (NFData sh) => NFData (Square sh) where + rnf (Square sh) = rnf sh + +instance (Storable sh) => Storable (Square sh) where + sizeOf = Store.sizeOf squareSize + alignment = Store.alignment squareSize + peek = Store.peek Square + poke = Store.poke squareSize + +instance (C sh) => C (Square sh) where + size (Square sh) = size sh ^ (2::Int) + +instance (Indexed sh) => Indexed (Square sh) where + type Index (Square sh) = (Index sh, Index sh) + indices (Square sh) = indices (sh,sh) + unifiedSizeOffset (Square sh) = + let szo = unifiedSizeOffset sh + in mapSnd (.fst) szo `combineSizeOffset` mapSnd (.snd) szo + inBounds (Square sh) = inBounds (sh,sh) + +instance (InvIndexed sh) => InvIndexed (Square sh) where + unifiedIndexFromOffset (Square sh) = + unifiedIndexFromOffset (sh,sh) + +newtype PatternRecord sh a = PatternRecord (DataPattern sh a) + +instance (Pattern sh) => Pattern (Square sh) where + -- Would require UndecidableInstances + -- type DataPattern (Square sh) x = DataPattern sh (DataPattern sh x) + + type DataPattern (Square sh) x = PatternRecord sh (DataPattern sh x) + indexPattern extend (Square sh) = + PatternRecord $ + indexPattern (\i -> indexPattern (\j -> extend (i,j)) sh) sh + + + +{- | +'Cube' is like a Cartesian product, +but it is statically asserted that both dimension shapes match. + +>>> Shape.indices $ Shape.Cube $ Shape.ZeroBased (2::Int) +[(0,0,0),(0,0,1),(0,1,0),(0,1,1),(1,0,0),(1,0,1),(1,1,0),(1,1,1)] +-} +newtype Cube sh = Cube {cubeSize :: sh} + deriving (Eq, Show) + +cartesianFromCube :: Cube sh -> (sh,sh,sh) +cartesianFromCube (Cube sh) = (sh,sh,sh) + +instance Functor Cube where + fmap f (Cube sh) = Cube $ f sh + +instance Applicative Cube where + pure = Cube + Cube f <*> Cube sh = Cube $ f sh + +instance (NFData sh) => NFData (Cube sh) where + rnf (Cube sh) = rnf sh + +instance (Storable sh) => Storable (Cube sh) where + sizeOf = Store.sizeOf cubeSize + alignment = Store.alignment cubeSize + peek = Store.peek Cube + poke = Store.poke cubeSize + +instance (C sh) => C (Cube sh) where + size (Cube sh) = size sh ^ (3::Int) + +instance (Indexed sh) => Indexed (Cube sh) where + type Index (Cube sh) = (Index sh, Index sh, Index sh) + indices (Cube sh) = indices (sh,sh,sh) + unifiedSizeOffset (Cube sh) = + let szo = unifiedSizeOffset sh + in mapSnd (.fst3) szo + `combineSizeOffset` + mapSnd (.snd3) szo + `combineSizeOffset` + mapSnd (.thd3) szo + inBounds (Cube sh) = inBounds (sh,sh,sh) + +instance (InvIndexed sh) => InvIndexed (Cube sh) where + unifiedIndexFromOffset (Cube sh) = + unifiedIndexFromOffset (sh,sh,sh) + + + +data Lower = Lower deriving (Eq, Show) +data Upper = Upper deriving (Eq, Show) + +class TriangularPart part where + switchTriangularPart :: f Lower -> f Upper -> f part +instance TriangularPart Lower where switchTriangularPart f _ = f +instance TriangularPart Upper where switchTriangularPart _ f = f + +getConstAs :: c -> Const a c -> a +getConstAs _ = getConst + +caseTriangularPart :: (TriangularPart part) => part -> a -> a -> a +caseTriangularPart part lo up = + getConstAs part $ switchTriangularPart (Const lo) (Const up) + +{- | +>>> Shape.indices $ Shape.Triangular Shape.Upper $ Shape.ZeroBased (3::Int) +[(0,0),(0,1),(0,2),(1,1),(1,2),(2,2)] +>>> Shape.indices $ Shape.Triangular Shape.Lower $ Shape.ZeroBased (3::Int) +[(0,0),(1,0),(1,1),(2,0),(2,1),(2,2)] +-} +data Triangular part size = + Triangular { + triangularPart :: part, + triangularSize :: size + } deriving (Show) + +newtype Equal part = Equal {getEqual :: part -> part -> Bool} + +equalPart :: (TriangularPart part) => part -> part -> Bool +equalPart = getEqual $ switchTriangularPart (Equal (==)) (Equal (==)) + +instance (TriangularPart part, Eq size) => Eq (Triangular part size) where + x==y = compose2 equalPart triangularPart x y && equating triangularSize x y + +type LowerTriangular = Triangular Lower +type UpperTriangular = Triangular Upper + +lowerTriangular :: size -> LowerTriangular size +lowerTriangular = Triangular Lower + +upperTriangular :: size -> UpperTriangular size +upperTriangular = Triangular Upper + +-- cf. Data.Bifunctor.Flip +newtype Flip f b a = Flip {getFlip :: f a b} + +instance + (TriangularPart part, NFData size) => NFData (Triangular part size) where + rnf (Triangular part sz) = + rnf + (flip getFlip part $ + switchTriangularPart (Flip $ \Lower -> ()) (Flip $ \Upper -> ()), + sz) + +instance (TriangularPart part, C size) => C (Triangular part size) where + size (Triangular _part sz) = triangleSize $ size sz + +instance + (TriangularPart part, Indexed size) => + Indexed (Triangular part size) where + type Index (Triangular part size) = (Index size, Index size) + + indices (Triangular part sz) = + let ixs = indices sz + in concat $ + caseTriangularPart part + (zipWith (\cs r -> map ((,) r) cs) + (NonEmpty.tail $ NonEmpty.inits ixs) ixs) + (zipWith (\r cs -> map ((,) r) cs) ixs $ tails ixs) + + unifiedSizeOffset (Triangular part sz) = + let (n, getOffset) = unifiedSizeOffset sz + in (triangleSize n, \(rs,cs) -> do + r <- getOffset rs + c <- getOffset cs + assert "Shape.Triangular.sizeOffset: wrong array part" $ + compareIndices part r c + return $ triangleOffset part n (r,c)) + + inBounds (Triangular part sz) ix@(r,c) = + inBounds (sz,sz) ix + && + let getOffset = offset sz + in compareIndices part (getOffset r) (getOffset c) + +triangleOffset :: TriangularPart part => part -> Int -> (Int, Int) -> Int +triangleOffset part n (r,c) = + caseTriangularPart part + (triangleSize r + c) + (triangleSize n - triangleSize (n-r) + c-r) + +compareIndices :: (TriangularPart part, Ord a) => part -> a -> a -> Bool +compareIndices part = caseTriangularPart part (>=) (<=) + +instance + (TriangularPart part, InvIndexed size) => + InvIndexed (Triangular part size) where + + unifiedIndexFromOffset (Triangular part sz) k = + let n = size sz in + App.mapPair (unifiedIndexFromOffset sz, unifiedIndexFromOffset sz) $ + caseTriangularPart part + (let r = floor (triangleRootDouble k) + in (r, k - triangleSize r)) + (let triSize = triangleSize n + rr = ceiling (triangleRootDouble (triSize-k)) + r = n - rr + in (r, k+r - (triSize - triangleSize rr))) + +triangleSize :: Int -> Int +triangleSize n = div (n*(n+1)) 2 + +{- +n*(n+1)/2 = m +n^2 + n - 2m = 0 +n = -1/2 + sqrt(1/4+2m) + = (sqrt(8m+1) - 1) / 2 +-} +triangleRoot :: Floating a => a -> a +triangleRoot sz = (sqrt (8*sz+1)-1)/2 + +triangleRootDouble :: Int -> Double +triangleRootDouble = triangleRoot . fromIntegral + + +instance + (TriangularPart part, Static size) => + Static (Triangular part size) where + static = Triangular autoPart static + +autoPart :: (TriangularPart part) => part +autoPart = runIdentity $ switchTriangularPart (Identity Lower) (Identity Upper) + + + +{- | +Simplex is a generalization of 'Triangular' to more than two dimensions. +Indices are tuples of fixed size +with elements ordered in ascending, strictly ascending, +descending or strictly descending order. +\"Order\" refers to the index order in 'indices'. +In order to avoid confusion we suggest that the order of 'indices' +is consistent with '<='. + +Obviously, 'offset' implements ranking +and 'indexFromOffset' implements unranking +of combinations (in the combinatorial sense) +with or without repetitions. + +>>> Shape.indices $ Shape.simplexAscending (replicate 3 Shape.AllDistinct) $ Shape.ZeroBased (4::Int) +[[0,1,2],[0,1,3],[0,2,3],[1,2,3]] +>>> Shape.indices $ Shape.simplexAscending (replicate 3 Shape.SomeRepetitive) $ Shape.ZeroBased (3::Int) +[[0,0,0],[0,0,1],[0,0,2],[0,1,1],[0,1,2],[0,2,2],[1,1,1],[1,1,2],[1,2,2],[2,2,2]] +>>> Shape.indices $ Shape.simplexAscending [Shape.Repetitive,Shape.Distinct,Shape.Repetitive] $ Shape.ZeroBased (4::Int) +[[0,0,1],[0,0,2],[0,0,3],[0,1,2],[0,1,3],[0,2,3],[1,1,2],[1,1,3],[1,2,3],[2,2,3]] +>>> Shape.indices $ Shape.simplexAscending [Shape.Repetitive,Shape.Distinct,Shape.Distinct] $ Shape.ZeroBased (4::Int) +[[0,0,1],[0,0,2],[0,0,3],[0,1,2],[0,1,3],[0,2,3],[1,1,2],[1,1,3],[1,2,3],[2,2,3]] + +>>> Shape.indices $ Shape.simplexDescending (replicate 3 Shape.AllDistinct) $ Shape.ZeroBased (4::Int) +[[2,1,0],[3,1,0],[3,2,0],[3,2,1]] +>>> Shape.indices $ Shape.simplexDescending (replicate 3 Shape.SomeRepetitive) $ Shape.ZeroBased (3::Int) +[[0,0,0],[1,0,0],[1,1,0],[1,1,1],[2,0,0],[2,1,0],[2,1,1],[2,2,0],[2,2,1],[2,2,2]] +>>> Shape.indices $ Shape.simplexDescending [Shape.Repetitive,Shape.Distinct,Shape.Repetitive] $ Shape.ZeroBased (4::Int) +[[1,1,0],[2,1,0],[2,2,0],[2,2,1],[3,1,0],[3,2,0],[3,2,1],[3,3,0],[3,3,1],[3,3,2]] +>>> Shape.indices $ Shape.simplexDescending [Shape.Repetitive,Shape.Distinct,Shape.Distinct] $ Shape.ZeroBased (4::Int) +[[1,1,0],[2,1,0],[2,2,0],[2,2,1],[3,1,0],[3,2,0],[3,2,1],[3,3,0],[3,3,1],[3,3,2]] +-} +data Simplex order coll f size = + Simplex { + simplexOrder :: SimplexOrder order, + simplexDimension :: f coll, + simplexSize :: size + } + +data Ascending +data Descending +data SimplexOrder order where + Ascending :: SimplexOrder Ascending + Descending :: SimplexOrder Descending + +instance Eq (SimplexOrder order) where + Ascending == Ascending = True + Descending == Descending = True + +instance Show (SimplexOrder order) where + show Ascending = "Ascending" + show Descending = "Descending" + +type SimplexAscending = Simplex Ascending +type SimplexDescending = Simplex Descending + +simplexAscending :: f coll -> size -> SimplexAscending coll f size +simplexAscending = Simplex Ascending + +simplexDescending :: f coll -> size -> SimplexDescending coll f size +simplexDescending = Simplex Descending + +isAscending :: SimplexOrder order -> Bool +isAscending Ascending = True +isAscending Descending = False + +class SimplexOrderC order where +instance SimplexOrderC Ascending where +instance SimplexOrderC Descending where + +data AllDistinct = AllDistinct deriving (Show, Eq) +data SomeRepetitive = SomeRepetitive deriving (Show, Eq) +data Collision = Distinct | Repetitive deriving (Show, Eq, Ord, Enum) + +class CollisionC coll where repetitionAllowed :: coll -> Bool +instance CollisionC AllDistinct where repetitionAllowed AllDistinct = False +instance CollisionC SomeRepetitive where repetitionAllowed SomeRepetitive = True +instance CollisionC Collision where + repetitionAllowed Distinct = False + repetitionAllowed Repetitive = True + +instance + (SimplexOrderC order, Show coll, FunctorC.Show1 f, Show size) => + Show (Simplex order coll f size) where + showsPrec p (Simplex order d sz) = + showParen (p>10) $ + showString "Simplex " . + shows order . + showString " " . + FunctorC.showsPrec1 11 d . + showString " " . + showsPrec 11 sz + +instance + (SimplexOrderC order, CollisionC coll, Traversable f, C size) => + C (Simplex order coll f size) where + size (Simplex _order d sz) = + let ds = Fold.toList d + rep = length $ filter repetitionAllowed $ laxInit ds + in simplexLayoutSize (length ds) (size sz + rep) + +laxInit :: [a] -> [a] +laxInit xs = Match.take (drop 1 xs) xs + +simplexLayoutSize :: Integral i => Int -> i -> i +simplexLayoutSize d n = + case drop d $ binomials n of + [] -> 0 + m:_ -> m + +-- cf. package combinatorial +binomials :: Integral a => a -> [a] +binomials n = + scanl (\acc (num,den) -> div (acc*num) den) 1 + (zip [n, pred n ..] [1..n]) + +foldLength :: (Foldable f) => f a -> Int +foldLength = length . Fold.toList + +instance + (SimplexOrderC order, CollisionC coll, + Traversable f, FunctorC.Eq1 f, Indexed size) => + Indexed (Simplex order coll f size) where + type Index (Simplex order coll f size) = f (Index size) + indices (Simplex order d sz) = + flip MS.evalStateT (indices sz) $ + Trav.traverse + (if isAscending order + then chooseIndexAscending + else chooseIndexDescending) + d + inBounds (Simplex order d sz) = + let getOffset = offset sz in \ix -> + let ixs = Fold.toList ix in + all (inBounds sz) ixs && + FunctorC.eq1 (void d) (void ix) && + isMonotonic order (Fold.toList d) (map getOffset ixs) + unifiedSizeOffset (Simplex order d sz) = + let (n, getOffset) = unifiedSizeOffset sz in + let dInt = foldLength d + prep = prepareSimplexIndexingOrder order d n in + (simplexLayoutSize dInt (fst prep), + -- cf. Combinatorics.chooseRank + \ixf -> do + ks <- Trav.traverse getOffset $ Fold.toList ixf + assert + "Shape.Simplex.offset: simplex and index structure mismatch" + (FunctorC.eq1 (void d) (void ixf)) + assert + "Shape.Simplex.offset: index elements not monotonic" + (isMonotonic order (Fold.toList d) ks) + return $ + simplexOffset order dInt + (mapSnd (map snd . Fold.toList) prep) ks) + +simplexOffset :: + (Integral i) => SimplexOrder order -> Int -> (i, [(Int, i)]) -> [i] -> i +simplexOffset order d (nsum,cis) ks = + case order of + Ascending -> + simplexLayoutSize d nsum - 1 + - + sum (zipWith (\k (x,y) -> simplexLayoutSize x (y-k)) ks cis) + Descending -> + sum (zipWith (\k (x,y) -> simplexLayoutSize x (y+k)) ks cis) + +isMonotonic :: + (CollisionC coll) => SimplexOrder order -> [coll] -> [Int] -> Bool +isMonotonic order cs = + and + . + (if isAscending order + then + ListHT.mapAdjacent + (\(c,x) (_,y) -> if repetitionAllowed c then x<=y else x if repetitionAllowed c then x>=y else x>y)) + . + zip cs + +chooseIndexAscending, chooseIndexDescending :: + (CollisionC coll) => coll -> MS.StateT [a] [] a + +chooseIndexAscending coll = + MS.StateT $ \as -> zip as $ + (if repetitionAllowed coll then NonEmpty.flatten else NonEmpty.tail) $ + NonEmpty.tails as + +chooseIndexDescending coll = + MS.StateT $ \as -> zip as $ + (if repetitionAllowed coll then NonEmpty.tail else NonEmpty.flatten) $ + NonEmpty.inits as + +instance + (SimplexOrderC order, CollisionC coll, + Traversable f, FunctorC.Eq1 f, InvIndexed size) => + InvIndexed (Simplex order coll f size) where + unifiedIndexFromOffset (Simplex order d sh) = + let n = size sh in + let (nSum,deco) = prepareSimplexIndexingOrder order d n in + let dInt = foldLength d in \k -> + maybe + (throwOrError $ messageIndexFromOffset "Simplex" k) + (Trav.traverse (unifiedIndexFromOffset sh) . snd) $ + if isAscending order + then + mapAccumLM + (\(a,k0) (db,(x,y)) -> + case dropWhile ((<0) . snd) $ + map (\bi -> (bi, k0 - simplexLayoutSize x (y-bi))) $ + takeWhile ( Nothing + (b,k1):_ -> Just ((b+db, k1), b)) + (0, simplexLayoutSize dInt nSum - 1 - k) + deco + else + mapAccumLM + (\(a,k0) (db,(x,y)) -> + case dropWhile ((<0) . snd) $ + map (\bi -> (bi, k0 - simplexLayoutSize x (y+bi))) $ + takeWhile (>=0) $ iterate (subtract 1) a of + [] -> Nothing + (b,k1):_ -> Just ((b-db, k1), b)) + (n,k) + deco + +mapAccumLM :: + (Traversable t, Monad m) => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumLM f a0 xs = + liftM swap $ + MS.runStateT + (Trav.mapM (\b -> MS.StateT $ \a -> liftM swap $ f a b) xs) a0 + + +prepareSimplexIndexingOrder :: + (Traversable t, Num i, CollisionC coll) => + SimplexOrder order -> t coll -> Int -> (Int, t (Int, (i, Int))) +prepareSimplexIndexingOrder order d n = + if isAscending order + then mapFst (1+) $ prepareSimplexIndexing d (n-1) + else mapFst (n+) $ prepareSimplexIndexing d 0 + +prepareSimplexIndexing :: + (Traversable t, Num i, CollisionC coll) => + t coll -> Int -> (Int, t (Int, (i, Int))) +prepareSimplexIndexing d n = + let ((_,(_,nSum)), deco) = + Trav.mapAccumR + (\(c0,(x,y)) ci -> + let c1 = fromEnum (ci&&c0) + p = (x+1,y+c1) + in ((True,p),(1-c1,p))) + (False,(0,n)) + (fmap repetitionAllowed d) + in (nSum, deco) + + + +{- | +'Cyclic' is a shape, where the indices wrap around at the array boundaries. +E.g. + +prop> let shape = Shape.Cyclic (10::Int) in Shape.offset shape (-1) == Shape.offset shape 9 + +This also means that there are multiple indices +that address the same array element. + +>>> Shape.indices (Shape.Cyclic (7::Int)) +[0,1,2,3,4,5,6] +-} +newtype Cyclic n = Cyclic {cyclicSize :: n} + deriving (Eq, Show) + +instance Functor Cyclic where + fmap f (Cyclic n) = Cyclic $ f n + +instance Applicative Cyclic where + pure = Cyclic + Cyclic f <*> Cyclic n = Cyclic $ f n + +instance (NFData n) => NFData (Cyclic n) where + rnf (Cyclic n) = rnf n + +instance (Storable n) => Storable (Cyclic n) where + sizeOf = Store.sizeOf cyclicSize + alignment = Store.alignment cyclicSize + peek = Store.peek Cyclic + poke = Store.poke cyclicSize + +instance (Integral n) => C (Cyclic n) where + size (Cyclic len) = fromIntegral len + +instance (Integral n) => Indexed (Cyclic n) where + type Index (Cyclic n) = n + indices (Cyclic len) = indices $ ZeroBased len + unifiedOffset (Cyclic len) ix = pure $ fromIntegral $ mod ix len + inBounds (Cyclic len) _ix = len>0 + +instance (Integral n) => InvIndexed (Cyclic n) where + unifiedIndexFromOffset (Cyclic len) k0 = do + let k = fromIntegral k0 + assertIndexFromOffset "Cyclic" k0 $ 0<=k && k>> Shape.indices (Shape.ZeroBased (3::Int) ::+ Shape.Range 'a' 'c') +[Left 0,Left 1,Left 2,Right 'a',Right 'b',Right 'c'] +-} +data sh0::+sh1 = sh0::+sh1 + deriving (Eq, Show) + +instance (NFData sh0, NFData sh1) => NFData (sh0::+sh1) where + rnf (sh0::+sh1) = rnf (sh0,sh1) + +instance (C sh0, C sh1) => C (sh0::+sh1) where + size (sh0::+sh1) = size sh0 + size 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) + unifiedOffset (sh0::+sh1) = + let (n0,getOffset0) = unifiedSizeOffset sh0 + getOffset1 = unifiedOffset sh1 + in \ix -> + case ix of + Left ix0 -> getOffset0 ix0 + Right ix1 -> (n0 +) <$> getOffset1 ix1 + unifiedSizeOffset (sh0::+sh1) = + let (n0, getOffset0) = unifiedSizeOffset sh0 + (n1, getOffset1) = unifiedSizeOffset sh1 + in (n0+n1, either getOffset0 (fmap (n0+) . getOffset1)) + inBounds (sh0::+sh1) = either (inBounds sh0) (inBounds sh1) + +instance (InvIndexed sh0, InvIndexed sh1) => InvIndexed (sh0::+sh1) where + unifiedIndexFromOffset (sh0::+sh1) = + let pivot = size sh0 + in \k -> + if k < pivot + then Left <$> unifiedIndexFromOffset sh0 k + else Right <$> unifiedIndexFromOffset sh1 (k-pivot) + +instance (Static sh0, Static sh1) => Static (sh0::+sh1) where + static = static::+static + +instance (Pattern sh0, Pattern sh1) => Pattern (sh0::+sh1) where + type DataPattern (sh0::+sh1) x = DataPattern sh0 x ::+ DataPattern sh1 x + indexPattern extend (sh0::+sh1) = + indexPattern (extend . Left) sh0 ::+ indexPattern (extend . Right) sh1 + + +infixl 7 |* +infixl 6 |+| + +(|*) :: (Functor f, Num a) => f a -> a -> f a +f|*a = fmap (*a) f + +(|+|) :: (Applicative f, Num a) => f a -> f a -> f a +(|+|) = App.lift2 (+) + + + +{- | +Shape for arrays that hold elements +that can alternatively be stored in nested tuples. +-} +newtype NestedTuple ixtype tuple = NestedTuple {getNestedTuple :: tuple} + deriving (Eq, Show) + +data TupleAccessor +data TupleIndex + +newtype Element = Element Int + deriving (Eq, Show) + +instance NFData Element where + rnf (Element k) = rnf k + + +class ElementTuple tuple where + type DataTuple tuple x + indexTupleA :: + (Applicative f) => (Element -> f a) -> tuple -> f (DataTuple tuple a) + +tupleSize :: (ElementTuple tuple) => tuple -> Int +tupleSize = + getSum . MW.execWriter . indexTupleA (\x -> MW.tell (Sum 1) >> return x) + +indexTuple :: + (ElementTuple tuple) => (Element -> a) -> tuple -> DataTuple tuple a +indexTuple extend = runIdentity . indexTupleA (Identity . extend) + +{- | +>>> rnf (Shape.NestedTuple (Shape.Element 1, Shape.Element 2)) +() +>>> rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element 2, Shape.Element 3))) +() +>>> isBottom $ rnf (Shape.NestedTuple (Shape.Element undefined, Shape.Element 2)) +True +>>> isBottom $ rnf (Shape.NestedTuple (Shape.Element undefined, (Shape.Element 2, Shape.Element 3))) +True +>>> isBottom $ rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element undefined, Shape.Element 3))) +True +>>> isBottom $ rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element 2, Shape.Element undefined))) +True +-} +instance (ElementTuple tuple) => NFData (NestedTuple ixtype tuple) where + rnf (NestedTuple tuple) = + execStrictUnitWriter $ indexTupleA ((StrictUnitWriter$!) . rnf) tuple + +data StrictUnitWriter a = StrictUnitWriter a + +execStrictUnitWriter :: StrictUnitWriter a -> () +execStrictUnitWriter (StrictUnitWriter _) = () + +instance Functor StrictUnitWriter where + fmap f (StrictUnitWriter a) = StrictUnitWriter $ f a + +instance Applicative StrictUnitWriter where + pure = StrictUnitWriter + StrictUnitWriter f <*> StrictUnitWriter a = StrictUnitWriter $ f a + +instance Monad StrictUnitWriter where + return = pure + StrictUnitWriter a >>= k = k a + + + +class (ElementTuple tuple) => AccessorTuple tuple where + tupleAccessors :: tuple -> [tuple -> Element] + +class (ElementTuple tuple, Eq tuple) => StaticTuple tuple where + staticTuple :: MS.State Element tuple + + +instance ElementTuple () where + type DataTuple () x = () + indexTupleA _ () = pure () + +instance AccessorTuple () where + tupleAccessors () = [] + +instance StaticTuple () where + staticTuple = return () + + +instance ElementTuple Element where + type DataTuple Element x = x + indexTupleA extend = extend + +instance AccessorTuple Element where + tupleAccessors _ = [id] + +instance StaticTuple Element where + staticTuple = do + ix <- MS.get + MS.modify (\(Element k) -> Element (k+1)) + return ix + + +instance (ElementTuple a, ElementTuple b) => ElementTuple (a,b) where + type DataTuple (a,b) x = (DataTuple a x, DataTuple b x) + indexTupleA extend (a,b) = + App.lift2 (,) (indexTupleA extend a) (indexTupleA extend b) + +instance (AccessorTuple a, AccessorTuple b) => AccessorTuple (a,b) where + tupleAccessors (a,b) = + map (.fst) (tupleAccessors a) ++ map (.snd) (tupleAccessors b) + +instance (StaticTuple a, StaticTuple b) => StaticTuple (a,b) where + staticTuple = App.lift2 (,) staticTuple staticTuple + + +instance + (ElementTuple a, ElementTuple b, ElementTuple c) => + ElementTuple (a,b,c) where + type DataTuple (a,b,c) x = (DataTuple a x, DataTuple b x, DataTuple c x) + indexTupleA extend (a,b,c) = + App.lift3 (,,) + (indexTupleA extend a) (indexTupleA extend b) (indexTupleA extend c) + +instance + (AccessorTuple a, AccessorTuple b, AccessorTuple c) => + AccessorTuple (a,b,c) where + tupleAccessors (a,b,c) = + map (.fst3) (tupleAccessors a) ++ + map (.snd3) (tupleAccessors b) ++ + map (.thd3) (tupleAccessors c) + +instance + (StaticTuple a, StaticTuple b, StaticTuple c) => + StaticTuple (a,b,c) where + staticTuple = App.lift3 (,,) staticTuple staticTuple staticTuple + + +instance + (ElementTuple a, ElementTuple b, ElementTuple c, ElementTuple d) => + ElementTuple (a,b,c,d) where + type DataTuple (a,b,c,d) x = + (DataTuple a x, DataTuple b x, DataTuple c x, DataTuple d x) + indexTupleA extend (a,b,c,d) = + App.lift4 (,,,) + (indexTupleA extend a) (indexTupleA extend b) + (indexTupleA extend c) (indexTupleA extend d) + +instance + (AccessorTuple a, AccessorTuple b, AccessorTuple c, AccessorTuple d) => + AccessorTuple (a,b,c,d) where + tupleAccessors (a,b,c,d) = + map (.(\(i,_,_,_) -> i)) (tupleAccessors a) ++ + map (.(\(_,i,_,_) -> i)) (tupleAccessors b) ++ + map (.(\(_,_,i,_) -> i)) (tupleAccessors c) ++ + map (.(\(_,_,_,i) -> i)) (tupleAccessors d) + +instance + (StaticTuple a, StaticTuple b, StaticTuple c, StaticTuple d) => + StaticTuple (a,b,c,d) where + staticTuple = App.lift4 (,,,) staticTuple staticTuple staticTuple staticTuple + + +instance (ElementTuple a) => ElementTuple (Complex a) where + type DataTuple (Complex a) x = Complex (DataTuple a x) + indexTupleA extend (a:+b) = + App.lift2 (:+) (indexTupleA extend a) (indexTupleA extend b) + +instance (AccessorTuple a, RealFloat a) => AccessorTuple (Complex a) where + tupleAccessors (a:+b) = + map (.realPart) (tupleAccessors a) ++ map (.imagPart) (tupleAccessors b) + +instance (StaticTuple a) => StaticTuple (Complex a) where + staticTuple = App.lift2 (:+) staticTuple staticTuple + + +instance (ElementTuple tuple) => C (NestedTuple ixtype tuple) where + size (NestedTuple tuple) = tupleSize tuple + +instance (StaticTuple tuple) => Static (NestedTuple ixtype tuple) where + static = NestedTuple $ MS.evalState staticTuple $ Element 0 + +-- requires FlexibleInstances +instance (AccessorTuple tuple) => Indexed (NestedTuple TupleAccessor tuple) where + type Index (NestedTuple TupleAccessor tuple) = tuple -> Element + indices (NestedTuple tuple) = tupleAccessors tuple + unifiedOffset (NestedTuple tuple) ix = + case ix tuple of Element k -> return k + + + +newtype ElementIndex tuple = ElementIndex Int + deriving (Eq, Ord, Show) + +instance (ElementTuple tuple) => Indexed (NestedTuple TupleIndex tuple) where + type Index (NestedTuple TupleIndex tuple) = ElementIndex tuple + indices (NestedTuple tuple) = + map ElementIndex $ take (tupleSize tuple) [0..] + unifiedOffset (NestedTuple _tuple) (ElementIndex k) = return k + +instance (ElementTuple tuple) => Pattern (NestedTuple TupleIndex tuple) where + type DataPattern (NestedTuple TupleIndex tuple) x = DataTuple tuple x + indexPattern extend (NestedTuple tuple) = + let elemIx :: tuple -> Element -> ElementIndex tuple + elemIx _ (Element k) = ElementIndex k + in indexTuple (extend . elemIx tuple) tuple + +indexTupleFromShape :: + (ElementTuple tuple) => + NestedTuple TupleIndex tuple -> DataTuple tuple (ElementIndex tuple) +indexTupleFromShape = indexPattern id + + + + +nextCounter :: MS.State Int Int +nextCounter = do k <- MS.get; MS.put (k+1); return k + +{- | +Shape for arrays that hold elements +that can alternatively be stored in a 'Traversable' record. +-} +newtype Record f = Record {getRecord :: f Element} + +instance (Foldable f) => Eq (Record f) where + Record sh0 == Record sh1 = Fold.toList sh0 == Fold.toList sh1 +{- +instance (Eq (f Element)) => Eq (Record f) where + Record sh0 == Record sh1 = sh0 == sh1 +-} + +newtype FieldIndex (f :: * -> *) = FieldIndex Int + deriving (Eq, Show) + +instance (Foldable f) => C (Record f) where + size = foldLength . getRecord + +instance (Applicative f, Traversable f) => Static (Record f) where + static = + Record $ flip MS.evalState 0 $ Trav.sequence $ + pure (fmap Element nextCounter) + +instance (Foldable f) => Indexed (Record f) where + type Index (Record f) = FieldIndex f + indices (Record xs) = map FieldIndex $ Match.take (Fold.toList xs) [0..] + unifiedOffset (Record _xs) (FieldIndex k) = return k + +indexRecordFromShape :: + (Traversable f) => + Record f -> f (FieldIndex f) +indexRecordFromShape (Record xs) = fmap (\(Element k) -> FieldIndex k) xs + + + +{- | +Dynamically build a shape and its indices in the 'Construction' monad. +-} +newtype Constructed tag = Constructed {constructedSize :: Int} + deriving (Eq, Show) + +newtype ConsIndex tag = ConsIndex Int + deriving (Eq, Show) + +newtype Construction tag a = Construction (MS.State Int a) + +instance Functor (Construction tag) where + fmap f (Construction m) = Construction $ fmap f m + +instance Applicative (Construction tag) where + pure = Construction . pure + Construction f <*> Construction a = Construction $ f<*>a + +instance Monad (Construction tag) where + return = pure + Construction am >>= k = + Construction $ am >>= \a -> case k a of Construction bm -> bm + +construct :: Construction tag a -> (Constructed tag, a) +construct (Construction m) = + case MS.runState m 0 of (a, sz) -> (Constructed sz, a) + +consIndex :: Construction tag (ConsIndex tag) +consIndex = Construction $ fmap ConsIndex nextCounter + + +instance C (Constructed tag) where + size = constructedSize + +instance Indexed (Constructed tag) where + type Index (Constructed tag) = ConsIndex tag + indices (Constructed len) = map ConsIndex $ take len [0..] + unifiedOffset (Constructed len) = + let f = unifiedOffset (ZeroBased len) in \(ConsIndex k) -> f k + inBounds (Constructed len) (ConsIndex ix) = inBounds (ZeroBased len) ix + +instance InvIndexed (Constructed tag) where + unifiedIndexFromOffset (Constructed len) = + fmap ConsIndex . unifiedIndexFromOffset (ZeroBased len) diff --git a/src/Data/Array/Comfort/Shape/SubSize.hs b/src/Data/Array/Comfort/Shape/SubSize.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Shape/SubSize.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{- | +Framework for extracting subsize in 'Array.unsafeCreateWithSizes'. +-} +module Data.Array.Comfort.Shape.SubSize ( + T(Cons, measure), + auto, + atom, + Sub(Sub), + sub, + pair, + triple, + append, + + C(ToShape), + Atom(Atom), + evaluate, + ) where + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape ((::+)((::+))) + + +newtype T sh nsize = Cons {measure :: sh -> (Int,nsize)} + +auto :: (C nsize) => T (ToShape nsize) nsize +auto = Cons evaluate + +atom :: (Shape.C sh) => T sh Int +atom = Cons $ \sh -> let n = Shape.size sh in (n,n) + +data Sub nsize = Sub Int nsize + +sub :: T sh nsize -> T sh (Sub nsize) +sub (Cons s) = + Cons $ \sh -> + let (n,subSizes) = s sh + in (n, Sub n subSizes) + +pair :: + T sh0 nsize0 -> + T sh1 nsize1 -> + T (sh0,sh1) (nsize0,nsize1) +pair (Cons s0) (Cons s1) = + Cons $ \(sh0,sh1) -> + let (n0,sub0) = s0 sh0 + (n1,sub1) = s1 sh1 + in (n0*n1, (sub0,sub1)) + +triple :: + T sh0 nsize0 -> + T sh1 nsize1 -> + T sh2 nsize2 -> + T (sh0,sh1,sh2) (nsize0,nsize1,nsize2) +triple (Cons s0) (Cons s1) (Cons s2) = + Cons $ \(sh0,sh1,sh2) -> + let (n0,sub0) = s0 sh0 + (n1,sub1) = s1 sh1 + (n2,sub2) = s2 sh2 + in (n0*n1*n2, (sub0,sub1,sub2)) + +append :: + T sh0 nsize0 -> + T sh1 nsize1 -> + T (sh0::+sh1) (nsize0::+nsize1) +append (Cons s0) (Cons s1) = + Cons $ \(sh0::+sh1) -> + let (n0,sub0) = s0 sh0 + (n1,sub1) = s1 sh1 + in (n0+n1, sub0::+sub1) + + + + +class C nsize where + type ToShape nsize + {- | + Compute the sizes of a shape and some sub-shapes. + -} + evaluate :: ToShape nsize -> (Int, nsize) + +newtype Atom sh = Atom Int + +instance (Shape.C sh) => C (Atom sh) where + type ToShape (Atom sh) = sh + evaluate sh = let n = Shape.size sh in (n, Atom n) + +instance (C sub) => C (Sub sub) where + type ToShape (Sub sub) = ToShape sub + evaluate = measure $ sub auto + +instance (C nsize0, C nsize1) => C (nsize0,nsize1) where + type ToShape (nsize0,nsize1) = + (ToShape nsize0, ToShape nsize1) + evaluate = measure $ pair auto auto + +instance (C nsize0, C nsize1, C nsize2) => C (nsize0,nsize1,nsize2) where + type ToShape (nsize0,nsize1,nsize2) = + (ToShape nsize0, ToShape nsize1, ToShape nsize2) + evaluate = measure $ triple auto auto auto + +instance (C nsize0, C nsize1) => C (nsize0::+nsize1) where + type ToShape (nsize0::+nsize1) = (ToShape nsize0 ::+ ToShape nsize1) + evaluate = measure $ append auto auto diff --git a/src/Data/Array/Comfort/Shape/Test.hs b/src/Data/Array/Comfort/Shape/Test.hs --- a/src/Data/Array/Comfort/Shape/Test.hs +++ b/src/Data/Array/Comfort/Shape/Test.hs @@ -1,15 +1,16 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GADTs #-} module Data.Array.Comfort.Shape.Test (tests) where import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Shape.Utility (isRight) + +import Control.Applicative (pure) import Data.Tuple.HT (mapSnd) 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 @@ -21,6 +22,21 @@ let ixs = Shape.indices sh in not (null ixs) QC.==> QC.forAll (QC.elements ixs) f +-- ToDo: we need to check for indices outside of bounds, too +inBoundsOffset :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property +inBoundsOffset sh = + forAllIndices sh $ \ix -> + Shape.inBounds sh ix == + isRight (Shape.getChecked (Shape.unifiedOffset sh ix)) + +inBoundsSizeOffset :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property +inBoundsSizeOffset sh = + forAllIndices sh $ \ix -> + Shape.inBounds sh ix == + isRight (Shape.getChecked (snd (Shape.unifiedSizeOffset sh) ix)) + sizeOffset :: (Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => sh -> QC.Property sizeOffset sh = @@ -34,14 +50,45 @@ uncheckedSizeOffset sh = forAllIndices sh $ \ix -> mapSnd ($ix) (Shape.uncheckedSizeOffset sh) == - (Shape.uncheckedSize sh, Shape.uncheckedOffset sh ix) + (Shape.size sh, Shape.uncheckedOffset sh ix) +unifiedSizeOffsetA :: + (Shape.Checking check, Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => + Shape.CheckSingleton check -> sh -> QC.Property +unifiedSizeOffsetA check sh = + forAllIndices sh $ \ix -> + mapSnd ($ix) (Shape.unifiedSizeOffset sh) == + (Shape.size sh, Shape.requireCheck check $ Shape.unifiedOffset sh ix) + +unifiedSizeOffsetB :: + (Shape.Checking check, Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => + Shape.CheckSingleton check -> sh -> QC.Property +unifiedSizeOffsetB check sh = + forAllIndices sh $ \ix -> + (mapSnd (Shape.requireCheck check . ($ix)) $ Shape.unifiedSizeOffset sh) + == + case check of + Shape.Checked -> + mapSnd (pure . ($ix)) (Shape.sizeOffset sh) + Shape.Unchecked -> + mapSnd (pure . ($ix)) (Shape.uncheckedSizeOffset sh) + 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 +unifiedOffset :: + (Shape.Checking check, Shape.Indexed sh, Shape.Index sh ~ ix, Show ix) => + Shape.CheckSingleton check -> sh -> QC.Property +unifiedOffset check sh = + forAllIndices sh $ \ix -> + Shape.requireCheck check (Shape.unifiedOffset sh ix) == + case check of + Shape.Checked -> pure $ Shape.offset sh ix + Shape.Unchecked -> pure $ Shape.uncheckedOffset sh ix + lengthIndices :: (Shape.Indexed sh) => sh -> Bool lengthIndices sh = length (Shape.indices sh) == Shape.size sh @@ -60,13 +107,50 @@ Shape.indices sh == map (Shape.uncheckedIndexFromOffset sh) (take (Shape.size sh) [0..]) +unifiedInvIndicesA :: + (Shape.Checking check, Shape.InvIndexed sh, Shape.Index sh ~ ix, Eq ix) => + Shape.CheckSingleton check -> sh -> Bool +unifiedInvIndicesA check sh = + map pure (Shape.indices sh) == + map (Shape.requireCheck check . Shape.unifiedIndexFromOffset sh) + (take (Shape.size sh) [0..]) +unifiedInvIndicesB :: + (Shape.Checking check, Shape.InvIndexed sh, Shape.Index sh ~ ix, Eq ix) => + Shape.CheckSingleton check -> sh -> QC.Property +unifiedInvIndicesB check sh = + let n = Shape.size sh in n>0 QC.==> + QC.forAll (QC.choose (0, n-1)) $ \k -> + Shape.requireCheck check (Shape.unifiedIndexFromOffset sh k) == + case check of + Shape.Checked -> pure $ Shape.indexFromOffset sh k + Shape.Unchecked -> pure $ Shape.uncheckedIndexFromOffset sh k + + +unifiedTests :: + (Shape.Checking check, + Shape.InvIndexed sh, Show sh, Shape.Index sh ~ ix, Eq ix, Show ix) => + Shape.CheckSingleton check -> QC.Gen sh -> [(String, QC.Property)] +unifiedTests check gen = + ("unifiedSizeOffsetA", QC.forAll gen (unifiedSizeOffsetA check)) : + ("unifiedSizeOffsetB", QC.forAll gen (unifiedSizeOffsetB check)) : + ("unifiedOffset", QC.forAll gen (unifiedOffset check)) : + ("unifiedInvIndicesA", QC.forAll gen (unifiedInvIndicesA check)) : + ("unifiedInvIndicesB", QC.forAll gen (unifiedInvIndicesB check)) : + [] + +-- cf. Test.Utility +prefix :: String -> [(String, test)] -> [(String, test)] +prefix msg = + map (\(str,test) -> (msg ++ "." ++ str, test)) + 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) : + ("inBoundsOffset", QC.forAll gen inBoundsOffset) : + ("inBoundsSizeOffset", QC.forAll gen inBoundsSizeOffset) : ("sizeOffset", QC.forAll gen sizeOffset) : ("uncheckedSizeOffset", QC.forAll gen uncheckedSizeOffset) : ("uncheckedOffset", QC.forAll gen uncheckedOffset) : @@ -74,4 +158,6 @@ ("indexOffsets", QC.forAll gen indexOffsets) : ("invIndices", QC.forAll gen invIndices) : ("uncheckedInvIndices", QC.forAll gen uncheckedInvIndices) : + prefix "Checked" (unifiedTests Shape.Checked gen) ++ + prefix "Unchecked" (unifiedTests Shape.Unchecked gen) ++ [] diff --git a/src/Data/Array/Comfort/Shape/Tuple.hs b/src/Data/Array/Comfort/Shape/Tuple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Shape/Tuple.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} +module Data.Array.Comfort.Shape.Tuple where + +import qualified Data.Array.Comfort.Shape as Shape +import Data.Complex (Complex((:+))) + +import qualified Control.Monad.Trans.State as MS +import qualified Control.Applicative.HT as App +import Control.Applicative ((<$>)) + + +get :: MS.State [a] a +get = + MS.state $ \at -> + case at of + a:as -> (a,as) + [] -> error "Shape.Tuple.get: no element left" + +cons :: + (Shape.ElementTuple shape) => + shape -> MS.State [a] (Shape.DataTuple shape a) +cons = Shape.indexTupleA (const get) + + +next :: MS.State Shape.Element Shape.Element +next = do + ix <- MS.get + MS.modify (\(Shape.Element k) -> Shape.Element (k+1)) + return ix + + +class (Shape.ElementTuple shape) => NestedTuple shape where + decons :: Shape.DataTuple shape a -> MS.State Shape.Element (shape, [a]) + +instance NestedTuple () where + decons () = return ((),[]) + +instance NestedTuple Shape.Element where + decons a = flip (,) [a] <$> next + +instance (NestedTuple a, NestedTuple b) => NestedTuple (a,b) where + decons (a,b) = + App.lift2 (\(ta,as) (tb,bs) -> ((ta,tb), as++bs)) (decons a) (decons b) + +instance + (NestedTuple a, NestedTuple b, NestedTuple c) => + NestedTuple (a,b,c) where + decons (a,b,c) = + App.lift3 + (\(ta,as) (tb,bs) (tc,cs) -> ((ta,tb,tc), as++bs++cs)) + (decons a) (decons b) (decons c) + +instance + (NestedTuple a, NestedTuple b, NestedTuple c, NestedTuple d) => + NestedTuple (a,b,c,d) where + decons (a,b,c,d) = + App.lift4 + (\(ta,as) (tb,bs) (tc,cs) (td,ds) -> ((ta,tb,tc,td), as++bs++cs++ds)) + (decons a) (decons b) (decons c) (decons d) + +instance (NestedTuple a) => NestedTuple (Complex a) where + decons (a:+b) = + App.lift2 (\(ta,as) (tb,bs) -> ((ta:+tb), as++bs)) (decons a) (decons b) diff --git a/src/Data/Array/Comfort/Shape/Utility.hs b/src/Data/Array/Comfort/Shape/Utility.hs --- a/src/Data/Array/Comfort/Shape/Utility.hs +++ b/src/Data/Array/Comfort/Shape/Utility.hs @@ -3,6 +3,13 @@ import Text.Printf (printf) +messageIndexFromOffset :: String -> Int -> String +messageIndexFromOffset name k = + printf "indexFromOffset (%s): index %d out of range" name k + errorIndexFromOffset :: String -> Int -> a -errorIndexFromOffset name k = - error $ printf "indexFromOffset (%s): index %d out of range" name k +errorIndexFromOffset name = error . messageIndexFromOffset name + + +isRight :: Either a b -> Bool +isRight = either (const False) (const True) diff --git a/src/Data/Array/Comfort/Storable.hs b/src/Data/Array/Comfort/Storable.hs --- a/src/Data/Array/Comfort/Storable.hs +++ b/src/Data/Array/Comfort/Storable.hs @@ -1,21 +1,31 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Data.Array.Comfort.Storable ( Array, shape, reshape, mapShape, - (!), + accessMaybe, (!), Array.toList, Array.vectorFromList, toAssociations, fromList, fromMap, toMap, + fromIntMap, toIntMap, + fromTuple, toTuple, + fromRecord, toRecord, fromContainer, toContainer, sample, + replicate, fromBoxed, toBoxed, + Array.fromStorableVector, + Array.toStorableVector, + fromBlockArray1, + fromBlockArray2, + fromNonEmptyBlockArray2, Array.map, Array.mapWithIndex, @@ -24,11 +34,16 @@ accumulate, fromAssociations, + pick, + toRowArray, + fromRowArray, Array.singleton, Array.append, Array.take, Array.drop, Array.takeLeft, Array.takeRight, Array.split, Array.takeCenter, + takeSet, + takeIntSet, Array.sum, Array.product, minimum, argMinimum, @@ -40,50 +55,69 @@ ) where import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArrayNC +import qualified Data.Array.Comfort.Storable.Mutable.Private as MutArrayPriv import qualified Data.Array.Comfort.Storable.Mutable as MutArray import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Storable.Dim2 as Array2 import qualified Data.Array.Comfort.Storable.Memory as Memory import qualified Data.Array.Comfort.Container as Container import qualified Data.Array.Comfort.Boxed as BoxedArray import qualified Data.Array.Comfort.Check as Check +import qualified Data.Array.Comfort.Shape.Tuple as TupleShape import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Unchecked (Array(Array)) import System.IO.Unsafe (unsafePerformIO) -import Foreign.Storable (Storable) +import Foreign.Marshal.Array (advancePtr) +import Foreign.Storable (Storable, poke, peekElemOff) import Foreign.ForeignPtr (withForeignPtr) +import qualified Control.Monad.Trans.State as MS import Control.Monad.ST (runST) +import qualified Data.StorableVector as SV +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Traversable as Trav import qualified Data.Foldable as Fold import qualified Data.List as List import qualified Data.Tuple.Strict as StrictTuple +import Data.IntMap (IntMap) +import Data.IntSet (IntSet) import Data.Map (Map) import Data.Set (Set) import Data.Foldable (forM_) +import Data.Either.HT (maybeRight) import Data.Semigroup (Semigroup, (<>), Min(Min,getMin), Max(Max,getMax), Arg(Arg)) -import Prelude2010 hiding (map, zipWith, foldl1, minimum, maximum) +import Prelude2010 hiding (map, zipWith, foldl1, minimum, maximum, replicate) import Prelude () {- $setup >>> import qualified Data.Array.Comfort.Storable as Array >>> import qualified Data.Array.Comfort.Shape as Shape ->>> import Data.Array.Comfort.Storable (Array) +>>> import Data.Array.Comfort.Storable (Array, (!)) >>> >>> import qualified Test.QuickCheck as QC >>> import Test.ChasingBottoms.IsBottom (isBottom) >>> >>> import Control.Applicative ((<$>)) >>> ->>> import Data.Word (Word16) +>>> import qualified Data.IntSet as IntSet +>>> import qualified Data.Set as Set +>>> import Data.Complex (Complex((:+))) +>>> import Data.Word (Word8, Word16) >>> >>> type ShapeInt = Shape.ZeroBased Int +>>> type X = Shape.Element >>> +>>> shapeInt :: Int -> ShapeInt +>>> shapeInt = Shape.ZeroBased +>>> >>> genArray :: QC.Gen (Array ShapeInt Word16) >>> genArray = Array.vectorFromList <$> QC.arbitrary >>> @@ -113,6 +147,10 @@ mapShape f arr = reshape (f $ shape arr) arr +{- | +>>> Array.fromList (shapeInt 5) ['a'..] +StorableArray.fromList (ZeroBased {zeroBasedSize = 5}) "abcde" +-} fromList :: (Shape.C sh, Storable a) => sh -> [a] -> Array sh a fromList sh arr = runST (MutArrayNC.unsafeFreeze =<< MutArray.fromList sh arr) @@ -120,8 +158,66 @@ fromMap m = fromList (Map.keysSet m) (Map.elems m) toMap :: (Ord k, Storable a) => Array (Set k) a -> Map k a -toMap arr = Map.fromAscList $ zip (Set.toAscList $ shape arr) (Array.toList arr) +toMap = Map.fromAscList . toAssociations +fromIntMap :: (Storable a) => IntMap a -> Array IntSet a +fromIntMap m = fromList (IntMap.keysSet m) (IntMap.elems m) + +toIntMap :: (Storable a) => Array IntSet a -> IntMap a +toIntMap = IntMap.fromAscList . toAssociations + +{- | +>>> Array.fromTuple ('a',('b','c')) :: Array (Shape.NestedTuple Shape.TupleIndex (X,(X,X))) Char +StorableArray.fromList (NestedTuple {getNestedTuple = (Element 0,(Element 1,Element 2))}) "abc" + +>>> :{ + let arr :: Array (Shape.NestedTuple Shape.TupleAccessor (X,(X,X))) Char + arr = Array.fromTuple ('a',('b','c')) + in (arr ! fst, arr ! (fst.snd)) +:} +('a','b') +-} +fromTuple :: + (TupleShape.NestedTuple tuple, Storable a) => + Shape.DataTuple tuple a -> Array (Shape.NestedTuple ixtype tuple) a +fromTuple tuple = + case MS.evalState (TupleShape.decons tuple) (Shape.Element 0) of + (sh, xs) -> fromList (Shape.NestedTuple sh) xs + +toTuple :: + (TupleShape.NestedTuple tuple, Storable a) => + Array (Shape.NestedTuple ixtype tuple) a -> Shape.DataTuple tuple a +toTuple arr = + MS.evalState + (TupleShape.cons $ Shape.getNestedTuple $ shape arr) + (Array.toList arr) + +{- | +>>> :{ + let arr = Array.fromRecord ('a' :+ 'b') in + let (real:+imag) = Shape.indexRecordFromShape $ Array.shape arr in + (arr ! real, arr ! imag) +:} +('a','b') +-} +fromRecord :: + (Trav.Traversable f, Storable a) => + f a -> Array (Shape.Record f) a +fromRecord xs = + fromList + (Shape.Record $ flip MS.evalState (Shape.Element 0) $ + Trav.traverse (const TupleShape.next) xs) + (Fold.toList xs) + +toRecord :: + (Trav.Traversable f, Storable a) => + Array (Shape.Record f) a -> f a +toRecord arr = + MS.evalState + (Trav.traverse (const TupleShape.get) $ + (\(Shape.Record record) -> record) $ shape arr) + (Array.toList arr) + fromContainer :: (Container.C f, Storable a) => f a -> Array (Container.Shape f) a fromContainer xs = fromList (Container.toShape xs) (Fold.toList xs) @@ -134,24 +230,75 @@ (Shape.Indexed sh, Storable a) => sh -> (Shape.Index sh -> a) -> Array sh a sample sh f = Array.fromList sh $ List.map f $ Shape.indices sh +replicate :: (Shape.C sh, Storable a) => sh -> a -> Array sh a +replicate sh a = runST (MutArrayNC.unsafeFreeze =<< MutArray.new sh a) + fromBoxed :: (Shape.C sh, Storable a) => BoxedArray.Array sh a -> Array sh a fromBoxed arr = Array.fromList (BoxedArray.shape arr) $ BoxedArray.toList arr toBoxed :: (Shape.C sh, Storable a) => Array sh a -> BoxedArray.Array sh a toBoxed arr = BoxedArray.fromList (Array.shape arr) $ Array.toList arr + +{-# DEPRECATED fromBlockArray1 "Use fromBlockArray instead." #-} +fromBlockArray, fromBlockArray1 :: + (Ord k, Shape.C shape, Storable a) => + BoxedArray.Array (Set k) (Array shape a) -> Array (Map k shape) a +fromBlockArray1 = fromBlockArray +fromBlockArray a = + reshape (BoxedArray.toMap $ fmap Array.shape a) $ + Array.fromStorableVector $ SV.concat $ + List.map Array.toStorableVector $ BoxedArray.toList a + +{-# DEPRECATED fromNonEmptyBlockArray2 + "Use Storable.Dim2.fromNonEmptyBlockArray instead." #-} +fromNonEmptyBlockArray2 :: + (Ord row, Shape.C height, Eq height) => + (Ord column, Shape.C width, Eq width) => + (Storable a) => + BoxedArray.Array (Set row, Set column) (Array (height, width) a) -> + Array (Map row height, Map column width) a +fromNonEmptyBlockArray2 = Array2.fromNonEmptyBlockArray + +{-# DEPRECATED fromBlockArray2 "Use Storable.Dim2.fromBlockArray instead." #-} +fromBlockArray2 :: + (Ord row, Shape.C height, Eq height) => + (Ord column, Shape.C width, Eq width) => + (Storable a) => + Map row height -> Map column width -> + BoxedArray.Array (Set row, Set column) (Array (height, width) a) -> + Array (Map row height, Map column width) a +fromBlockArray2 = Array2.fromBlockArray + + toAssociations :: (Shape.Indexed sh, Storable a) => Array sh a -> [(Shape.Index sh, a)] toAssociations arr = zip (Shape.indices $ shape arr) (Array.toList arr) +errorArray :: String -> String -> a +errorArray name msg = + error ("Array.Comfort.Storable." ++ name ++ ": " ++ msg) + infixl 9 ! (!) :: (Shape.Indexed sh, Storable a) => Array sh a -> Shape.Index sh -> a -(!) arr ix = runST (do +(!) arr = either (errorArray "!") id . accessEither arr + +accessMaybe :: + (Shape.Indexed sh, Storable a) => Array sh a -> Shape.Index sh -> Maybe a +accessMaybe arr = maybeRight . accessEither arr + +accessEither :: + (Shape.Indexed sh, Storable a) => + Array sh a -> Shape.Index sh -> Either String a +accessEither arr ix = runST (do marr <- MutArrayNC.unsafeThaw arr - MutArray.read marr ix) + case MutArrayPriv.readEither marr ix of + Right access -> fmap Right access + Left msg -> return $ Left msg) +-- for GHC>=7.8: Trav.sequenceA $ MutArrayPriv.readEither marr ix) zipWith :: @@ -160,7 +307,7 @@ zipWith f a b = if shape a == shape b then Array.zipWith f a b - else error "zipWith: shapes mismatch" + else errorArray "zipWith" "shapes mismatch" (//) :: (Shape.Indexed sh, Storable a) => @@ -187,8 +334,60 @@ MutArrayNC.unsafeFreeze marr) +{- | +>>> Array.takeSet (Set.fromList [0,2,4,7,13]) (Array.vectorFromList [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3::Word8]) +StorableArray... (... [0,2,4,7,13]) [3,4,5,6,7] +-} +{-# INLINE takeSet #-} +takeSet :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Ord ix, Storable a) => + Set ix -> Array sh a -> Array (Set ix) a +takeSet = takeSetGen Set.toAscList {- | +>>> Array.takeIntSet (IntSet.fromList [0,2,4,7,13]) (Array.vectorFromList [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3::Word8]) +StorableArray... (... [0,2,4,7,13]) [3,4,5,6,7] +-} +{-# INLINE takeIntSet #-} +takeIntSet :: + (Shape.Indexed sh, Shape.Index sh ~ Int, Storable a) => + IntSet -> Array sh a -> Array IntSet a +takeIntSet = takeSetGen IntSet.toAscList + +{-# INLINE takeSetGen #-} +takeSetGen :: + (Shape.Indexed sh, Shape.Index sh ~ ix, Shape.C set, Storable a) => + (set -> [ix]) -> set -> Array sh a -> Array set a +takeSetGen listFromSet ixs (Array sh a) = + Array.unsafeCreate ixs $ \dstPtr -> + withForeignPtr a $ \srcPtr -> + sequence_ $ + List.zipWith + (\src dst -> poke dst =<< peekElemOff srcPtr src) + (List.map (Shape.offset sh) $ listFromSet ixs) + (iterate (flip advancePtr 1) dstPtr) + + +{-# DEPRECATED pick "Use Storable.Dim2.takeRow instead." #-} +pick :: + (Shape.Indexed sh0, Shape.C sh1, Storable a) => + Array (sh0,sh1) a -> Shape.Index sh0 -> Array sh1 a +pick = Array2.takeRow + +{-# DEPRECATED toRowArray "Use Storable.Dim2.toRowArray instead." #-} +toRowArray :: + (Shape.Indexed sh0, Shape.C sh1, Storable a) => + Array (sh0,sh1) a -> BoxedArray.Array sh0 (Array sh1 a) +toRowArray = Array2.toRowArray + +{-# DEPRECATED fromRowArray "Use Storable.Dim2.fromRowArray instead." #-} +fromRowArray :: + (Shape.C sh0, Shape.C sh1, Eq sh1, Storable a) => + sh1 -> BoxedArray.Array sh0 (Array sh1 a) -> Array (sh0,sh1) a +fromRowArray = Array2.fromRowArray + + +{- | It is a checked error if the vector is empty. prop> forAllNonEmpty $ \xs -> Array.minimum xs ==? minimum (Array.toList xs) @@ -225,8 +424,8 @@ argMinimum, argMaximum :: - (Shape.InvIndexed sh, Shape.Index sh ~ ix, Storable a, Ord a) => - Array sh a -> (ix,a) + (Shape.InvIndexed sh, Storable a, Ord a) => + Array sh a -> (Shape.Index sh, a) argMinimum xs = unArg xs $ getMin $ foldMapWithIndex (\k x -> Min (Arg x k)) xs argMaximum xs = unArg xs $ getMax $ foldMapWithIndex (\k x -> Max (Arg x k)) xs diff --git a/src/Data/Array/Comfort/Storable/Dim2.hs b/src/Data/Array/Comfort/Storable/Dim2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Storable/Dim2.hs @@ -0,0 +1,697 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Array.Comfort.Storable.Dim2 ( + Array2, + singleRow, flattenRow, + singleColumn, flattenColumn, + takeRow, + toRowArray, + fromRowArray, + above, beside, + takeTop, takeBottom, + takeLeft, takeRight, + + fromNonEmptyBlockArray, + fromBlockArray, + fromBlocks, BlockFunction, RowFunction, + ShapeSequence(switchSequence), + + BlockArray, BlockMatrix, Block, + fromBlockMatrix, block, blockAbove, blockBeside, (&===), (&|||), + ) where + +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Storable.Unchecked as Array +import qualified Data.Array.Comfort.Shape.SubSize as SubSize +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Unchecked (Array(Array)) +import Data.Array.Comfort.Shape ((::+)((::+))) + +import Foreign.Marshal.Array (copyArray, advancePtr) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Storable (Storable) + +import qualified Data.StorableVector as SV + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.List.HT as ListHT +import qualified Data.List as List +import Data.Map (Map) +import Data.Set (Set) +import Data.Foldable (forM_) +import Data.Tuple.HT (mapPair, mapFst) +import Data.Proxy (Proxy(Proxy)) + + +{- $setup +>>> import qualified DocTest.Data.Array.Comfort.Boxed.Unchecked +>>> as TestBoxedArray +>>> import DocTest.Data.Array.Comfort.Storable (ShapeInt, shapeInt) +>>> +>>> import qualified Data.Array.Comfort.Boxed as BoxedArray +>>> import qualified Data.Array.Comfort.Storable.Dim2 as Array2 +>>> import qualified Data.Array.Comfort.Storable as Array +>>> import qualified Data.Array.Comfort.Shape as Shape +>>> import Data.Array.Comfort.Storable.Dim2 (Array2, (&===), (&|||)) +>>> import Data.Array.Comfort.Storable (Array, (!)) +>>> import Data.Array.Comfort.Shape ((::+)((::+))) +>>> +>>> import qualified Test.QuickCheck as QC +>>> +>>> import Control.Monad (replicateM) +>>> import Control.Applicative (liftA2, (<$>), (<*>)) +>>> +>>> import qualified Data.Map as Map +>>> import qualified Data.Set as Set +>>> import Data.Map (Map) +>>> import Data.Function.HT (Id) +>>> import Data.Tuple.HT (swap) +>>> import Data.Word (Word16) +>>> import Data.Proxy (Proxy(Proxy)) +>>> +>>> import Foreign.Storable (Storable) +>>> +>>> genArray2 :: QC.Gen (Array2 ShapeInt ShapeInt Word16) +>>> genArray2 = do +>>> xs <- QC.arbitrary +>>> let n = length xs +>>> (k,m) <- +>>> if n == 0 +>>> then QC.elements [(,) 0, flip (,) 0] <*> QC.choose (1,20) +>>> else fmap (\m -> (div n m, m)) $ QC.choose (1,n) +>>> return $ Array.fromList (Shape.ZeroBased k, Shape.ZeroBased m) xs +>>> +>>> genArrayForShape :: (Shape.C shape) => shape -> QC.Gen (Array shape Word16) +>>> genArrayForShape sh = +>>> Array.fromList sh <$> replicateM (Shape.size sh) QC.arbitrary +>>> +>>> genNonEmptyArray2 :: QC.Gen (Array2 ShapeInt ShapeInt Word16) +>>> genNonEmptyArray2 = do +>>> xs <- QC.getNonEmpty <$> QC.arbitrary +>>> let n = length xs +>>> m <- QC.choose (1,n) +>>> return $ Array.fromList (Shape.ZeroBased (div n m), Shape.ZeroBased m) xs +>>> +>>> +>>> transpose :: +>>> (Shape.Indexed sh0, Shape.Indexed sh1, Storable a) => +>>> Array2 sh0 sh1 a -> Array2 sh1 sh0 a +>>> transpose a = Array.sample (swap $ Array.shape a) (\(i,j) -> a!(j,i)) +-} + + +type Array2 sh0 sh1 = Array (sh0,sh1) + +singleRow :: Array width a -> Array2 () width a +singleRow = Array.mapShape ((,) ()) + +singleColumn :: Array height a -> Array2 height () a +singleColumn = Array.mapShape (flip (,) ()) + +flattenRow :: Array2 () width a -> Array width a +flattenRow = Array.mapShape snd + +flattenColumn :: Array2 height () a -> Array height a +flattenColumn = Array.mapShape fst + + +{- | +prop> :{ + QC.forAll genNonEmptyArray2 $ \xs -> + QC.forAll (QC.elements $ Shape.indices $ Array.shape xs) $ \(ix0,ix1) -> + Array2.takeRow xs ix0 ! ix1 == xs!(ix0,ix1) +:} +-} +takeRow :: + (Shape.Indexed sh0, Shape.C sh1, Storable a) => + Array2 sh0 sh1 a -> Shape.Index sh0 -> Array sh1 a +takeRow (Array (sh0,sh1) x) ix0 = + Array.unsafeCreateWithSize sh1 $ \k yPtr -> + withForeignPtr x $ \xPtr -> + copyArray yPtr (advancePtr xPtr (Shape.offset sh0 ix0 * k)) k + +toRowArray :: + (Shape.C sh0, Shape.C sh1, Storable a) => + Array2 sh0 sh1 a -> BoxedArray.Array sh0 (Array sh1 a) +toRowArray x = + let y = Array.mapShape (mapFst Shape.Deferred) x in + BoxedArray.mapShape (\(Shape.Deferred sh0) -> sh0) $ + fmap (takeRow y) $ BoxedArray.indices $ fst $ Array.shape y + +{- | +It is a checked error if a row width differs from the result array width. + +prop> :{ + QC.forAll genArray2 $ \xs -> + xs == Array2.fromRowArray (snd $ Array.shape xs) (Array2.toRowArray xs) +:} +-} +fromRowArray :: + (Shape.C sh0, Shape.C sh1, Eq sh1, Storable a) => + sh1 -> BoxedArray.Array sh0 (Array sh1 a) -> Array2 sh0 sh1 a +fromRowArray sh1 x = + Array.unsafeCreateWithAutoSizes (BoxedArray.shape x, sh1) $ + \(SubSize.Atom _, SubSize.Atom k) yPtr -> + forM_ (zip [0,k..] (BoxedArray.toList x)) $ \(j, Array sh1i row) -> + if sh1 == sh1i + then withForeignPtr row $ \xPtr -> copyArray (advancePtr yPtr j) xPtr k + else errorArray "fromRowArray" "mismatching row width" + + +infixr 2 `above` +infixr 3 `beside` + +{- | +prop> :{ + QC.forAll genArray2 $ \xs -> + let (Shape.ZeroBased m, width) = Array.shape xs in + QC.forAll (QC.choose (0, m)) $ \k -> + let ys = Array.reshape + (Shape.ZeroBased k ::+ Shape.ZeroBased (m-k), width) xs in + ys == Array2.above (Array2.takeTop ys) (Array2.takeBottom ys) +:} +-} +above :: + (Shape.C heightA, Shape.C heightB) => + (Shape.C width, Eq width) => + (Storable a) => + Array2 heightA width a -> + Array2 heightB width a -> + Array2 (heightA::+heightB) width a +above a b = + Array.mapShape + (\((heightA,widthA)::+(heightB,widthB)) -> + if widthA == widthB + then (heightA::+heightB, widthA) + else error "Array.Dim2.above: widths mismatch") $ + Array.append a b + +{- | +prop> :{ + QC.forAll genArray2 $ \xs -> + let (height, Shape.ZeroBased n) = Array.shape xs in + QC.forAll (QC.choose (0, n)) $ \k -> + let ys = Array.reshape + (height, Shape.ZeroBased k ::+ Shape.ZeroBased (n-k)) xs in + ys == Array2.beside (Array2.takeLeft ys) (Array2.takeRight ys) +:} +-} +beside :: + (Shape.C height, Eq height) => + (Shape.C widthA, Shape.C widthB) => + (Storable a) => + Array2 height widthA a -> + Array2 height widthB a -> + Array2 height (widthA::+widthB) a +beside a b = + case (Array.shape a, Array.shape b) of + ((heightA, widthA), (heightB, widthB)) -> + if heightA == heightB + then + Array.reshape (heightA, widthA::+widthB) . + Array.fromStorableVector . + SV.concat . concat . take (Shape.size heightA) $ + zipWith + (\arow brow -> [arow, brow]) + (toRowSlicesInf a) + (toRowSlicesInf b) + else error "Array.Dim2.beside: heights mismatch" + + +takeTop :: + (Shape.C heightA, Shape.C heightB, Shape.C width, Storable a) => + Array2 (heightA::+heightB) width a -> + Array2 heightA width a +takeTop = Array.takeLeft . splitVertically + +takeBottom :: + (Shape.C heightA, Shape.C heightB, Shape.C width, Storable a) => + Array2 (heightA::+heightB) width a -> + Array2 heightB width a +takeBottom = Array.takeRight . splitVertically + +splitVertically :: + (Shape.C heightA, Shape.C heightB, Shape.C width) => + Array2 (heightA::+heightB) width a -> + Array ((heightA,width)::+(heightB,width)) a +splitVertically = + Array.mapShape + (\(heightA::+heightB, width) -> (heightA,width)::+(heightB,width)) + + +takeLeft :: + (Shape.C height, Shape.C widthA, Shape.C widthB, Storable a) => + Array2 height (widthA::+widthB) a -> + Array2 height widthA a +takeLeft a = + case Array.shape a of + (height, widthA::+widthB) -> + let m = Shape.size height + na = Shape.size widthA + nb = Shape.size widthB + in Array.reshape (height, widthA) . Array.fromStorableVector . + SV.concat . take m . map (SV.take na) . + iterate (SV.drop (na+nb)) . + Array.toStorableVector $ a + +takeRight :: + (Shape.C height, Shape.C widthA, Shape.C widthB, Storable a) => + Array2 height (widthA::+widthB) a -> + Array2 height widthB a +takeRight a = + case Array.shape a of + (height, widthA::+widthB) -> + let m = Shape.size height + na = Shape.size widthA + nb = Shape.size widthB + in Array.reshape (height, widthB) . Array.fromStorableVector . + SV.concat . take m . map (SV.take nb) . + iterate (SV.drop (na+nb)) . SV.drop na . + Array.toStorableVector $ a + + +{- | +Only the outer @BoxedArray@ need to be non-empty. + +>>> :{ + let shapeR0 = shapeInt 2; shapeR1 = shapeInt 3 in + let shapeC0 = shapeInt 3; shapeC1 = shapeInt 2 in + let block sh a = Array.replicate sh (a::Word16) in + Array2.fromBlockArray + (Map.singleton 'A' shapeR0 <> Map.singleton 'B' shapeR1) + (Map.singleton '1' shapeC0 <> Map.singleton '2' shapeC1) $ + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [block (shapeR0,shapeC0) 0, block (shapeR0,shapeC1) 1, + block (shapeR1,shapeC0) 2, block (shapeR1,shapeC1) 3] +:} +StorableArray.fromList (fromList [('A',ZeroBased {... 2}),('B',ZeroBased {... 3})],fromList [('1',ZeroBased {... 3}),('2',ZeroBased {... 2})]) [0,0,0,1,1,0,0,0,1,1,2,2,2,3,3,2,2,2,3,3,2,2,2,3,3] + +prop> :{ + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + let blocked = + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [blockA1, blockA2, blockB1, blockB2] in + + transpose (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromNonEmptyBlockArray + (TestBoxedArray.transpose (fmap transpose blocked)) +:} + +prop> :{ + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + QC.forAll genArray2 $ \blockC3 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + let shapeR2 = fst $ Array.shape blockC3 in + let shapeC2 = snd $ Array.shape blockC3 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC2)) $ \blockB3 -> + QC.forAll (genArrayForShape (shapeR2, shapeC0)) $ \blockC1 -> + QC.forAll (genArrayForShape (shapeR2, shapeC1)) $ \blockC2 -> + let blocked = + BoxedArray.fromList (Set.fromList "ABC", Set.fromList "123") + [blockA1, blockA2, blockA3, + blockB1, blockB2, blockB3, + blockC1, blockC2, blockC3] in + + transpose (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromNonEmptyBlockArray + (TestBoxedArray.transpose (fmap transpose blocked)) +:} +-} +fromNonEmptyBlockArray :: + (Ord row, Shape.C height, Eq height) => + (Ord column, Shape.C width, Eq width) => + (Storable a) => + BoxedArray.Array (Set row, Set column) (Array2 height width a) -> + Array2 (Map row height) (Map column width) a +fromNonEmptyBlockArray arr = + let shapes = List.map Array.shape $ BoxedArray.toList arr in + let width = Set.size $ snd $ BoxedArray.shape arr in + let (rowIxs, columnIxs) = + mapPair (Set.toAscList, Set.toAscList) $ BoxedArray.shape arr in + case (ListHT.sieve width shapes, take width shapes) of + (leftColumn@(_:_), topRow@(_:_)) -> + fromBlockArray + (Map.fromList $ List.zip rowIxs $ List.map fst leftColumn) + (Map.fromList $ List.zip columnIxs $ List.map snd topRow) + arr + _ -> errorArray "fromNonEmptyBlockArray" "empty array" + +{- | +Explicit parameters for the shape of the result matrix +allow for working with arrays of zero rows or columns. + +>>> :{ + (id :: Id (array (height, Map Char ShapeInt) Word16)) $ + Array2.fromBlockArray + (Map.singleton 'A' (shapeInt 2) <> Map.singleton 'B' (shapeInt 3)) + Map.empty $ + BoxedArray.fromList (Set.fromList "AB", Set.empty) [] +:} +StorableArray.fromList (fromList [('A',ZeroBased {... 2}),('B',ZeroBased {... 3})],fromList []) [] + +prop> :{ + QC.forAll genArray2 $ \block -> + let height = Map.singleton 'A' $ fst $ Array.shape block in + let width = Map.singleton '1' $ snd $ Array.shape block in + + Array.reshape (height,width) block + QC.=== + Array2.fromBlockArray height width + (BoxedArray.replicate (Set.singleton 'A', Set.singleton '1') block) +:} +-} +fromBlockArray :: + (Ord row, Shape.C height, Eq height) => + (Ord column, Shape.C width, Eq width) => + (Storable a) => + Map row height -> Map column width -> + BoxedArray.Array (Set row, Set column) (Array2 height width a) -> + Array2 (Map row height) (Map column width) a +fromBlockArray height width = + Array.reshape (height, width) . Array.fromStorableVector . + SV.concat . List.concat . List.concatMap List.transpose . + ListHT.sliceVertical (Map.size width) . BoxedArray.toList . + BoxedArray.zipWith checkSliceBlock + (BoxedArray.cartesian + (BoxedArray.fromMap height) (BoxedArray.fromMap width)) +{- +[[[111,111],[222,222]],[[333,333],[444,444]]] + | + v +[111,222,111,222,333,444,333,444] +-} + + + +class (Shape.C sh) => ShapeSequence sh where + switchSequence :: + f Shape.Zero -> + (forall sh0 shs. (Shape.C sh0, Eq sh0, ShapeSequence shs) => + f (sh0::+shs)) -> + f sh + +instance ShapeSequence Shape.Zero where + switchSequence f _ = f + +instance + (Shape.C sh, Eq sh, ShapeSequence shs) => + ShapeSequence (sh::+shs) where + switchSequence _ f = f + + +type family BlockFunction heights widths a r +type instance BlockFunction Shape.Zero widths a r = r +type instance BlockFunction (height::+heights) widths a r = + RowFunction height widths a (BlockFunction heights widths a r) + +newtype CreateBig widths a r heights = + CreateBig { + getCreateBig :: + heights -> widths -> + ([[SV.Vector a]] -> r) -> + BlockFunction heights widths a r + } + +createBig :: + (ShapeSequence heights, ShapeSequence widths, Storable a) => + heights -> widths -> + ([[SV.Vector a]] -> r) -> + BlockFunction heights widths a r +createBig = + getCreateBig $ + switchSequence + (CreateBig $ \Shape.Zero _widths cons -> cons []) + (CreateBig $ \(height::+heights) widths cons -> + createBlockRow heights widths cons height widths id) + + +type family RowFunction height widths a r +type instance RowFunction height Shape.Zero a r = r +type instance RowFunction height (width::+widths) a r = + Array2 height width a -> RowFunction height widths a r + +newtype CreateBlockRow heightsRem widthsRem height a r widths = + CreateBlockRow { + getCreateBlockRow :: + heightsRem -> widthsRem -> ([[SV.Vector a]] -> r) -> + height -> widths -> ([[SV.Vector a]] -> [[SV.Vector a]]) -> + RowFunction height widths a + (BlockFunction heightsRem widthsRem a r) + } + +createBlockRow :: + (ShapeSequence heightsRem, ShapeSequence widthsRem) => + (Shape.C height, Eq height, ShapeSequence widths, Storable a) => + heightsRem -> widthsRem -> ([[SV.Vector a]] -> r) -> + height -> widths -> ([[SV.Vector a]] -> [[SV.Vector a]]) -> + RowFunction height widths a + (BlockFunction heightsRem widthsRem a r) +createBlockRow = + getCreateBlockRow $ + switchSequence + (CreateBlockRow $ + \heightsRem widthsRem consBig _height Shape.Zero consRow -> + createBig heightsRem widthsRem + (consBig . (List.transpose (consRow []) ++))) + (CreateBlockRow $ + \heightsRem widthsRem consBig height (width::+widths) consRow blk -> + createBlockRow + heightsRem widthsRem consBig + height widths + (consRow . (checkSliceBlock (height,width) blk :))) + + +{- | +prop> :{ + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + let shapeR = shapeR0::+shapeR1::+Shape.Zero in + let shapeC = shapeC0::+shapeC1::+Shape.Zero in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + let blocked = + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [blockA1, blockA2, blockB1, blockB2] in + + Array.reshape (shapeR, shapeC) + (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromBlocks shapeR shapeC Proxy + blockA1 blockA2 + blockB1 blockB2 +:} +-} +fromBlocks :: + (ShapeSequence height, ShapeSequence width, Storable a) => + height -> width -> Proxy a -> + BlockFunction height width a (Array2 height width a) +fromBlocks height width proxy = + createBig height width + (Array.reshape (height, width) . Array.fromStorableVector . + idSV proxy . SV.concat . List.concat) + +idSV :: Proxy a -> SV.Vector a -> SV.Vector a +idSV Proxy = id + + + +data BlockArray shape a = BlockArray shape [[SV.Vector a]] +type BlockMatrix height width = BlockArray (height, width) + +block :: + (Block block, Shape.C height, Shape.C width, Storable a) => + block (height, width) a -> BlockMatrix height width a +block = blockPrivate + +class Block block where + blockPrivate :: + (Shape.C height, Shape.C width, Storable a) => + block (height, width) a -> BlockMatrix height width a + +instance Block BlockArray where + blockPrivate = id + +instance Block Array where + blockPrivate arr = + BlockArray (Array.shape arr) + (map (:[]) $ take (Shape.size $ fst $ Array.shape arr) $ + toRowSlicesInf arr) + +blockAbove :: + (Eq width) => + BlockMatrix heightA width a -> BlockMatrix heightB width a -> + BlockMatrix (heightA::+heightB) width a +blockAbove (BlockArray (heightA,widthA) a) (BlockArray (heightB,widthB) b) = + BlockArray + (if widthA == widthB + then (heightA::+heightB, widthA) + else error "Array.Dim2.blockAbove: widths mismatch") + (a ++ b) + +blockBeside :: + (Eq height) => + BlockMatrix height widthA a -> BlockMatrix height widthB a -> + BlockMatrix height (widthA::+widthB) a +blockBeside (BlockArray (heightA,widthA) a) (BlockArray (heightB,widthB) b) = + BlockArray + (if heightA == heightB + then (heightA, widthA::+widthB) + else error "Array.Dim2.beside: heights mismatch") + (zipWith (++) a b) + +infixr 2 &=== +infixr 3 &||| + +(&===) :: + (Block blockA, Block blockB) => + (Shape.C heightA, Shape.C heightB) => + (Shape.C width, Eq width) => + (Storable a) => + blockA (heightA,width) a -> blockB (heightB,width) a -> + BlockMatrix (heightA::+heightB) width a +(&===) a b = blockAbove (block a) (block b) + +(&|||) :: + (Block blockA, Block blockB) => + (Shape.C height, Eq height) => + (Shape.C widthA, Shape.C widthB) => + (Storable a) => + blockA (height,widthA) a -> blockB (height,widthB) a -> + BlockMatrix height (widthA::+widthB) a +(&|||) a b = blockBeside (block a) (block b) + + + +{- | +prop> :{ + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB3 -> + QC.forAll + (liftA2 + (\char0 char1 -> Shape.Range (min char0 char1) (max char0 char1)) + (QC.choose ('a','k')) (QC.choose ('a','k'))) $ + \shapeC1 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB3 in + let shapeC2 = snd $ Array.shape blockB3 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC1)) $ \blockB2 -> + + Array2.fromBlockMatrix + (blockA1 &||| Array2.beside blockA2 blockA3 + &=== + blockB1 &||| blockB2 &||| blockB3) + QC.=== + Array.reshape + (shapeR0::+shapeR1, shapeC0::+shapeC1::+shapeC2) + (Array2.fromBlocks + (shapeR0::+shapeR1::+Shape.Zero) + (shapeC0::+shapeC1::+shapeC2::+Shape.Zero) + Proxy + blockA1 blockA2 blockA3 + blockB1 blockB2 blockB3) +:} + +prop> :{ + QC.forAll + (liftA2 + (\char0 char1 -> Shape.Range (min char0 char1) (max char0 char1)) + (QC.choose ('a','k')) (QC.choose ('a','k'))) $ + \shapeR0 -> + QC.forAll + (liftA2 Shape.Shifted (QC.choose (-10,10)) (QC.choose (0,10::Int))) $ + \shapeR1 -> + let shapeR2 = () in + QC.forAll (fmap Shape.ZeroBased (QC.choose (0,10::Int))) $ + \shapeC0 -> + QC.forAll (fmap Shape.OneBased (QC.choose (0,10::Int))) $ + \shapeC1 -> + let shapeC2 :: Shape.Enumeration Ordering + shapeC2 = Shape.Enumeration in + + QC.forAll (genArrayForShape (shapeR0, shapeC0)) $ \blockA1 -> + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC1)) $ \blockB2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC2)) $ \blockB3 -> + QC.forAll (genArrayForShape (shapeR2, shapeC0)) $ \blockC1 -> + QC.forAll (genArrayForShape (shapeR2, shapeC1)) $ \blockC2 -> + QC.forAll (genArrayForShape (shapeR2, shapeC2)) $ \blockC3 -> + + Array2.fromBlockMatrix + (blockA1 &||| blockA2 &||| blockA3 + &=== + blockB1 &||| blockB2 &||| blockB3 + &=== + blockC1 &||| blockC2 &||| blockC3) + QC.=== + Array2.beside + (Array2.above blockA1 $ Array2.above blockB1 blockC1) + (Array2.above + (Array2.beside blockA2 blockA3) + (Array2.beside + (Array2.above blockB2 blockC2) + (Array2.above blockB3 blockC3))) +:} +-} +fromBlockMatrix :: + (Shape.C height, Shape.C width, Storable a) => + BlockMatrix height width a -> Array2 height width a +fromBlockMatrix (BlockArray (height, width) rows) = + Array.reshape (height, width) . + Array.fromStorableVector . SV.concat . List.concat $ rows + + +checkSliceBlock :: + (Shape.C sh0, Eq sh0, Shape.C sh1, Eq sh1, Storable a) => + (sh0, sh1) -> Array (sh0, sh1) a -> [SV.Vector a] +checkSliceBlock sh blk = + if sh == Array.shape blk + then toRowSlices blk + else errorArray "fromBlockArray" "block shapes mismatch" + +toRowSlices :: + (Shape.C sh0, Shape.C sh1, Storable a) => + Array2 sh0 sh1 a -> [SV.Vector a] +toRowSlices arr = + SV.sliceVertical (Shape.size $ snd $ Array.shape arr) $ + Array.toStorableVector arr + +toRowSlicesInf :: + (Shape.C sh0, Shape.C sh1, Storable a) => + Array2 sh0 sh1 a -> [SV.Vector a] +toRowSlicesInf arr = + let n = Shape.size $ snd $ Array.shape arr in + map (SV.take n) . iterate (SV.drop n) . Array.toStorableVector $ arr + + +errorArray :: String -> String -> a +errorArray name msg = + error ("Array.Comfort.Storable.Dim2." ++ name ++ ": " ++ msg) diff --git a/src/Data/Array/Comfort/Storable/Mutable.hs b/src/Data/Array/Comfort/Storable/Mutable.hs --- a/src/Data/Array/Comfort/Storable/Mutable.hs +++ b/src/Data/Array/Comfort/Storable/Mutable.hs @@ -5,7 +5,7 @@ shape, MutArray.new, - read, + read, MutArray.readMaybe, write, update, toList, @@ -19,6 +19,7 @@ import qualified Data.Array.Comfort.Storable.Mutable.Unchecked as MutArray import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Mutable.Unchecked (Array) +import Data.Maybe (fromMaybe) import Foreign.Marshal.Array (pokeArray) import Foreign.Storable (Storable) @@ -36,9 +37,9 @@ (PrimMonad m, Shape.Indexed sh, Storable a) => Array m sh a -> Shape.Index sh -> m a read arr ix = - if Shape.inBounds (shape arr) ix - then MutArray.read arr ix - else error "Array.Comfort.Storable.Mutable.read: index out of bounds" + fromMaybe + (error "Array.Comfort.Storable.Mutable.read: index out of bounds") + (MutArray.readMaybe arr ix) write :: (PrimMonad m, Shape.Indexed sh, Storable a) => diff --git a/src/Data/Array/Comfort/Storable/Mutable/Private.hs b/src/Data/Array/Comfort/Storable/Mutable/Private.hs --- a/src/Data/Array/Comfort/Storable/Mutable/Private.hs +++ b/src/Data/Array/Comfort/Storable/Mutable/Private.hs @@ -13,6 +13,7 @@ import Control.Monad (liftM) import Control.Applicative ((<$>)) +import Data.Either.HT (maybeRight) import Data.Tuple.HT (mapFst) import qualified Prelude as P @@ -100,6 +101,18 @@ Array m sh a -> Shape.Index sh -> m a read (Array sh fptr) ix = withArrayPtr fptr $ flip peekElemOff (Shape.uncheckedOffset sh ix) + +readMaybe :: + (PrimMonad m, Shape.Indexed sh, Storable a) => + Array m sh a -> Shape.Index sh -> Maybe (m a) +readMaybe arr = maybeRight . readEither arr + +readEither :: + (PrimMonad m, Shape.Indexed sh, Storable a) => + Array m sh a -> Shape.Index sh -> Either String (m a) +readEither (Array sh fptr) ix = + fmap (withArrayPtr fptr . flip peekElemOff) $ + Shape.getChecked $ Shape.unifiedOffset sh ix write :: (PrimMonad m, Shape.Indexed sh, Storable a) => diff --git a/src/Data/Array/Comfort/Storable/Mutable/Unchecked.hs b/src/Data/Array/Comfort/Storable/Mutable/Unchecked.hs --- a/src/Data/Array/Comfort/Storable/Mutable/Unchecked.hs +++ b/src/Data/Array/Comfort/Storable/Mutable/Unchecked.hs @@ -15,6 +15,7 @@ MutArray.unsafeCreateWithSizeAndResult, MutArray.withPtr, MutArray.read, + MutArray.readMaybe, MutArray.write, MutArray.update, MutArray.toList, diff --git a/src/Data/Array/Comfort/Storable/Private.hs b/src/Data/Array/Comfort/Storable/Private.hs --- a/src/Data/Array/Comfort/Storable/Private.hs +++ b/src/Data/Array/Comfort/Storable/Private.hs @@ -3,11 +3,16 @@ import qualified Data.Array.Comfort.Storable.Mutable.Private as MutArray import qualified Data.Array.Comfort.Shape as Shape +import Data.Semigroup (Semigroup((<>))) +import Data.Monoid (Monoid(mempty, mappend)) import qualified Foreign.Marshal.Array.Guarded as Alloc -import Foreign.Storable (Storable, ) -import Foreign.ForeignPtr (ForeignPtr, ) +import Foreign.Marshal.Array (copyArray, advancePtr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Storable (Storable) +import System.IO.Unsafe (unsafePerformIO) + import Control.DeepSeq (NFData, rnf) import Control.Monad.Primitive (PrimMonad, unsafeIOToPrim) import Control.Monad.ST (runST) @@ -106,3 +111,26 @@ unsafeThaw (Array sh fptr) = unsafeIOToPrim $ liftM (MutArray.Array sh) $ Alloc.thawInplace (Shape.size sh) fptr + + +instance (Shape.AppendSemigroup sh, Storable a) => Semigroup (Array sh a) where + (<>) = append Shape.append + +instance (Shape.AppendMonoid sh, Storable a) => Monoid (Array sh a) where + mappend = (<>) + mempty = fromList Shape.empty [] + +append :: + (Shape.C shx, Shape.C shy, Storable a) => + (shx -> shy -> shz) -> + Array shx a -> Array shy a -> Array shz a +append appendShape (Array shX x) (Array shY y) = + unsafePerformIO $ + let sizeX = Shape.size shX in + let sizeY = Shape.size shY in + fmap (Array (appendShape shX shY) . fst) $ + Alloc.create (sizeX+sizeY) $ \zPtr -> + withForeignPtr x $ \xPtr -> + withForeignPtr y $ \yPtr -> do + copyArray zPtr xPtr sizeX + copyArray (advancePtr zPtr sizeX) yPtr sizeY diff --git a/src/Data/Array/Comfort/Storable/Unchecked.hs b/src/Data/Array/Comfort/Storable/Unchecked.hs --- a/src/Data/Array/Comfort/Storable/Unchecked.hs +++ b/src/Data/Array/Comfort/Storable/Unchecked.hs @@ -11,10 +11,14 @@ (Priv.!), unsafeCreate, unsafeCreateWithSize, + unsafeCreateWithSizes, + unsafeCreateWithAutoSizes, unsafeCreateWithSizeAndResult, Priv.toList, Priv.fromList, Priv.vectorFromList, + fromStorableVector, + toStorableVector, map, mapWithIndex, @@ -36,10 +40,13 @@ import qualified Data.Array.Comfort.Storable.Unchecked.Monadic as Monadic import qualified Data.Array.Comfort.Storable.Private as Priv import qualified Data.Array.Comfort.Storable.Memory as Memory +import qualified Data.Array.Comfort.Shape.SubSize as SubSize import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Private (Array(Array), mapShape) -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) +import qualified Data.StorableVector.Base as SVB + import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Array (copyArray, advancePtr) import Foreign.Storable (Storable, poke, peek) @@ -83,6 +90,18 @@ sh -> (Int -> Ptr a -> IO ()) -> Array sh a unsafeCreateWithSize sh arr = runST (Monadic.unsafeCreateWithSize sh arr) +unsafeCreateWithSizes :: + (Shape.C sh, Storable a) => + SubSize.T sh nsize -> sh -> (nsize -> Ptr a -> IO ()) -> Array sh a +unsafeCreateWithSizes sub sh arr = + runST (Monadic.unsafeCreateWithSizes sub sh arr) + +unsafeCreateWithAutoSizes :: + (Shape.C sh, sh ~ SubSize.ToShape nsize, SubSize.C nsize, + Storable a) => + sh -> (nsize -> Ptr a -> IO ()) -> Array sh a +unsafeCreateWithAutoSizes = unsafeCreateWithSizes SubSize.auto + unsafeCreateWithSizeAndResult :: (Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO b) -> (Array sh a, b) @@ -90,13 +109,26 @@ runST (Monadic.unsafeCreateWithSizeAndResult sh arr) +fromStorableVector :: + (Storable a) => SVB.Vector a -> Array (Shape.ZeroBased Int) a +fromStorableVector xs = + case SVB.toForeignPtr xs of + (fptr,0,n) -> Array (Shape.ZeroBased n) fptr + (fptr,s,n) -> + takeRight $ Array (Shape.ZeroBased s ::+ Shape.ZeroBased n) fptr + +toStorableVector :: (Shape.C sh, Storable a) => Array sh a -> SVB.Vector a +toStorableVector (Array sh fptr) = + SVB.fromForeignPtr fptr $ Shape.size sh + + map :: (Shape.C sh, Storable a, Storable b) => (a -> b) -> Array sh a -> Array sh b map f (Array sh a) = - unsafeCreate sh $ \dstPtr -> + unsafeCreateWithSize sh $ \n dstPtr -> withForeignPtr a $ \srcPtr -> - sequence_ $ List.take (Shape.size sh) $ + sequence_ $ List.take n $ List.zipWith (\src dst -> poke dst . f =<< peek src) (iterate (flip advancePtr 1) srcPtr) @@ -119,11 +151,11 @@ (Shape.C sh, Storable a, Storable b, Storable c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c zipWith f (Array _sh a) (Array sh b) = - unsafeCreate sh $ \dstPtr -> + unsafeCreateWithSize sh $ \n dstPtr -> withForeignPtr a $ \srcAPtr -> withForeignPtr b $ \srcBPtr -> - sequence_ $ List.take (Shape.size sh) $ - zipWith3 + sequence_ $ List.take n $ + List.zipWith3 (\srcA srcB dst -> poke dst =<< liftA2 f (peek srcA) (peek srcB)) (iterate (flip advancePtr 1) srcAPtr) (iterate (flip advancePtr 1) srcBPtr) @@ -136,17 +168,13 @@ singleton :: (Storable a) => a -> Array () a singleton a = unsafeCreate () $ flip poke a + +infixr 5 `append` + append :: (Shape.C shx, Shape.C shy, Storable a) => - Array shx a -> Array shy a -> Array (shx:+:shy) a -append (Array shX x) (Array shY y) = - unsafeCreate (shX:+:shY) $ \zPtr -> - withForeignPtr x $ \xPtr -> - withForeignPtr y $ \yPtr -> do - let sizeX = Shape.size shX - let sizeY = Shape.size shY - copyArray zPtr xPtr sizeX - copyArray (advancePtr zPtr sizeX) yPtr sizeY + Array shx a -> Array shy a -> Array (shx::+shy) a +append = Priv.append (::+) {- | prop> \(QC.NonNegative n) (Array16 x) -> x == Array.mapShape (Shape.ZeroBased . Shape.size) (Array.append (Array.take n x) (Array.drop n x)) @@ -160,7 +188,7 @@ splitN :: (Integral n, Storable a) => n -> Array (Shape.ZeroBased n) a -> - Array (Shape.ZeroBased n :+: Shape.ZeroBased n) a + Array (Shape.ZeroBased n ::+ Shape.ZeroBased n) a splitN n = mapShape (Shape.zeroBasedSplit n) {- | @@ -168,19 +196,19 @@ -} takeLeft :: (Shape.C sh0, Shape.C sh1, Storable a) => - Array (sh0:+:sh1) a -> Array sh0 a + Array (sh0::+sh1) a -> Array sh0 a takeLeft = - takeCenter . mapShape (\(sh0 :+: sh1) -> (Shape.Zero :+: sh0 :+: sh1)) + takeCenter . mapShape (\(sh0 ::+ sh1) -> (Shape.Zero ::+ sh0 ::+ sh1)) takeRight :: (Shape.C sh0, Shape.C sh1, Storable a) => - Array (sh0:+:sh1) a -> Array sh1 a + Array (sh0::+sh1) a -> Array sh1 a takeRight = - takeCenter . mapShape (\(sh0 :+: sh1) -> (sh0 :+: sh1 :+: Shape.Zero)) + takeCenter . mapShape (\(sh0 ::+ sh1) -> (sh0 ::+ sh1 ::+ Shape.Zero)) split :: (Shape.C sh0, Shape.C sh1, Storable a) => - Array (sh0:+:sh1) a -> (Array sh0 a, Array sh1 a) + Array (sh0::+sh1) a -> (Array sh0 a, Array sh1 a) split x = (takeLeft x, takeRight x) {- | @@ -188,8 +216,8 @@ -} takeCenter :: (Shape.C sh0, Shape.C sh1, Shape.C sh2, Storable a) => - Array (sh0:+:sh1:+:sh2) a -> Array sh1 a -takeCenter (Array (sh0:+:sh1:+:_sh2) x) = + Array (sh0::+sh1::+sh2) a -> Array sh1 a +takeCenter (Array (sh0::+sh1::+_sh2) x) = unsafeCreateWithSize sh1 $ \k yPtr -> withForeignPtr x $ \xPtr -> copyArray yPtr (advancePtr xPtr (Shape.size sh0)) k diff --git a/src/Data/Array/Comfort/Storable/Unchecked/Creator.hs b/src/Data/Array/Comfort/Storable/Unchecked/Creator.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Comfort/Storable/Unchecked/Creator.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE Rank2Types #-} +module Data.Array.Comfort.Storable.Unchecked.Creator where + +import qualified Data.Array.Comfort.Shape.SubSize as SubSize +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Private (Array(Array)) + +import Foreign.Storable (Storable, ) +import Foreign.Ptr (Ptr, ) + +import qualified Foreign.Marshal.Array.Guarded as Alloc +import qualified Control.Monad.Trans.Cont as MC +import Control.Monad.Primitive (PrimMonad, unsafeIOToPrim) + +import Data.Biapplicative (Biapplicative(bipure, (<<*>>))) +import Data.Bifunctor (Bifunctor(bimap)) + +import Data.Tuple.HT (mapFst) + + +newtype Creator arr ptr = Creator (forall a. (ptr -> IO a) -> IO (arr, a)) + +liftIO :: IO ptr -> Creator () ptr +liftIO act = Creator $ \f -> fmap ((,) ()) $ f =<< act + +liftContT :: (forall a. MC.ContT a IO ptr) -> Creator () ptr +liftContT act = Creator $ \f -> fmap ((,) ()) $ MC.runContT act f + +instance Functor (Creator arr) where + fmap g (Creator act) = Creator $ \f -> act (f . g) + + +pair :: + Creator arr0 ptr0 -> Creator arr1 ptr1 -> + Creator (arr0,arr1) (ptr0,ptr1) +pair (Creator act0) (Creator act1) = + Creator $ \f -> + fmap (\(arr0,(arr1,a)) -> ((arr0,arr1),a)) $ + act0 $ \ptr0 -> + act1 $ \ptr1 -> + f (ptr0, ptr1) + +instance Bifunctor Creator where + bimap g h (Creator act) = Creator $ \f -> fmap (mapFst g) $ act (f . h) + +instance Biapplicative Creator where + bipure a b = Creator $ \f -> fmap ((,) a) $ f b + creator0 <<*>> creator1 = + bimap (uncurry id) (uncurry id) $ pair creator0 creator1 + +unsafeRun :: (PrimMonad m) => Creator arr ptr -> (ptr -> IO ()) -> m arr +unsafeRun (Creator act) f = unsafeIOToPrim $ fmap (\(arr,()) -> arr) $ act f + +unsafeRunWithResult :: + (PrimMonad m) => Creator arr ptr -> (ptr -> IO b) -> m (arr, b) +unsafeRunWithResult (Creator act) f = unsafeIOToPrim $ act f + +{-# INLINE create #-} +create :: + (Shape.C sh, Storable a) => + sh -> Creator (Array sh a) (Ptr a) +create sh = fmap snd $ createWithSize sh + +{-# INLINE createWithSize #-} +createWithSize :: + (Shape.C sh, Storable a) => + sh -> Creator (Array sh a) (Int, Ptr a) +createWithSize sh = + let size = Shape.size sh + in Creator $ \f -> + fmap (mapFst (Array sh)) $ Alloc.create size $ curry f size + +{-# INLINE createWithSizes #-} +createWithSizes :: + (Shape.C sh, Storable a) => + SubSize.T sh nsize -> sh -> Creator (Array sh a) (nsize, Ptr a) +createWithSizes (SubSize.Cons subSize) sh = + let (size, subSizes) = subSize sh + in Creator $ \f -> + fmap (mapFst (Array sh)) $ Alloc.create size $ curry f subSizes diff --git a/src/Data/Array/Comfort/Storable/Unchecked/Monadic.hs b/src/Data/Array/Comfort/Storable/Unchecked/Monadic.hs --- a/src/Data/Array/Comfort/Storable/Unchecked/Monadic.hs +++ b/src/Data/Array/Comfort/Storable/Unchecked/Monadic.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Data.Array.Comfort.Storable.Unchecked.Monadic where +import qualified Data.Array.Comfort.Shape.SubSize as SubSize import qualified Data.Array.Comfort.Shape as Shape import Data.Array.Comfort.Storable.Private (Array(Array)) @@ -23,9 +26,30 @@ sh -> (Int -> Ptr a -> IO ()) -> m (Array sh a) unsafeCreateWithSize sh f = liftM fst $ unsafeCreateWithSizeAndResult sh f +unsafeCreateWithSizes :: + (PrimMonad m, Shape.C sh, Storable a) => + SubSize.T sh nsize -> sh -> (nsize -> Ptr a -> IO ()) -> m (Array sh a) +unsafeCreateWithSizes sub sh f = + liftM fst $ unsafeCreateWithSizesAndResult sub sh f + unsafeCreateWithSizeAndResult :: (PrimMonad m, Shape.C sh, Storable a) => sh -> (Int -> Ptr a -> IO b) -> m (Array sh a, b) unsafeCreateWithSizeAndResult sh f = unsafeIOToPrim $ let size = Shape.size sh in fmap (mapFst (Array sh)) $ Alloc.create size $ f size + +unsafeCreateWithSizesAndResult :: + (PrimMonad m, Shape.C sh, Storable a) => + SubSize.T sh nsize -> sh -> (nsize -> Ptr a -> IO b) -> m (Array sh a, b) +unsafeCreateWithSizesAndResult (SubSize.Cons subSize) sh f = unsafeIOToPrim $ + let (size, subSizes) = subSize sh + in fmap (mapFst (Array sh)) $ Alloc.create size $ f subSizes + +_unsafeCreateWithSizesAndResult :: + (PrimMonad m, Storable a, + SubSize.C nsize, SubSize.ToShape nsize ~ sh, Shape.C sh) => + sh -> (Int -> nsize -> Ptr a -> IO b) -> m (Array sh a, b) +_unsafeCreateWithSizesAndResult sh f = unsafeIOToPrim $ + let (size, subSizes) = SubSize.evaluate sh + in fmap (mapFst (Array sh)) $ Alloc.create size $ f size subSizes diff --git a/test-module.list b/test-module.list deleted file mode 100644 --- a/test-module.list +++ /dev/null @@ -1,3 +0,0 @@ -Data.Array.Comfort.Shape -Data.Array.Comfort.Storable -Data.Array.Comfort.Storable.Unchecked diff --git a/test/DocTest/Data/Array/Comfort/Boxed.hs b/test/DocTest/Data/Array/Comfort/Boxed.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Data/Array/Comfort/Boxed.hs @@ -0,0 +1,40 @@ +-- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Boxed.hs +{-# LINE 62 "src/Data/Array/Comfort/Boxed.hs" #-} + +module DocTest.Data.Array.Comfort.Boxed where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 63 "src/Data/Array/Comfort/Boxed.hs" #-} +import qualified Data.Array.Comfort.Boxed as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Boxed (Array, (!)) + +import qualified Test.QuickCheck as QC + +type ShapeInt = Shape.ZeroBased Int + +genArray2 :: QC.Gen (Array (ShapeInt,ShapeInt) Char) +genArray2 = do + xs <- QC.arbitrary + let n = length xs + (k,m) <- + if n == 0 + then QC.elements [(,) 0, flip (,) 0] <*> QC.choose (1,20) + else fmap (\m -> (div n m, m)) $ QC.choose (1,n) + return $ + Array.fromList (Shape.ZeroBased k, Shape.ZeroBased m) $ take (k*m) xs + +test :: DocTest.T () +test = do + DocTest.printPrefix "Data.Array.Comfort.Boxed:201: " +{-# LINE 201 "src/Data/Array/Comfort/Boxed.hs" #-} + DocTest.property( +{-# LINE 201 "src/Data/Array/Comfort/Boxed.hs" #-} + + QC.forAll genArray2 $ \xs -> + let shape = Array.shape xs in + Shape.size shape > 0 QC.==> + QC.forAll (QC.elements $ Shape.indices shape) $ \(ix0,ix1) -> + Array.pick xs ix0 ! ix1 == xs!(ix0,ix1) + ) diff --git a/test/DocTest/Data/Array/Comfort/Boxed/Unchecked.hs b/test/DocTest/Data/Array/Comfort/Boxed/Unchecked.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Data/Array/Comfort/Boxed/Unchecked.hs @@ -0,0 +1,54 @@ +-- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Boxed/Unchecked.hs +{-# LINE 38 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + +module DocTest.Data.Array.Comfort.Boxed.Unchecked where + +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 39 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} +import qualified Data.Array.Comfort.Boxed as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Boxed (Array, (!)) +import Data.Tuple.HT (swap) +import Control.Applicative ((<$>)) + +import qualified Test.QuickCheck as QC + +type ShapeInt = Shape.ZeroBased Int + +genArray :: QC.Gen (Array ShapeInt Char) +genArray = Array.vectorFromList <$> QC.arbitrary + +newtype ArrayChar = ArrayChar (Array ShapeInt Char) + deriving (Show) + +instance QC.Arbitrary ArrayChar where + arbitrary = fmap ArrayChar genArray + + +transpose :: + (Shape.Indexed sh0, Shape.Indexed sh1) => + Array (sh0,sh1) a -> Array (sh1,sh0) a +transpose a = + fmap (\(i,j) -> a!(j,i)) $ Array.indices $ swap $ Array.shape a + +test :: DocTest.T () +test = do + DocTest.printPrefix "Data.Array.Comfort.Boxed.Unchecked:173: " +{-# LINE 173 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + DocTest.property( +{-# LINE 173 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + \(QC.NonNegative n) (ArrayChar x) -> x == Array.mapShape (Shape.ZeroBased . Shape.size) (Array.append (Array.take n x) (Array.drop n x)) + ) + DocTest.printPrefix "Data.Array.Comfort.Boxed.Unchecked:188: " +{-# LINE 188 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + DocTest.property( +{-# LINE 188 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + \(ArrayChar x) (ArrayChar y) -> let xy = Array.append x y in x == Array.takeLeft xy && y == Array.takeRight xy + ) + DocTest.printPrefix "Data.Array.Comfort.Boxed.Unchecked:208: " +{-# LINE 208 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + DocTest.property( +{-# LINE 208 "src/Data/Array/Comfort/Boxed/Unchecked.hs" #-} + \(ArrayChar x) (ArrayChar y) (ArrayChar z) -> let xyz = Array.append x $ Array.append y z in y == Array.takeCenter xyz + ) diff --git a/test/DocTest/Data/Array/Comfort/Shape.hs b/test/DocTest/Data/Array/Comfort/Shape.hs --- a/test/DocTest/Data/Array/Comfort/Shape.hs +++ b/test/DocTest/Data/Array/Comfort/Shape.hs @@ -1,129 +1,263 @@ -- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Shape.hs -{-# LINE 65 "src/Data/Array/Comfort/Shape.hs" #-} +{-# LINE 129 "src/Data/Array/Comfort/Shape.hs" #-} module DocTest.Data.Array.Comfort.Shape where import Test.DocTest.Base import qualified Test.DocTest.Driver as DocTest -{-# LINE 66 "src/Data/Array/Comfort/Shape.hs" #-} +{-# LINE 130 "src/Data/Array/Comfort/Shape.hs" #-} import qualified Data.Array.Comfort.Shape as Shape +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) +import Test.ChasingBottoms.IsBottom (isBottom) +import Control.DeepSeq (rnf) + test :: DocTest.T () test = do - DocTest.printPrefix "Data.Array.Comfort.Shape:128: " -{-# LINE 128 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 128 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices ()) + DocTest.printPrefix "Data.Array.Comfort.Shape:345: " +{-# LINE 345 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 345 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices () + ) [ExpectedLine [LineChunk "[()]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:150: " -{-# LINE 150 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 150 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.ZeroBased (7::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:368: " +{-# LINE 368 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 368 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.ZeroBased (7::Int)) + ) [ExpectedLine [LineChunk "[0,1,2,3,4,5,6]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:201: " -{-# LINE 201 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 201 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.OneBased (7::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:426: " +{-# LINE 426 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 426 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.OneBased (7::Int)) + ) [ExpectedLine [LineChunk "[1,2,3,4,5,6,7]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:249: " -{-# LINE 249 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 249 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.Range (-5) (5::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:476: " +{-# LINE 476 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 476 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.Range (-5) (5::Int)) + ) [ExpectedLine [LineChunk "[-5,-4,-3,-2,-1,0,1,2,3,4,5]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:251: " -{-# LINE 251 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 251 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.Range (-1,-1) (1::Int,1::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:478: " +{-# LINE 478 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 478 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.Range (-1,-1) (1::Int,1::Int)) + ) [ExpectedLine [LineChunk "[(-1,-1),(-1,0),(-1,1),(0,-1),(0,0),(0,1),(1,-1),(1,0),(1,1)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:301: " -{-# LINE 301 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 301 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.Shifted (-4) (8::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:528: " +{-# LINE 528 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 528 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.Shifted (-4) (8::Int)) + ) [ExpectedLine [LineChunk "[-4,-3,-2,-1,0,1,2,3]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:373: " -{-# LINE 373 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 373 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.Enumeration :: Shape.Enumeration Ordering)) + DocTest.printPrefix "Data.Array.Comfort.Shape:599: " +{-# LINE 599 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 599 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.Enumeration :: Shape.Enumeration Ordering) + ) [ExpectedLine [LineChunk "[LT,EQ,GT]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:428: " -{-# LINE 428 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 428 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Set.fromList "comfort")) + DocTest.printPrefix "Data.Array.Comfort.Shape:663: " +{-# LINE 663 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 663 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Set.fromList "comfort") + ) [ExpectedLine [LineChunk "\"cfmort\""]] - DocTest.printPrefix "Data.Array.Comfort.Shape:454: " -{-# LINE 454 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 454 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices $ fmap Shape.ZeroBased $ Map.fromList [('b', (0::Int)), ('a', 5), ('c', 2)]) + DocTest.printPrefix "Data.Array.Comfort.Shape:694: " +{-# LINE 694 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 694 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (IntSet.fromList [3,1,4,1,5,9,2,6,5,3]) + ) + [ExpectedLine [LineChunk "[1,2,3,4,5,6,9]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:727: " +{-# LINE 727 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 727 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ fmap Shape.ZeroBased $ Map.fromList [('b', (0::Int)), ('a', 5), ('c', 2)] + ) [ExpectedLine [LineChunk "[('a',0),('a',1),('a',2),('a',3),('a',4),('c',0),('c',1)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:528: " -{-# LINE 528 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 528 "src/Data/Array/Comfort/Shape.hs" #-} - ( - let sh2 = (Shape.ZeroBased (2::Int), Shape.ZeroBased (2::Int)) in - let sh3 = (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) in - (Shape.offset sh3 $ Shape.indexFromOffset sh2 3, - Shape.offset (Shape.Deferred sh3) $ - Shape.indexFromOffset (Shape.Deferred sh2) 3) + DocTest.printPrefix "Data.Array.Comfort.Shape:785: " +{-# LINE 785 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 785 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ IntMap.fromList [(2, Set.fromList "abc"), (0, Set.fromList "a"), (1, Set.fromList "d")] ) + [ExpectedLine [LineChunk "[(0,'a'),(1,'d'),(2,'a'),(2,'b'),(2,'c')]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:851: " +{-# LINE 851 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 851 "src/Data/Array/Comfort/Shape.hs" #-} + + let sh2 = (Shape.ZeroBased (2::Int), Shape.ZeroBased (2::Int)) in + let sh3 = (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) in + (Shape.offset sh3 $ Shape.indexFromOffset sh2 3, + Shape.offset (Shape.Deferred sh3) $ + Shape.indexFromOffset (Shape.Deferred sh2) 3) + ) [ExpectedLine [LineChunk "(4,3)"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:630: " -{-# LINE 630 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 630 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:955: " +{-# LINE 955 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 955 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.ZeroBased (3::Int), Shape.ZeroBased (3::Int)) + ) [ExpectedLine [LineChunk "[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:744: " -{-# LINE 744 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 744 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices $ Shape.Square $ Shape.ZeroBased (3::Int)) + DocTest.printPrefix "Data.Array.Comfort.Shape:1077: " +{-# LINE 1077 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1077 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.Square $ Shape.ZeroBased (3::Int) + ) [ExpectedLine [LineChunk "[(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:793: " -{-# LINE 793 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 793 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices $ Shape.Cube $ Shape.ZeroBased (2::Int)) + DocTest.printPrefix "Data.Array.Comfort.Shape:1134: " +{-# LINE 1134 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1134 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.Cube $ Shape.ZeroBased (2::Int) + ) [ExpectedLine [LineChunk "[(0,0,0),(0,0,1),(0,1,0),(0,1,1),(1,0,0),(1,0,1),(1,1,0),(1,1,1)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:862: " -{-# LINE 862 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 862 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices $ Shape.Triangular Shape.Upper $ Shape.ZeroBased (3::Int)) + DocTest.printPrefix "Data.Array.Comfort.Shape:1196: " +{-# LINE 1196 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1196 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.Triangular Shape.Upper $ Shape.ZeroBased (3::Int) + ) [ExpectedLine [LineChunk "[(0,0),(0,1),(0,2),(1,1),(1,2),(2,2)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:864: " -{-# LINE 864 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 864 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices $ Shape.Triangular Shape.Lower $ Shape.ZeroBased (3::Int)) + DocTest.printPrefix "Data.Array.Comfort.Shape:1198: " +{-# LINE 1198 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1198 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.Triangular Shape.Lower $ Shape.ZeroBased (3::Int) + ) [ExpectedLine [LineChunk "[(0,0),(1,0),(1,1),(2,0),(2,1),(2,2)]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:994: " -{-# LINE 994 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.property -{-# LINE 994 "src/Data/Array/Comfort/Shape.hs" #-} - (let shape = Shape.Cyclic (10::Int) in Shape.offset shape (-1) == Shape.offset shape 9) - DocTest.printPrefix "Data.Array.Comfort.Shape:999: " -{-# LINE 999 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 999 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.Cyclic (7::Int))) + DocTest.printPrefix "Data.Array.Comfort.Shape:1330: " +{-# LINE 1330 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1330 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexAscending (replicate 3 Shape.AllDistinct) $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[0,1,2],[0,1,3],[0,2,3],[1,2,3]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1332: " +{-# LINE 1332 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1332 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexAscending (replicate 3 Shape.SomeRepetitive) $ Shape.ZeroBased (3::Int) + ) + [ExpectedLine [LineChunk "[[0,0,0],[0,0,1],[0,0,2],[0,1,1],[0,1,2],[0,2,2],[1,1,1],[1,1,2],[1,2,2],[2,2,2]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1334: " +{-# LINE 1334 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1334 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexAscending [Shape.Repetitive,Shape.Distinct,Shape.Repetitive] $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[0,0,1],[0,0,2],[0,0,3],[0,1,2],[0,1,3],[0,2,3],[1,1,2],[1,1,3],[1,2,3],[2,2,3]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1336: " +{-# LINE 1336 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1336 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexAscending [Shape.Repetitive,Shape.Distinct,Shape.Distinct] $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[0,0,1],[0,0,2],[0,0,3],[0,1,2],[0,1,3],[0,2,3],[1,1,2],[1,1,3],[1,2,3],[2,2,3]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1339: " +{-# LINE 1339 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1339 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexDescending (replicate 3 Shape.AllDistinct) $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[2,1,0],[3,1,0],[3,2,0],[3,2,1]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1341: " +{-# LINE 1341 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1341 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexDescending (replicate 3 Shape.SomeRepetitive) $ Shape.ZeroBased (3::Int) + ) + [ExpectedLine [LineChunk "[[0,0,0],[1,0,0],[1,1,0],[1,1,1],[2,0,0],[2,1,0],[2,1,1],[2,2,0],[2,2,1],[2,2,2]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1343: " +{-# LINE 1343 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1343 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexDescending [Shape.Repetitive,Shape.Distinct,Shape.Repetitive] $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[1,1,0],[2,1,0],[2,2,0],[2,2,1],[3,1,0],[3,2,0],[3,2,1],[3,3,0],[3,3,1],[3,3,2]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1345: " +{-# LINE 1345 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1345 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices $ Shape.simplexDescending [Shape.Repetitive,Shape.Distinct,Shape.Distinct] $ Shape.ZeroBased (4::Int) + ) + [ExpectedLine [LineChunk "[[1,1,0],[2,1,0],[2,2,0],[2,2,1],[3,1,0],[3,2,0],[3,2,1],[3,3,0],[3,3,1],[3,3,2]]"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1579: " +{-# LINE 1579 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.property( +{-# LINE 1579 "src/Data/Array/Comfort/Shape.hs" #-} + let shape = Shape.Cyclic (10::Int) in Shape.offset shape (-1) == Shape.offset shape 9 + ) + DocTest.printPrefix "Data.Array.Comfort.Shape:1584: " +{-# LINE 1584 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1584 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.Cyclic (7::Int)) + ) [ExpectedLine [LineChunk "[0,1,2,3,4,5,6]"]] - DocTest.printPrefix "Data.Array.Comfort.Shape:1047: " -{-# LINE 1047 "src/Data/Array/Comfort/Shape.hs" #-} - DocTest.example -{-# LINE 1047 "src/Data/Array/Comfort/Shape.hs" #-} - (Shape.indices (Shape.ZeroBased (3::Int) :+: Shape.Range 'a' 'c')) + DocTest.printPrefix "Data.Array.Comfort.Shape:1628: " +{-# LINE 1628 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1628 "src/Data/Array/Comfort/Shape.hs" #-} + Shape.indices (Shape.ZeroBased (3::Int) ::+ Shape.Range 'a' 'c') + ) [ExpectedLine [LineChunk "[Left 0,Left 1,Left 2,Right 'a',Right 'b',Right 'c']"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1715: " +{-# LINE 1715 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1715 "src/Data/Array/Comfort/Shape.hs" #-} + rnf (Shape.NestedTuple (Shape.Element 1, Shape.Element 2)) + ) + [ExpectedLine [LineChunk "()"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1717: " +{-# LINE 1717 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1717 "src/Data/Array/Comfort/Shape.hs" #-} + rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element 2, Shape.Element 3))) + ) + [ExpectedLine [LineChunk "()"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1719: " +{-# LINE 1719 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1719 "src/Data/Array/Comfort/Shape.hs" #-} + isBottom $ rnf (Shape.NestedTuple (Shape.Element undefined, Shape.Element 2)) + ) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1721: " +{-# LINE 1721 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1721 "src/Data/Array/Comfort/Shape.hs" #-} + isBottom $ rnf (Shape.NestedTuple (Shape.Element undefined, (Shape.Element 2, Shape.Element 3))) + ) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1723: " +{-# LINE 1723 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1723 "src/Data/Array/Comfort/Shape.hs" #-} + isBottom $ rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element undefined, Shape.Element 3))) + ) + [ExpectedLine [LineChunk "True"]] + DocTest.printPrefix "Data.Array.Comfort.Shape:1725: " +{-# LINE 1725 "src/Data/Array/Comfort/Shape.hs" #-} + DocTest.example( +{-# LINE 1725 "src/Data/Array/Comfort/Shape.hs" #-} + isBottom $ rnf (Shape.NestedTuple (Shape.Element 1, (Shape.Element 2, Shape.Element undefined))) + ) + [ExpectedLine [LineChunk "True"]] diff --git a/test/DocTest/Data/Array/Comfort/Storable.hs b/test/DocTest/Data/Array/Comfort/Storable.hs --- a/test/DocTest/Data/Array/Comfort/Storable.hs +++ b/test/DocTest/Data/Array/Comfort/Storable.hs @@ -1,24 +1,32 @@ -- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Storable.hs -{-# LINE 73 "src/Data/Array/Comfort/Storable.hs" #-} +{-# LINE 100 "src/Data/Array/Comfort/Storable.hs" #-} module DocTest.Data.Array.Comfort.Storable where +import Test.DocTest.Base import qualified Test.DocTest.Driver as DocTest -{-# LINE 74 "src/Data/Array/Comfort/Storable.hs" #-} +{-# LINE 101 "src/Data/Array/Comfort/Storable.hs" #-} import qualified Data.Array.Comfort.Storable as Array import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Storable (Array) +import Data.Array.Comfort.Storable (Array, (!)) import qualified Test.QuickCheck as QC import Test.ChasingBottoms.IsBottom (isBottom) import Control.Applicative ((<$>)) -import Data.Word (Word16) +import qualified Data.IntSet as IntSet +import qualified Data.Set as Set +import Data.Complex (Complex((:+))) +import Data.Word (Word8, Word16) type ShapeInt = Shape.ZeroBased Int +type X = Shape.Element +shapeInt :: Int -> ShapeInt +shapeInt = Shape.ZeroBased + genArray :: QC.Gen (Array ShapeInt Word16) genArray = Array.vectorFromList <$> QC.arbitrary @@ -37,18 +45,69 @@ test :: DocTest.T () test = do - DocTest.printPrefix "Data.Array.Comfort.Storable:194: " -{-# LINE 194 "src/Data/Array/Comfort/Storable.hs" #-} - DocTest.property -{-# LINE 194 "src/Data/Array/Comfort/Storable.hs" #-} - (forAllNonEmpty $ \xs -> Array.minimum xs ==? minimum (Array.toList xs)) - DocTest.printPrefix "Data.Array.Comfort.Storable:202: " -{-# LINE 202 "src/Data/Array/Comfort/Storable.hs" #-} - DocTest.property -{-# LINE 202 "src/Data/Array/Comfort/Storable.hs" #-} - (forAllNonEmpty $ \xs -> Array.maximum xs ==? maximum (Array.toList xs)) - DocTest.printPrefix "Data.Array.Comfort.Storable:214: " -{-# LINE 214 "src/Data/Array/Comfort/Storable.hs" #-} - DocTest.property -{-# LINE 214 "src/Data/Array/Comfort/Storable.hs" #-} - (forAllNonEmpty $ \xs -> Array.limits xs ==? (Array.minimum xs, Array.maximum xs)) + DocTest.printPrefix "Data.Array.Comfort.Storable:151: " +{-# LINE 151 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 151 "src/Data/Array/Comfort/Storable.hs" #-} + Array.fromList (shapeInt 5) ['a'..] + ) + [ExpectedLine [LineChunk "StorableArray.fromList (ZeroBased {zeroBasedSize = 5}) \"abcde\""]] + DocTest.printPrefix "Data.Array.Comfort.Storable:170: " +{-# LINE 170 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 170 "src/Data/Array/Comfort/Storable.hs" #-} + Array.fromTuple ('a',('b','c')) :: Array (Shape.NestedTuple Shape.TupleIndex (X,(X,X))) Char + ) + [ExpectedLine [LineChunk "StorableArray.fromList (NestedTuple {getNestedTuple = (Element 0,(Element 1,Element 2))}) \"abc\""]] + DocTest.printPrefix "Data.Array.Comfort.Storable:173: " +{-# LINE 173 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 173 "src/Data/Array/Comfort/Storable.hs" #-} + + let arr :: Array (Shape.NestedTuple Shape.TupleAccessor (X,(X,X))) Char + arr = Array.fromTuple ('a',('b','c')) + in (arr ! fst, arr ! (fst.snd)) + ) + [ExpectedLine [LineChunk "('a','b')"]] + DocTest.printPrefix "Data.Array.Comfort.Storable:196: " +{-# LINE 196 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 196 "src/Data/Array/Comfort/Storable.hs" #-} + + let arr = Array.fromRecord ('a' :+ 'b') in + let (real:+imag) = Shape.indexRecordFromShape $ Array.shape arr in + (arr ! real, arr ! imag) + ) + [ExpectedLine [LineChunk "('a','b')"]] + DocTest.printPrefix "Data.Array.Comfort.Storable:338: " +{-# LINE 338 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 338 "src/Data/Array/Comfort/Storable.hs" #-} + Array.takeSet (Set.fromList [0,2,4,7,13]) (Array.vectorFromList [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3::Word8]) + ) + [ExpectedLine [LineChunk "StorableArray",WildCardChunk,LineChunk " (",WildCardChunk,LineChunk " [0,2,4,7,13]) [3,4,5,6,7]"]] + DocTest.printPrefix "Data.Array.Comfort.Storable:348: " +{-# LINE 348 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.example( +{-# LINE 348 "src/Data/Array/Comfort/Storable.hs" #-} + Array.takeIntSet (IntSet.fromList [0,2,4,7,13]) (Array.vectorFromList [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3::Word8]) + ) + [ExpectedLine [LineChunk "StorableArray",WildCardChunk,LineChunk " (",WildCardChunk,LineChunk " [0,2,4,7,13]) [3,4,5,6,7]"]] + DocTest.printPrefix "Data.Array.Comfort.Storable:393: " +{-# LINE 393 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.property( +{-# LINE 393 "src/Data/Array/Comfort/Storable.hs" #-} + forAllNonEmpty $ \xs -> Array.minimum xs ==? minimum (Array.toList xs) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable:401: " +{-# LINE 401 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.property( +{-# LINE 401 "src/Data/Array/Comfort/Storable.hs" #-} + forAllNonEmpty $ \xs -> Array.maximum xs ==? maximum (Array.toList xs) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable:413: " +{-# LINE 413 "src/Data/Array/Comfort/Storable.hs" #-} + DocTest.property( +{-# LINE 413 "src/Data/Array/Comfort/Storable.hs" #-} + forAllNonEmpty $ \xs -> Array.limits xs ==? (Array.minimum xs, Array.maximum xs) + ) diff --git a/test/DocTest/Data/Array/Comfort/Storable/Dim2.hs b/test/DocTest/Data/Array/Comfort/Storable/Dim2.hs new file mode 100644 --- /dev/null +++ b/test/DocTest/Data/Array/Comfort/Storable/Dim2.hs @@ -0,0 +1,308 @@ +-- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Storable/Dim2.hs +{-# LINE 49 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + +module DocTest.Data.Array.Comfort.Storable.Dim2 where + +import Test.DocTest.Base +import qualified Test.DocTest.Driver as DocTest + +{-# LINE 50 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} +import qualified DocTest.Data.Array.Comfort.Boxed.Unchecked + as TestBoxedArray +import DocTest.Data.Array.Comfort.Storable (ShapeInt, shapeInt) + +import qualified Data.Array.Comfort.Boxed as BoxedArray +import qualified Data.Array.Comfort.Storable.Dim2 as Array2 +import qualified Data.Array.Comfort.Storable as Array +import qualified Data.Array.Comfort.Shape as Shape +import Data.Array.Comfort.Storable.Dim2 (Array2, (&===), (&|||)) +import Data.Array.Comfort.Storable (Array, (!)) +import Data.Array.Comfort.Shape ((::+)((::+))) + +import qualified Test.QuickCheck as QC + +import Control.Monad (replicateM) +import Control.Applicative (liftA2, (<$>), (<*>)) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Map (Map) +import Data.Function.HT (Id) +import Data.Tuple.HT (swap) +import Data.Word (Word16) +import Data.Proxy (Proxy(Proxy)) + +import Foreign.Storable (Storable) + +genArray2 :: QC.Gen (Array2 ShapeInt ShapeInt Word16) +genArray2 = do + xs <- QC.arbitrary + let n = length xs + (k,m) <- + if n == 0 + then QC.elements [(,) 0, flip (,) 0] <*> QC.choose (1,20) + else fmap (\m -> (div n m, m)) $ QC.choose (1,n) + return $ Array.fromList (Shape.ZeroBased k, Shape.ZeroBased m) xs + +genArrayForShape :: (Shape.C shape) => shape -> QC.Gen (Array shape Word16) +genArrayForShape sh = + Array.fromList sh <$> replicateM (Shape.size sh) QC.arbitrary + +genNonEmptyArray2 :: QC.Gen (Array2 ShapeInt ShapeInt Word16) +genNonEmptyArray2 = do + xs <- QC.getNonEmpty <$> QC.arbitrary + let n = length xs + m <- QC.choose (1,n) + return $ Array.fromList (Shape.ZeroBased (div n m), Shape.ZeroBased m) xs + + +transpose :: + (Shape.Indexed sh0, Shape.Indexed sh1, Storable a) => + Array2 sh0 sh1 a -> Array2 sh1 sh0 a +transpose a = Array.sample (swap $ Array.shape a) (\(i,j) -> a!(j,i)) + +test :: DocTest.T () +test = do + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:122: " +{-# LINE 122 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 122 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genNonEmptyArray2 $ \xs -> + QC.forAll (QC.elements $ Shape.indices $ Array.shape xs) $ \(ix0,ix1) -> + Array2.takeRow xs ix0 ! ix1 == xs!(ix0,ix1) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:147: " +{-# LINE 147 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 147 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \xs -> + xs == Array2.fromRowArray (snd $ Array.shape xs) (Array2.toRowArray xs) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:168: " +{-# LINE 168 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 168 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \xs -> + let (Shape.ZeroBased m, width) = Array.shape xs in + QC.forAll (QC.choose (0, m)) $ \k -> + let ys = Array.reshape + (Shape.ZeroBased k ::+ Shape.ZeroBased (m-k), width) xs in + ys == Array2.above (Array2.takeTop ys) (Array2.takeBottom ys) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:193: " +{-# LINE 193 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 193 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \xs -> + let (height, Shape.ZeroBased n) = Array.shape xs in + QC.forAll (QC.choose (0, n)) $ \k -> + let ys = Array.reshape + (height, Shape.ZeroBased k ::+ Shape.ZeroBased (n-k)) xs in + ys == Array2.beside (Array2.takeLeft ys) (Array2.takeRight ys) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:279: " +{-# LINE 279 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.example( +{-# LINE 279 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + let shapeR0 = shapeInt 2; shapeR1 = shapeInt 3 in + let shapeC0 = shapeInt 3; shapeC1 = shapeInt 2 in + let block sh a = Array.replicate sh (a::Word16) in + Array2.fromBlockArray + (Map.singleton 'A' shapeR0 <> Map.singleton 'B' shapeR1) + (Map.singleton '1' shapeC0 <> Map.singleton '2' shapeC1) $ + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [block (shapeR0,shapeC0) 0, block (shapeR0,shapeC1) 1, + block (shapeR1,shapeC0) 2, block (shapeR1,shapeC1) 3] + ) + [ExpectedLine [LineChunk "StorableArray.fromList (fromList [('A',ZeroBased {",WildCardChunk,LineChunk " 2}),('B',ZeroBased {",WildCardChunk,LineChunk " 3})],fromList [('1',ZeroBased {",WildCardChunk,LineChunk " 3}),('2',ZeroBased {",WildCardChunk,LineChunk " 2})]) [0,0,0,1,1,0,0,0,1,1,2,2,2,3,3,2,2,2,3,3,2,2,2,3,3]"]] + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:292: " +{-# LINE 292 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 292 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + let blocked = + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [blockA1, blockA2, blockB1, blockB2] in + + transpose (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromNonEmptyBlockArray + (TestBoxedArray.transpose (fmap transpose blocked)) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:311: " +{-# LINE 311 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 311 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + QC.forAll genArray2 $ \blockC3 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + let shapeR2 = fst $ Array.shape blockC3 in + let shapeC2 = snd $ Array.shape blockC3 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC2)) $ \blockB3 -> + QC.forAll (genArrayForShape (shapeR2, shapeC0)) $ \blockC1 -> + QC.forAll (genArrayForShape (shapeR2, shapeC1)) $ \blockC2 -> + let blocked = + BoxedArray.fromList (Set.fromList "ABC", Set.fromList "123") + [blockA1, blockA2, blockA3, + blockB1, blockB2, blockB3, + blockC1, blockC2, blockC3] in + + transpose (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromNonEmptyBlockArray + (TestBoxedArray.transpose (fmap transpose blocked)) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:362: " +{-# LINE 362 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.example( +{-# LINE 362 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + (id :: Id (array (height, Map Char ShapeInt) Word16)) $ + Array2.fromBlockArray + (Map.singleton 'A' (shapeInt 2) <> Map.singleton 'B' (shapeInt 3)) + Map.empty $ + BoxedArray.fromList (Set.fromList "AB", Set.empty) [] + ) + [ExpectedLine [LineChunk "StorableArray.fromList (fromList [('A',ZeroBased {",WildCardChunk,LineChunk " 2}),('B',ZeroBased {",WildCardChunk,LineChunk " 3})],fromList []) []"]] + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:371: " +{-# LINE 371 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 371 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \block -> + let height = Map.singleton 'A' $ fst $ Array.shape block in + let width = Map.singleton '1' $ snd $ Array.shape block in + + Array.reshape (height,width) block + QC.=== + Array2.fromBlockArray height width + (BoxedArray.replicate (Set.singleton 'A', Set.singleton '1') block) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:484: " +{-# LINE 484 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 484 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB2 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB2 in + let shapeC1 = snd $ Array.shape blockB2 in + let shapeR = shapeR0::+shapeR1::+Shape.Zero in + let shapeC = shapeC0::+shapeC1::+Shape.Zero in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + let blocked = + BoxedArray.fromList (Set.fromList "AB", Set.fromList "12") + [blockA1, blockA2, blockB1, blockB2] in + + Array.reshape (shapeR, shapeC) + (Array2.fromNonEmptyBlockArray blocked) + QC.=== + Array2.fromBlocks shapeR shapeC Proxy + blockA1 blockA2 + blockB1 blockB2 + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:589: " +{-# LINE 589 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 589 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll genArray2 $ \blockA1 -> + QC.forAll genArray2 $ \blockB3 -> + QC.forAll + (liftA2 + (\char0 char1 -> Shape.Range (min char0 char1) (max char0 char1)) + (QC.choose ('a','k')) (QC.choose ('a','k'))) $ + \shapeC1 -> + let shapeR0 = fst $ Array.shape blockA1 in + let shapeC0 = snd $ Array.shape blockA1 in + let shapeR1 = fst $ Array.shape blockB3 in + let shapeC2 = snd $ Array.shape blockB3 in + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC1)) $ \blockB2 -> + + Array2.fromBlockMatrix + (blockA1 &||| Array2.beside blockA2 blockA3 + &=== + blockB1 &||| blockB2 &||| blockB3) + QC.=== + Array.reshape + (shapeR0::+shapeR1, shapeC0::+shapeC1::+shapeC2) + (Array2.fromBlocks + (shapeR0::+shapeR1::+Shape.Zero) + (shapeC0::+shapeC1::+shapeC2::+Shape.Zero) + Proxy + blockA1 blockA2 blockA3 + blockB1 blockB2 blockB3) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Dim2:621: " +{-# LINE 621 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + DocTest.property( +{-# LINE 621 "src/Data/Array/Comfort/Storable/Dim2.hs" #-} + + QC.forAll + (liftA2 + (\char0 char1 -> Shape.Range (min char0 char1) (max char0 char1)) + (QC.choose ('a','k')) (QC.choose ('a','k'))) $ + \shapeR0 -> + QC.forAll + (liftA2 Shape.Shifted (QC.choose (-10,10)) (QC.choose (0,10::Int))) $ + \shapeR1 -> + let shapeR2 = () in + QC.forAll (fmap Shape.ZeroBased (QC.choose (0,10::Int))) $ + \shapeC0 -> + QC.forAll (fmap Shape.OneBased (QC.choose (0,10::Int))) $ + \shapeC1 -> + let shapeC2 :: Shape.Enumeration Ordering + shapeC2 = Shape.Enumeration in + + QC.forAll (genArrayForShape (shapeR0, shapeC0)) $ \blockA1 -> + QC.forAll (genArrayForShape (shapeR0, shapeC1)) $ \blockA2 -> + QC.forAll (genArrayForShape (shapeR0, shapeC2)) $ \blockA3 -> + QC.forAll (genArrayForShape (shapeR1, shapeC0)) $ \blockB1 -> + QC.forAll (genArrayForShape (shapeR1, shapeC1)) $ \blockB2 -> + QC.forAll (genArrayForShape (shapeR1, shapeC2)) $ \blockB3 -> + QC.forAll (genArrayForShape (shapeR2, shapeC0)) $ \blockC1 -> + QC.forAll (genArrayForShape (shapeR2, shapeC1)) $ \blockC2 -> + QC.forAll (genArrayForShape (shapeR2, shapeC2)) $ \blockC3 -> + + Array2.fromBlockMatrix + (blockA1 &||| blockA2 &||| blockA3 + &=== + blockB1 &||| blockB2 &||| blockB3 + &=== + blockC1 &||| blockC2 &||| blockC3) + QC.=== + Array2.beside + (Array2.above blockA1 $ Array2.above blockB1 blockC1) + (Array2.above + (Array2.beside blockA2 blockA3) + (Array2.beside + (Array2.above blockB2 blockC2) + (Array2.above blockB3 blockC3))) + ) diff --git a/test/DocTest/Data/Array/Comfort/Storable/Unchecked.hs b/test/DocTest/Data/Array/Comfort/Storable/Unchecked.hs --- a/test/DocTest/Data/Array/Comfort/Storable/Unchecked.hs +++ b/test/DocTest/Data/Array/Comfort/Storable/Unchecked.hs @@ -1,11 +1,11 @@ -- Do not edit! Automatically created with doctest-extract from src/Data/Array/Comfort/Storable/Unchecked.hs -{-# LINE 57 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} +{-# LINE 64 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} module DocTest.Data.Array.Comfort.Storable.Unchecked where import qualified Test.DocTest.Driver as DocTest -{-# LINE 58 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} +{-# LINE 65 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} import DocTest.Data.Array.Comfort.Storable (ShapeInt, genArray) import qualified Data.Array.Comfort.Storable as Array @@ -24,33 +24,39 @@ test :: DocTest.T () test = do - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:134: " -{-# LINE 134 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 134 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\x -> Array.singleton x ! () == (x::Word16)) - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:152: " -{-# LINE 152 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 152 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\(QC.NonNegative n) (Array16 x) -> x == Array.mapShape (Shape.ZeroBased . Shape.size) (Array.append (Array.take n x) (Array.drop n x))) - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:167: " -{-# LINE 167 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 167 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\(Array16 x) (Array16 y) -> let xy = Array.append x y in x == Array.takeLeft xy && y == Array.takeRight xy) - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:187: " -{-# LINE 187 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 187 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\(Array16 x) (Array16 y) (Array16 z) -> let xyz = Array.append x $ Array.append y z in y == Array.takeCenter xyz) - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:200: " -{-# LINE 200 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 200 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\(Array16 xs) -> Array.sum xs == sum (Array.toList xs)) - DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:206: " -{-# LINE 206 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - DocTest.property -{-# LINE 206 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} - (\(Array16 xs) -> Array.product xs == product (Array.toList xs)) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:166: " +{-# LINE 166 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 166 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \x -> Array.singleton x ! () == (x::Word16) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:180: " +{-# LINE 180 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 180 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \(QC.NonNegative n) (Array16 x) -> x == Array.mapShape (Shape.ZeroBased . Shape.size) (Array.append (Array.take n x) (Array.drop n x)) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:195: " +{-# LINE 195 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 195 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \(Array16 x) (Array16 y) -> let xy = Array.append x y in x == Array.takeLeft xy && y == Array.takeRight xy + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:215: " +{-# LINE 215 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 215 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \(Array16 x) (Array16 y) (Array16 z) -> let xyz = Array.append x $ Array.append y z in y == Array.takeCenter xyz + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:228: " +{-# LINE 228 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 228 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \(Array16 xs) -> Array.sum xs == sum (Array.toList xs) + ) + DocTest.printPrefix "Data.Array.Comfort.Storable.Unchecked:234: " +{-# LINE 234 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + DocTest.property( +{-# LINE 234 "src/Data/Array/Comfort/Storable/Unchecked.hs" #-} + \(Array16 xs) -> Array.product xs == product (Array.toList xs) + ) diff --git a/test/DocTest/Main.hs b/test/DocTest/Main.hs --- a/test/DocTest/Main.hs +++ b/test/DocTest/Main.hs @@ -2,13 +2,19 @@ module DocTest.Main where import qualified DocTest.Data.Array.Comfort.Shape -import qualified DocTest.Data.Array.Comfort.Storable import qualified DocTest.Data.Array.Comfort.Storable.Unchecked +import qualified DocTest.Data.Array.Comfort.Storable +import qualified DocTest.Data.Array.Comfort.Storable.Dim2 +import qualified DocTest.Data.Array.Comfort.Boxed.Unchecked +import qualified DocTest.Data.Array.Comfort.Boxed import qualified Test.DocTest.Driver as DocTest main :: DocTest.T () main = do DocTest.Data.Array.Comfort.Shape.test - DocTest.Data.Array.Comfort.Storable.test DocTest.Data.Array.Comfort.Storable.Unchecked.test + DocTest.Data.Array.Comfort.Storable.test + DocTest.Data.Array.Comfort.Storable.Dim2.test + DocTest.Data.Array.Comfort.Boxed.Unchecked.test + DocTest.Data.Array.Comfort.Boxed.test diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} module Main where import qualified DocTest.Main as DocTestMain diff --git a/test/Test/Shape.hs b/test/Test/Shape.hs --- a/test/Test/Shape.hs +++ b/test/Test/Shape.hs @@ -2,13 +2,15 @@ import qualified Data.Array.Comfort.Shape.Test as ShapeTest import qualified Data.Array.Comfort.Shape as Shape -import Data.Array.Comfort.Shape ((:+:)((:+:))) +import Data.Array.Comfort.Shape ((::+)((::+))) import qualified Test.QuickCheck as QC import Test.Utility (prefix) -import Control.Applicative (liftA2, liftA3) +import Control.Applicative (liftA2, liftA3, pure, (<$>)) +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Set as Set import Data.Tagged (Tagged(Tagged)) @@ -20,6 +22,27 @@ tag :: sh -> Tagged Ordering sh tag = Tagged +simplex :: + (Shape.SimplexOrderC order) => + Shape.SimplexOrder order -> [(String, QC.Property)] +simplex order = + prefix "Mixed" + (ShapeTest.tests $ + liftA2 (Shape.Simplex order) + (take 4 <$> QC.listOf (QC.elements [Shape.Distinct,Shape.Repetitive])) + (genZeroBased 10)) ++ + prefix "Strict" + (ShapeTest.tests $ + liftA2 (Shape.Simplex order) + (take 4 <$> QC.listOf (pure Shape.AllDistinct)) + (genZeroBased 10)) ++ + prefix "Weak" + (ShapeTest.tests $ + liftA2 (Shape.Simplex order) + (take 4 <$> QC.listOf (pure Shape.SomeRepetitive)) + (genZeroBased 10)) ++ + [] + tests :: [(String, QC.Property)] tests = prefix "ZeroBased" @@ -48,6 +71,13 @@ (ShapeTest.tests $ fmap Map.fromList (QC.listOf (liftA2 (,) (QC.choose ('a','z')) (genZeroBased 10)))) ++ + prefix "IntSet" + (ShapeTest.tests $ + fmap IntSet.fromList (QC.listOf (QC.choose (1,10)))) ++ + prefix "IntMap" + (ShapeTest.tests $ + fmap IntMap.fromList + (QC.listOf (liftA2 (,) (QC.choose (1,10)) (genZeroBased 10)))) ++ prefix "Deferred Shifted" (ShapeTest.tests $ fmap Shape.Deferred $ liftA2 Shape.Shifted @@ -62,7 +92,7 @@ (ShapeTest.tests $ liftA3 (,,) (genZeroBased 10) (genZeroBased 10) (genZeroBased 10)) ++ prefix "Append" - (ShapeTest.tests $ liftA2 (:+:) (genZeroBased 10) (genZeroBased 10)) ++ + (ShapeTest.tests $ liftA2 (::+) (genZeroBased 10) (genZeroBased 10)) ++ prefix "Square" (ShapeTest.tests $ fmap Shape.Square $ genZeroBased 10) ++ prefix "Cube" @@ -73,6 +103,9 @@ prefix "Triangular Upper" (ShapeTest.tests $ fmap (Shape.Triangular Shape.Upper) (genZeroBased 10)) ++ + prefix "Simplex" + (prefix "Upper" (simplex Shape.Ascending) ++ + prefix "Lower" (simplex Shape.Descending)) ++ prefix "Cyclic" (ShapeTest.tests $ fmap Shape.Cyclic $ QC.choose (0,10::Int)) ++ []