packages feed

comfort-array 0.4.1 → 0.5.5

raw patch · 33 files changed

Files

Changes.md view
@@ -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
comfort-array.cabal view
@@ -1,5 +1,5 @@ Name:             comfort-array-Version:          0.4.1+Version:          0.5.5 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann <haskell@henning-thielemann.de>@@ -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
set/0.4.0/Data/Array/Comfort/Shape/Set.hs view
@@ -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 =
set/0.5.4/Data/Array/Comfort/Shape/Set.hs view
@@ -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<Set.size set) (Set.elemAt k set)++uncheckedIndexFromOffset :: Set a -> Int -> a+uncheckedIndexFromOffset = flip Set.elemAt
+ src/Data/Array/Comfort/Bool.hs view
@@ -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
src/Data/Array/Comfort/Boxed.hs view
@@ -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)
+ src/Data/Array/Comfort/Boxed/Strict/Unchecked.hs view
@@ -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)
src/Data/Array/Comfort/Boxed/Unchecked.hs view
@@ -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)
src/Data/Array/Comfort/Container.hs view
@@ -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<len+         return ix) + {- instance Foldable only available since GHC-8.0. :-( Could be circumvented by Data.Orphans@@ -103,7 +123,17 @@ instance (NFShape f) => 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<len+         return ix) + instance C Empty.T where    data Shape Empty.T = ShapeEmpty       deriving (Show)@@ -134,7 +164,12 @@ instance (NFData k, Ord k) => 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)
src/Data/Array/Comfort/Shape.hs view
@@ -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<len--instance (Integral n) => InvIndexed (ZeroBased n) where-   indexFromOffset (ZeroBased len) k0 =-      let k = fromIntegral k0-      in  if 0<=k && k<len-            then k-            else errorIndexFromOffset "ZeroBased" k0-   uncheckedIndexFromOffset _ k = fromIntegral k--zeroBasedSplit :: (Real n) => 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<ix && ix<=len--instance (Integral n) => InvIndexed (OneBased n) where-   indexFromOffset (OneBased len) k0 =-      let k = fromIntegral k0-      in  if 0<=k && k<len-            then 1+k-            else errorIndexFromOffset "OneBased" k0-   uncheckedIndexFromOffset _ k = 1 + fromIntegral k---{- |-'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)-   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<offs-        then error "Shape.Shifted: array index too small"-        else-          let k = ix-offs-          in  if k<len-                then fromIntegral k-                else error "Shape.Shifted: array index too big"-   uncheckedOffset (Shifted offs _len) ix = fromIntegral $ ix-offs-   inBounds (Shifted offs len) ix = offs <= ix && ix < offs+len--instance (Integral n) => InvIndexed (Shifted n) where-   indexFromOffset (Shifted offs len) k0 =-      let k = fromIntegral k0-      in  if 0<=k && k<len-            then offs+k-            else errorIndexFromOffset "Shifted" k0-   uncheckedIndexFromOffset (Shifted offs _len) k = offs + fromIntegral k---- cf. sample-frame:Stereo-instance Storable n => Storable (Shifted n) where-   {-# INLINE sizeOf #-}-   {-# INLINE alignment #-}-   {-# INLINE peek #-}-   {-# INLINE poke #-}-   sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n-   alignment ~(Shifted l _) = alignment l-   poke p (Shifted l n) =-      let q = castToElemPtr p-      in  poke q l >> pokeElemOff q 1 n-   peek p =-      let q = castToElemPtr p-      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)---{-# INLINE castToElemPtr #-}-castToElemPtr :: Ptr (f a) -> Ptr a-castToElemPtr = castPtr----{- |-'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<len-            then k-            else errorIndexFromOffset "Cyclic" k0-   uncheckedIndexFromOffset _ k = fromIntegral k----infixr 5 :+:--{- |-Row-major composition of two dimensions.-->>> 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 (<len) $ iterate (+1) 0+   unifiedOffset (ZeroBased len) = unifiedOffset $ Shifted 0 len+   inBounds (ZeroBased len) ix = 0<=ix && ix<len++instance (Integral n) => InvIndexed (ZeroBased n) where+   unifiedIndexFromOffset (ZeroBased len) k0 = do+      let k = fromIntegral k0+      assertIndexFromOffset "ZeroBased" k0 $ 0<=k && k<len+      pure k++zeroBasedSplit :: (Real n) => 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<ix && ix<=len++instance (Integral n) => InvIndexed (OneBased n) where+   unifiedIndexFromOffset (OneBased len) k0 = do+      let k = fromIntegral k0+      assertIndexFromOffset "OneBased" k0 $ 0<=k && k<len+      pure $ 1+k++instance (Integral n) => 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<len)+      return $ fromIntegral k+   inBounds (Shifted offs len) ix = offs <= ix && ix < offs+len++instance (Integral n) => InvIndexed (Shifted n) where+   unifiedIndexFromOffset (Shifted offs len) k0 = do+      let k = fromIntegral k0+      assertIndexFromOffset "Shifted" k0 $ 0<=k && k<len+      return $ offs+k++-- cf. sample-frame:Stereo+instance Storable n => Storable (Shifted n) where+   {-# INLINE sizeOf #-}+   {-# INLINE alignment #-}+   {-# INLINE peek #-}+   {-# INLINE poke #-}+   sizeOf ~(Shifted l n) = sizeOf l + mod (- sizeOf l) (alignment n) + sizeOf n+   alignment ~(Shifted l _) = alignment l+   poke p (Shifted l n) =+      let q = castToElemPtr p+      in  poke q l >> pokeElemOff q 1 n+   peek p =+      let q = castToElemPtr p+      in  Monad.lift2 Shifted (peek q) (peekElemOff q 1)+++{-# INLINE castToElemPtr #-}+castToElemPtr :: Ptr (f a) -> Ptr a+castToElemPtr = castPtr++++{- |+'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<y)+      else+         ListHT.mapAdjacent+            (\(c,x) (_,y) -> 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 (<n) $ iterate (1+) a of+                     [] -> 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<len+      return k++++infixr 5 ::+++{- |+Row-major composition of two dimensions.++>>> 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)
+ src/Data/Array/Comfort/Shape/SubSize.hs view
@@ -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
src/Data/Array/Comfort/Shape/Test.hs view
@@ -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) ++    []
+ src/Data/Array/Comfort/Shape/Tuple.hs view
@@ -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)
src/Data/Array/Comfort/Shape/Utility.hs view
@@ -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)
src/Data/Array/Comfort/Storable.hs view
@@ -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
+ src/Data/Array/Comfort/Storable/Dim2.hs view
@@ -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)
src/Data/Array/Comfort/Storable/Mutable.hs view
@@ -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) =>
src/Data/Array/Comfort/Storable/Mutable/Private.hs view
@@ -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) =>
src/Data/Array/Comfort/Storable/Mutable/Unchecked.hs view
@@ -15,6 +15,7 @@    MutArray.unsafeCreateWithSizeAndResult,    MutArray.withPtr,    MutArray.read,+   MutArray.readMaybe,    MutArray.write,    MutArray.update,    MutArray.toList,
src/Data/Array/Comfort/Storable/Private.hs view
@@ -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
src/Data/Array/Comfort/Storable/Unchecked.hs view
@@ -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
+ src/Data/Array/Comfort/Storable/Unchecked/Creator.hs view
@@ -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
src/Data/Array/Comfort/Storable/Unchecked/Monadic.hs view
@@ -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
− test-module.list 
@@ -1,3 +0,0 @@-Data.Array.Comfort.Shape-Data.Array.Comfort.Storable-Data.Array.Comfort.Storable.Unchecked
+ test/DocTest/Data/Array/Comfort/Boxed.hs view
@@ -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)+  )
+ test/DocTest/Data/Array/Comfort/Boxed/Unchecked.hs view
@@ -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+  )
test/DocTest/Data/Array/Comfort/Shape.hs view
@@ -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"]]
test/DocTest/Data/Array/Comfort/Storable.hs view
@@ -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)+  )
+ test/DocTest/Data/Array/Comfort/Storable/Dim2.hs view
@@ -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)))+  )
test/DocTest/Data/Array/Comfort/Storable/Unchecked.hs view
@@ -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)+  )
test/DocTest/Main.hs view
@@ -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
test/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TypeFamilies #-} module Main where  import qualified DocTest.Main as DocTestMain
test/Test/Shape.hs view
@@ -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)) ++    []