carray 0.1.5.2 → 0.1.6

raw patch · 15 files changed

+962/−831 lines, 15 filesdep +QuickCheckdep +carraydep ~arraydep ~basedep ~binaryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, carray

Dependency ranges changed: array, base, binary, bytestring, ix-shapable, syb

API changes (from Hackage documentation)

Files

• Data/Array/CArray.hs +0/−91
• Data/Array/CArray/Base.hs +0/−537
• Data/Array/IOCArray.hs +0/−40
• Makefile +2/−1
• carray.cabal +94/−29
• src/Data/Array/CArray.hs +91/−0
• src/Data/Array/CArray/Base.hs +565/−0
• src/Data/Array/IOCArray.hs +40/−0
• tests/meteor-contest-c.hs +31/−15
• tests/meteor-contest-u.hs +31/−15
• tests/nsieve-bits-c.hs +18/−12
• tests/nsieve-bits-s.hs +18/−12
• tests/nsieve-bits-u.hs +16/−9
• tests/runtests.sh +3/−14
• tests/tests.hs +53/−56

@@ -1,91 +0,0 @@--- |--- Module      : Data.Array.CArray--- Copyright   : (c) 2008 Jed Brown--- License     : BSD-style--- --- Maintainer  : jed@59A2.org--- Stability   : experimental--- Portability : non-portable------ This module provides the immutable 'CArray' which uses pinned memory on the--- GC'd heap.  Elements are stored according to the class 'Storable'.  You can--- obtain a pointer to the array contents to manipulate elements from--- languages like C.------ 'CArray' is 16-byte aligned by default.  If you create a 'CArray' with--- 'unsafeForeignPtrToCArray' then it may not be aligned.  This will be an issue--- if you intend to use SIMD instructions.------ 'CArray' is similar to 'Data.Array.Unboxed.UArray' but slower if you stay--- within Haskell.  'CArray' can handle more types and can be used by external--- libraries.------ 'CArray' has an instance of 'Binary'.--------------------------------------------------------------------------------module Data.Array.CArray (-    -- * CArray type-    CArray,--    -- * Multi-dimensional--    -- ** Fast reshaping-    reshape,-    flatten,--    -- ** Query-    rank,-    shape,-    size,--    -- * Mapping--    -- ** General-    ixmapWithIndP,-    ixmapWithInd,-    ixmapWithP,-    ixmapWith,-    ixmapP,--    -- ** Slicing-    sliceStrideWithP,-    sliceStrideWith,-    sliceStrideP,-    sliceStride,-    sliceWithP,-    sliceWith,-    sliceP,-    slice,--    -- * Lifting-    liftArrayP,-    liftArray,-    liftArray2P,-    liftArray2,-    liftArray3P,-    liftArray3,--    -- * Norms-    normp,-    norm2,-    normSup,--    -- * Types-    Shapable,-    Abs,--    -- * Unsafe low-level-    withCArray,-    unsafeForeignPtrToCArray,-    toForeignPtr,-    unsafeCArrayToByteString,-    unsafeByteStringToCArray,-    createCArray,--   -- * The overloaded immutable array interface-   module Data.Array.IArray-) where--import Data.Ix.Shapable-import Data.Array.IArray-import Data.Array.CArray.Base

@@ -1,537 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ < 610-{-# OPTIONS_GHC -frewrite-rules #-}-#else-{-# OPTIONS_GHC -fenable-rewrite-rules #-}-#endif-#endif--------------------------------------------------------------------------------- |--- Module      : Data.Array.CArray.Base--- Copyright   : (c) 2001 The University of Glasgow---               (c) 2008 Jed Brown--- License     : BSD-style--- --- Maintainer  : jed@59A2.org--- Stability   : experimental--- Portability : non-portable------ This module provides both the immutable 'CArray' and mutable 'IOCArray'.  The--- underlying storage is exactly the same - pinned memory on the GC'd heap.--- Elements are stored according to the class 'Storable'.  You can obtain a--- pointer to the array contents to manipulate elements from languages like C.------ 'CArray' is 16-byte aligned by default.  If you create a 'CArray' with--- 'unsafeForeignPtrToCArray' then it may not be aligned.  This will be an issue--- if you intend to use SIMD instructions.------ 'CArray' is similar to 'Data.Array.Unboxed.UArray' but slower if you stay--- within Haskell.  'CArray' can handle more types and can be used by external--- libraries.------ 'IOCArray' is equivalent to 'Data.Array.Storable.StorableArray' and similar--- to 'Data.Array.IO.IOUArray' but slower.  'IOCArray' has O(1) versions of--- 'unsafeFreeze' and 'unsafeThaw' when converting to/from 'CArray'.--------------------------------------------------------------------------------module Data.Array.CArray.Base where--import Control.Applicative-import Control.Monad-import Data.Ix-import Data.Ix.Shapable-import Data.Array.Base-import Data.Array.MArray        ()-import Data.Array.IArray        ()-import qualified Data.ByteString.Internal as S-import Data.Binary-import Data.Complex-import Data.List-import System.IO.Unsafe         (unsafePerformIO)-import Foreign.Storable-import Foreign.ForeignPtr-import Foreign.Ptr-import Foreign.Marshal.Array    (copyArray, withArray)-import Data.Word                ()--import Data.Generics            (Data(..), Typeable(..))-import GHC.Ptr                  (Ptr(..))-import GHC.ForeignPtr           (ForeignPtr(..), mallocPlainForeignPtrBytes)---- | The immutable array type.-data CArray i e = CArray !i !i Int !(ForeignPtr e)-    deriving (Data, Typeable)---- | Absolutely equivalent representation, but used for the mutable interface.-data IOCArray i e = IOCArray !i !i Int !(ForeignPtr e)-    deriving (Data, Typeable)--instance Storable e => MArray IOCArray e IO where-    getBounds (IOCArray l u _ _) = return (l,u)--    getNumElements (IOCArray _ _ n _) = return n--    newArray (l,u) e0 = do-        fp <- mallocForeignPtrArrayAligned n-        withForeignPtr fp $ \a ->-            sequence_ [pokeElemOff a i e0 | i <- [0 .. n - 1]]-        return (IOCArray l u n fp)-        where n = rangeSize (l,u)--    unsafeNewArray_ (l,u) = do-        let n = rangeSize (l,u)-        fp <- mallocForeignPtrArrayAligned n-        return (IOCArray l u n fp)--    newArray_ = unsafeNewArray_--    unsafeRead (IOCArray _ _ _ fp) i =-        withForeignPtr fp $ \a -> peekElemOff a i--    unsafeWrite (IOCArray _ _ _ fp) i e =-        withForeignPtr fp $ \a -> pokeElemOff a i e---- | The pointer to the array contents is obtained by 'withCArray'.--- The idea is similar to 'ForeignPtr' (used internally here).--- The pointer should be used only during execution of the 'IO' action--- retured by the function passed as argument to 'withCArray'.-withCArray :: CArray i e -> (Ptr e -> IO a) -> IO a-withCArray (CArray _ _ _ fp) f = withForeignPtr fp f--withIOCArray :: IOCArray i e -> (Ptr e -> IO a) -> IO a-withIOCArray (IOCArray _ _ _ fp) f = withForeignPtr fp f---- | If you want to use it afterwards, ensure that you--- 'touchCArray' after the last use of the pointer,--- so the array is not freed too early.-touchIOCArray :: IOCArray i e -> IO ()-touchIOCArray (IOCArray _ _ _ fp) = touchForeignPtr fp---- | /O(1)/ Construct a 'CArray' from an arbitrary 'ForeignPtr'.  It is--- the caller's responsibility to ensure that the 'ForeignPtr' points to--- an area of memory sufficient for the specified bounds.-unsafeForeignPtrToCArray-   :: Ix i => ForeignPtr e -> (i,i) -> IO (CArray i e)-unsafeForeignPtrToCArray p (l,u) =-   return (CArray l u (rangeSize (l,u)) p)---- | /O(1)/ Construct a 'CArray' from an arbitrary 'ForeignPtr'.  It is--- the caller's responsibility to ensure that the 'ForeignPtr' points to--- an area of memory sufficient for the specified bounds.-unsafeForeignPtrToIOCArray-   :: Ix i => ForeignPtr e -> (i,i) -> IO (IOCArray i e)-unsafeForeignPtrToIOCArray p (l,u) =-   return (IOCArray l u (rangeSize (l,u)) p)---- | /O(1)/ Extract ForeignPtr from a CArray.-toForeignPtr :: CArray i e -> (Int, ForeignPtr e)-toForeignPtr (CArray _ _ n fp) = (n, fp)---- | /O(1)/ Turn a CArray into a ByteString.  Unsafe because it uses--- 'castForeignPtr' and thus is not platform independent.-unsafeCArrayToByteString :: (Storable e) => CArray i e -> S.ByteString-unsafeCArrayToByteString (CArray _ _ l fp) = go undefined fp-    where go :: (Storable e) => e -> ForeignPtr e -> S.ByteString-          go dummy fp' = S.fromForeignPtr (castForeignPtr fp') 0 (l * sizeOf dummy)---- | /O(1)/ Turn a ByteString into a CArray.  Unsafe because it uses--- 'castForeignPtr' and thus is not platform independent.  Returns 'Nothing' if--- the range specified is larger than the size of the ByteString or the start of--- the ByteString does not fulfil the alignment requirement of the resulting--- CArray (as specified by the Storable instance).-unsafeByteStringToCArray :: (Ix i, Storable e)-                            => (i,i) -> S.ByteString -> Maybe (CArray i e)-unsafeByteStringToCArray lu bs = go undefined lu-    where go :: (Ix i, Storable e) => e -> (i,i) -> Maybe (CArray i e)-          go dummy (l,u) | safe = Just (CArray l u n fp)-                         | otherwise = Nothing-              where n = rangeSize (l,u)-                    !((ForeignPtr addr contents), off, len) = S.toForeignPtr bs-                    !p@(Ptr addr') = Ptr addr `plusPtr` off-                    fp = ForeignPtr addr' contents-                    safe = sizeOf dummy * n <= len && p == p `alignPtr` alignment dummy--copy :: (Ix i, Storable e) => CArray i e -> IO (CArray i e)-copy ain@(CArray l u n _) =-    createCArray (l,u) $ \op ->-        withCArray ain $ \ip ->-            copyArray op ip n--freezeIOCArray :: (Ix i, Storable e) => IOCArray i e -> IO (CArray i e)-freezeIOCArray = unsafeFreezeIOCArray >=> copy--unsafeFreezeIOCArray :: (Ix i) => IOCArray i e -> IO (CArray i e)-unsafeFreezeIOCArray (IOCArray l u n fp) = return (CArray l u n fp)--thawIOCArray :: (Ix i, Storable e) => CArray i e -> IO (IOCArray i e)-thawIOCArray = copy >=> unsafeThawIOCArray--unsafeThawIOCArray :: (Ix i) => CArray i e -> IO (IOCArray i e)-unsafeThawIOCArray (CArray l u n fp) = return (IOCArray l u n fp)---- Since we can remove the (Storable e) restriction for these, the rules are--- compact and general.-{-# RULES-"unsafeFreeze/IOCArray" unsafeFreeze = unsafeFreezeIOCArray-"unsafeThaw/IOCArray" unsafeThaw = unsafeThawIOCArray-  #-}---- Since we can't parameterize the rules with the (Storable e) constraint, we--- have to specialize manually.  This is unfortunate since it is less general.-{-# RULES-"freeze/IOCArray/Int"    freeze      = freezeIOCArray :: (Ix i) => IOCArray i Int -> IO (CArray i Int)-"freeze/IOCArray/Float"  freeze      = freezeIOCArray :: (Ix i) => IOCArray i Float -> IO (CArray i Float)-"freeze/IOCArray/Double" freeze      = freezeIOCArray :: (Ix i) => IOCArray i Double -> IO (CArray i Double)-"thaw/IOCArray/Int"      thaw        = thawIOCArray   :: (Ix i) => CArray i Int -> IO (IOCArray i Int)-"thaw/IOCArray/Float"    thaw        = thawIOCArray   :: (Ix i) => CArray i Float -> IO (IOCArray i Float)-"thaw/IOCArray/Double"   thaw        = thawIOCArray   :: (Ix i) => CArray i Double -> IO (IOCArray i Double)-  #-}---instance Storable e => IArray CArray e where-    {-# INLINE bounds #-}-    bounds (CArray l u _ _) = (l,u)-    {-# INLINE numElements #-}-    numElements (CArray _ _ n _) = n-    {-# NOINLINE unsafeArray #-}-    unsafeArray lu ies = unsafePerformIO $ unsafeArrayCArray lu ies (zeroElem (undefined :: e))-    {-# INLINE unsafeAt #-}-    unsafeAt (CArray _ _ _ fp) i = S.inlinePerformIO $-                                   withForeignPtr fp $ \a -> peekElemOff a i-    {-# NOINLINE unsafeReplace #-}-    unsafeReplace arr ies = unsafePerformIO $ unsafeReplaceCArray arr ies-    {-# NOINLINE unsafeAccum #-}-    unsafeAccum f arr ies = unsafePerformIO $ unsafeAccumCArray f arr ies-    {-# NOINLINE unsafeAccumArray #-}-    unsafeAccumArray f e0 lu ies = unsafePerformIO $ unsafeAccumArrayCArray f e0 lu ies----- | Hackish way to get the zero element for a Storable type.-{-# NOINLINE zeroElem #-}-zeroElem :: Storable a => a -> a-zeroElem u = unsafePerformIO $-    withArray (replicate (sizeOf u) (0 :: Word8)) $ peek . castPtr--{-# INLINE unsafeArrayCArray #-}-unsafeArrayCArray :: (Storable e, Ix i)-                  => (i,i) -> [(Int, e)] -> e -> IO (CArray i e)-unsafeArrayCArray lu ies default_elem = do-        marr <- newArray lu default_elem-        sequence_ [unsafeWrite marr i e | (i, e) <- ies]-        unsafeFreezeIOCArray marr--{-# INLINE unsafeReplaceCArray #-}-unsafeReplaceCArray :: (Storable e, Ix i)-                       => CArray i e -> [(Int, e)] -> IO (CArray i e)-unsafeReplaceCArray arr ies = do-    marr <- thawIOCArray arr-    sequence_ [unsafeWrite marr i e | (i, e) <- ies]-    unsafeFreezeIOCArray marr--{-# INLINE unsafeAccumCArray #-}-unsafeAccumCArray :: (Storable e, Ix i)-                            => (e -> e' -> e) -> CArray i e -> [(Int, e')]-                                              -> IO (CArray i e)-unsafeAccumCArray f arr ies = do-    marr <- thawIOCArray arr-    sequence_ [do-        old <- unsafeRead marr i-        unsafeWrite marr i (f old new)-        | (i, new) <- ies]-    unsafeFreezeIOCArray marr--{-# INLINE unsafeAccumArrayCArray #-}-unsafeAccumArrayCArray :: (Storable e, Ix i)-                          => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')]-                                            -> IO (CArray i e)-unsafeAccumArrayCArray f e0 lu ies = do-    marr <- newArray lu e0-    sequence_ [do-        old <- unsafeRead marr i-        unsafeWrite marr i (f old new)-        | (i, new) <- ies]-    unsafeFreezeIOCArray marr--{-# INLINE eqCArray #-}-eqCArray :: (Storable e, Ix i, Eq e)-                   => CArray i e -> CArray i e -> Bool-eqCArray arr1@(CArray l1 u1 n1 _) arr2@(CArray l2 u2 n2 _) =-    if n1 == 0 then n2 == 0 else-        l1 == l2 && u1 == u2 &&-           and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]]--{-# INLINE cmpCArray #-}-cmpCArray :: (Storable e, Ix i, Ord e)-                    => CArray i e -> CArray i e -> Ordering-cmpCArray arr1 arr2 = compare (assocs arr1) (assocs arr2)--{-# INLINE cmpIntCArray #-}-cmpIntCArray :: (Storable e, Ord e)-                       => CArray Int e -> CArray Int e -> Ordering-cmpIntCArray arr1@(CArray l1 u1 n1 _) arr2@(CArray l2 u2 n2 _) =-    if n1 == 0 then if n2 == 0 then EQ else LT else-    if n2 == 0 then GT else-    case compare l1 l2 of-        EQ    -> foldr cmp (compare u1 u2) [0 .. (n1 `min` n2) - 1]-        other -> other-    where-    cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of-        EQ    -> rest-        other -> other--{-# RULES "cmpCArray/Int" cmpCArray = cmpIntCArray #-}--instance (Ix ix, Eq e, Storable e) => Eq (CArray ix e) where-    (==) = eqCArray--instance (Ix ix, Ord e, Storable e) => Ord (CArray ix e) where-    compare = cmpCArray--instance (Ix ix, Show ix, Show e, Storable e) => Show (CArray ix e) where-    showsPrec = showsIArray------- General purpose array operations which happen to be very fast for CArray.------- | O(1) reshape an array.  The number of elements in the new shape must not--- exceed the number in the old shape.  The elements are in C-style ordering.-reshape :: (Ix i, Ix j) => (j,j) -> CArray i e -> CArray j e-reshape (l',u') (CArray _ _ n fp) | n' > n = error "reshape: new size too large"-                                  | otherwise = CArray l' u' n' fp-    where n' = rangeSize (l', u')---- | O(1) make a rank 1 array from an arbitrary shape.--- It has the property that 'reshape (0, size a - 1) a == flatten a'.-flatten :: Ix i => CArray i e -> CArray Int e-flatten (CArray _ _ n fp) = CArray 0 (n - 1) n fp------- None of the following are specific to CArray.  Some could have slightly--- faster versions specialized to CArray.  In general, slicing is expensive--- because the slice is not contiguous in memory, so must be copied.  There are--- many specialized versions.------- | Generic slice and map.  This takes the new range, the inverse map on--- indices, and function to produce the next element.  It is the most general--- operation in its class.-ixmapWithIndP :: (Ix i, Ix i', IArray a e, IArray a' e')-                 => (i',i') -> (i' -> i) -> (i -> e -> i' -> e') -> a i e -> a' i' e'-ixmapWithIndP lu f g arr = listArray lu-                           [ let i = f i' in g i (arr ! i) i' | i' <- range lu ]---- | Less polymorphic version.-ixmapWithInd :: (Ix i, Ix i', IArray a e, IArray a e')-                => (i',i') -> (i' -> i) -> (i -> e -> i' -> e') -> a i e -> a i' e'-ixmapWithInd = ixmapWithIndP---- | Perform an operation on the elements, independent of their location.-ixmapWithP  :: (Ix i, Ix i', IArray a e, IArray a' e')-               => (i',i') -> (i' -> i) -> (e -> e') -> a i e -> a' i' e'-ixmapWithP lu f g arr = listArray lu-                        [ g (arr ! f i') | i' <- range lu ]---- | Less polymorphic version.-ixmapWith  :: (Ix i, Ix i', IArray a e, IArray a e')-              => (i',i') -> (i' -> i) -> (e -> e') -> a i e -> a i' e'-ixmapWith = ixmapWithP---- | More polymorphic version of 'ixmap'.-ixmapP :: (Ix i, Ix i', IArray a e, IArray a' e)-          => (i',i') -> (i' -> i) -> a i e -> a' i' e-ixmapP lu f arr = ixmapWithP lu f id arr---- | More friendly sub-arrays with element mapping.-sliceStrideWithP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e')-                    => (i',i') -> (i,i,i) -> (e -> e') -> a i e -> a' i' e'-sliceStrideWithP lu (start,next,end) f arr-    | all (inRange (bounds arr)) [start,next,end] = listArray lu es-    | otherwise = error "sliceStrideWith: out of bounds"-    where is = offsetShapeFromThenTo (shape arr) (index' start) (index' next) (index' end)-          es = map (f . (unsafeAt arr)) is-          index' = indexes arr---- | Less polymorphic version.-sliceStrideWith :: (Ix i, Shapable i, Ix i', IArray a e, IArray a e')-                   => (i',i') -> (i,i,i) -> (e -> e') -> a i e -> a i' e'-sliceStrideWith = sliceStrideWithP---- | Strided sub-array without element mapping.-sliceStrideP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e)-                => (i',i') -> (i,i,i) -> a i e -> a' i' e-sliceStrideP lu sne = sliceStrideWithP lu sne id---- | Less polymorphic version.-sliceStride :: (Ix i, Shapable i, Ix i', IArray a e)-               => (i',i') -> (i,i,i) -> a i e -> a i' e-sliceStride = sliceStrideP---- | Contiguous sub-array with element mapping.-sliceWithP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e')-              => (i',i') -> (i,i) -> (e -> e') -> a i e -> a' i' e'-sliceWithP lu (start,end) f arr-    | all (inRange (bounds arr)) [start,end] = listArray lu es-    | otherwise = error "sliceWith: out of bounds"-    where is = offsetShapeFromTo (shape arr) (index' start) (index' end)-          es = map (f . (unsafeAt arr)) is-          index' = indexes arr---- | Less polymorphic version.-sliceWith :: (Ix i, Shapable i, Ix i', IArray a e, IArray a e')-             => (i',i') -> (i,i) -> (e -> e') -> a i e -> a i' e'-sliceWith = sliceWithP---- | Contiguous sub-array without element mapping.-sliceP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e)-          => (i',i') -> (i,i) -> a i e -> a' i' e-sliceP lu se = sliceWithP lu se id---- | Less polymorphic version.-slice ::  (Ix i, Shapable i, Ix i', IArray a e)-          => (i',i') -> (i,i) -> a i e -> a i' e-slice = sliceP---- | In-place map on CArray.  Note that this is /IN PLACE/ so you should not--- retain any reference to the original.  It flagrantly breaks referential--- transparency!-{-# INLINE mapCArrayInPlace #-}-mapCArrayInPlace :: (Ix i, Storable e) => (e -> e) -> CArray i e -> CArray i e-mapCArrayInPlace f a = S.inlinePerformIO $ do-    withCArray a $ \p ->-        forM_ [0 .. size a - 1] $ \i ->-            peekElemOff p i >>= pokeElemOff p i . f-    return a---------------------------------------------- These are meant to be internal only-indexes :: (Ix i, Shapable i, IArray a e) => a i e -> i -> [Int]-indexes a i = map pred $ (sShape . fst . bounds) a i--offsetShapeFromThenTo :: [Int] -> [Int] -> [Int] -> [Int] -> [Int]-offsetShapeFromThenTo s a b c = foldr (liftA2 (+)) [0] (ilists stride a b c)-    where ilists = zipWith4 (\s' a' b' c' -> map (*s') $ enumFromThenTo a' b' c')-          stride = shapeToStride s--offsetShapeFromTo :: [Int] -> [Int] -> [Int] -> [Int]-offsetShapeFromTo = offsetShapeFromTo' id--offsetShapeFromTo' :: ([[Int]] -> [[Int]]) -> [Int] -> [Int] -> [Int] -> [Int]-offsetShapeFromTo' f s a b = foldr (liftA2 (+)) [0] (f $ ilists stride a b)-    where ilists = zipWith3 (\s' a' b' -> map (*s') $ enumFromTo a' b')-          stride = shapeToStride s--offsets :: (Ix a, Shapable a) => (a, a) -> a -> [Int]-offsets lu i = reverse . osets (index lu i) . reverse . scanl1 (*) . uncurry sShape $ lu-    where osets 0 [] = []-          osets i' (b:bs) = r : osets d bs-              where (d,r) = i' `divMod` b-          osets _ _ = error "osets"---------------------------------------------- | p-norm on the array taken as a vector-normp :: (Ix i, RealFloat e', Abs e e', IArray a e) => e' -> a i e -> e'-normp p a | 1 <= p && not (isInfinite p) = (** (1/p)) $ foldl' (\z e -> z + (abs_ e) ** p) 0 (elems a)-          | otherwise = error "normp: p < 1"---- | 2-norm on the array taken as a vector (Frobenius norm for matrices)-norm2 :: (Ix i, Floating e', Abs e e', IArray a e) => a i e -> e'-norm2 a = sqrt $ foldl' (\z e -> z + abs_ e ^ (2 :: Int)) 0 (elems a)---- | Sup norm on the array taken as a vector-normSup :: (Ix i, Num e', Ord e', Abs e e', IArray a e) => a i e -> e'-normSup a = foldl' (\z e -> z `max` abs_ e) 0 (elems a)---- | Polymorphic version of amap.-liftArrayP :: (Ix i, IArray a e, IArray a1 e1)-              => (e -> e1) -> a i e -> a1 i e1-liftArrayP f a = listArray (bounds a) (map f (elems a))---- | Equivalent to amap.  Here for consistency only.-liftArray :: (Ix i, IArray a e, IArray a e1)-              => (e -> e1) -> a i e -> a i e1-liftArray = liftArrayP---- | Polymorphic 2-array lift.-liftArray2P :: (Ix i, IArray a e, IArray a1 e1, IArray a2 e2)-              => (e -> e1 -> e2) -> a i e -> a1 i e1 -> a2 i e2-liftArray2P f a b | aBounds == bounds b =-                     listArray aBounds (zipWith f (elems a) (elems b))-                 | otherwise = error "liftArray2: array bounds must match"-    where aBounds = bounds a---- | Less polymorphic version.-liftArray2 :: (Ix i, IArray a e, IArray a e1, IArray a e2)-              => (e -> e1 -> e2) -> a i e -> a i e1 -> a i e2-liftArray2 = liftArray2P---- | Polymorphic 3-array lift.-liftArray3P :: (Ix i, IArray a e, IArray a1 e1, IArray a2 e2, IArray a3 e3)-               => (e -> e1 -> e2 -> e3) -> a i e -> a1 i e1 -> a2 i e2 -> a3 i e3-liftArray3P f a b c | aBounds == bounds b && aBounds == bounds c =-                       listArray aBounds (zipWith3 f (elems a) (elems b) (elems c))-                   | otherwise = error "liftArray2: array bounds must match"-    where aBounds = bounds a---- | Less polymorphic version.-liftArray3 :: (Ix i, IArray a e, IArray a e1, IArray a e2, IArray a e3)-              => (e -> e1 -> e2 -> e3) -> a i e -> a i e1 -> a i e2 -> a i e3-liftArray3 = liftArray3P----- | Hack so that norms have a sensible type.-class Abs a b | a -> b where-    abs_ :: a -> b-instance Abs (Complex Double) Double where-    abs_ = magnitude-instance Abs (Complex Float) Float where-    abs_ = magnitude-instance Abs Double Double where-    abs_ = abs-instance Abs Float Float where-    abs_ = abs----- | Allocate an array which is 16-byte aligned.  Essential for SIMD instructions.-mallocForeignPtrArrayAligned :: Storable a => Int -> IO (ForeignPtr a)-mallocForeignPtrArrayAligned n = doMalloc undefined-  where-    doMalloc :: Storable b => b -> IO (ForeignPtr b)-    doMalloc dummy = mallocForeignPtrBytesAligned (n * sizeOf dummy)---- | Allocate memory which is 16-byte aligned.  This is essential for SIMD--- instructions.  We know that mallocPlainForeignPtrBytes will give word-aligned--- memory, so we pad enough to be able to return the desired amount of memory--- after aligning our pointer.-mallocForeignPtrBytesAligned :: Int -> IO (ForeignPtr a)-mallocForeignPtrBytesAligned n = do-    (ForeignPtr addr contents) <- mallocPlainForeignPtrBytes (n + pad)-    let !(Ptr addr') = alignPtr (Ptr addr) 16-    return (ForeignPtr addr' contents)-    where pad = 16 - sizeOf (undefined :: Word)---- | Make a new CArray with an IO action.-createCArray :: (Ix i, Storable e) => (i,i) -> (Ptr e -> IO ()) -> IO (CArray i e)-createCArray lu f = do-    fp <- mallocForeignPtrArrayAligned (rangeSize lu)-    withForeignPtr fp f-    unsafeForeignPtrToCArray fp lu--unsafeCreateCArray :: (Ix i, Storable e) => (i,i) -> (Ptr e -> IO ()) -> CArray i e-unsafeCreateCArray lu =  unsafePerformIO . createCArray lu---instance (Ix i, Binary i, Binary e, Storable e) => Binary (CArray i e) where-    put a = do-        put (bounds a)-        mapM_ put (elems a)-    get = do-        lu <- get-        es <- replicateM (rangeSize lu) get-        return $ listArray lu es

@@ -1,40 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : Data.Array.IOCArray--- Copyright   : (c) 2008 Jed Brown--- License     : BSD-style--- --- Maintainer  : jed@59A2.org--- Stability   : experimental--- Portability : non-portable------ This module provides both the mutable 'IOCArray' which uses pinned memory on--- the GC'd heap.  Elements are stored according to the class 'Storable'.  You--- can obtain a pointer to the array contents to manipulate elements from--- languages like C.------ 'IOCArray' is 16-byte aligned by default.  If you create a 'IOCArray' with--- 'unsafeForeignPtrToIOCArray' then it may not be aligned.  This will be an--- issue if you intend to use SIMD instructions.------ 'IOCArray' is equivalent to 'Data.Array.Storable.StorableArray' and similar--- to 'Data.Array.IO.IOUArray' but slower.  'IOCArray' has O(1) versions of--- 'unsafeFreeze' and 'unsafeThaw' when converting to/from 'CArray'.---------------------------------------------------------------------------------module Data.Array.IOCArray (-    -- * IOCArray type-    IOCArray,--    -- * Foreign support-    withIOCArray,-    touchIOCArray,-    unsafeForeignPtrToIOCArray,--    -- * The overloaded mutable array interface-    module Data.Array.MArray-) where--import Data.Array.CArray.Base-import Data.Array.MArray

@@ -1,5 +1,6 @@ test:-	runhaskell Setup configure --user+	runhaskell Setup configure --user --enable-tests --enable-benchmarks 	runhaskell Setup build 	runhaskell Setup haddock+	./dist/build/test/test 	(cd tests; sh runtests.sh)

@@ -1,39 +1,33 @@ name:                carray-version:             0.1.5.2+version:             0.1.6 synopsis:            A C-compatible array library. description:-		     A C-compatible array library.-		     .-		     Provides both an immutable and mutable (in the IO monad) interface.-		     Includes utilities for multi-dimensional arrays, slicing and norms.-		     Memory is 16-byte aligned by default to enable use of SIMD instructions.-		     .+  A C-compatible array library.+  .+  Provides both an immutable and mutable (in the IO monad) interface.+  Includes utilities for multi-dimensional arrays, slicing and norms.+  Memory is 16-byte aligned by default to enable use of SIMD instructions. category:            Data license:             BSD3 license-file:        LICENSE author:              Jed Brown maintainer:          Jed Brown <jed@59A2.org>, Henning Thielemann <fft@henning-thielemann.de> stability:	     experimental-cabal-version:       >=1.6+cabal-version:       >=1.14 build-type:	     Simple -extra-source-files: tests/meteor-contest-c.hs-                    tests/meteor-contest-u.hs-                    tests/nsieve-bits-c.hs-                    tests/nsieve-bits-s.hs-                    tests/nsieve-bits-u.hs-                    tests/tests.hs-                    tests/runtests.sh-                    Makefile+extra-source-files:+  tests/runtests.sh+  Makefile  source-repository this-  tag:         0.1.5.2+  tag:         0.1.6   type:        darcs-  location:    http://code.haskell.org/carray/+  location:    http://hub.darcs.net/thielema/carray/  source-repository head   type:        darcs-  location:    http://code.haskell.org/carray/+  location:    http://hub.darcs.net/thielema/carray/   flag splitBase@@ -44,23 +38,94 @@   description: syb was split from base >= 4   library-  build-depends:   ix-shapable, binary+  build-depends:+    ix-shapable >=0.1 && <0.2,+    binary >=0.5 && <0.8,+    QuickCheck >=2.4 && <2.8+   if flag(bytestringInBase)-    build-depends: base >= 2.0 && < 2.2+    build-depends: base >=2.0 && <2.2   else-    build-depends: base < 2.0 || >= 3, bytestring+    build-depends: base <2.0 || >=3, bytestring >=0.9 && <0.11    if flag(splitBase)-    build-depends: base >= 3, array+    build-depends: base >=3, array >=0.1 && <0.6   else-    build-depends: base < 3+    build-depends: base <3    if flag(base4)-    build-depends: base >= 4 && < 5, syb >= 0.1+    build-depends: base >=4 && <5, syb >=0.1 && <0.6   else-    build-depends: base < 4+    build-depends: base <4 -  exposed-modules:   Data.Array.CArray-                     Data.Array.IOCArray-                     Data.Array.CArray.Base+  exposed-modules:+    Data.Array.CArray+    Data.Array.IOCArray+    Data.Array.CArray.Base   ghc-options: -Wall+  hs-source-dirs: src+  default-language:  Haskell98++test-suite test+  main-is: tests.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    QuickCheck,+    ix-shapable,+    carray,+    array,+    base++benchmark meteor-contest-c+  main-is: meteor-contest-c.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    carray,+    base++benchmark meteor-contest-u+  main-is: meteor-contest-u.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    array,+    base++benchmark nsieve-bits-c+  main-is: nsieve-bits-c.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    carray,+    array,+    base++benchmark nsieve-bits-s+  main-is: nsieve-bits-s.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    array,+    base++benchmark nsieve-bits-u+  main-is: nsieve-bits-u.hs+  ghc-options: -Wall+  hs-source-dirs: tests+  type: exitcode-stdio-1.0+  default-language:  Haskell98+  build-depends:+    array,+    base

@@ -0,0 +1,91 @@+-- |+-- Module      : Data.Array.CArray+-- Copyright   : (c) 2008 Jed Brown+-- License     : BSD-style+-- +-- Maintainer  : jed@59A2.org+-- Stability   : experimental+-- Portability : non-portable+--+-- This module provides the immutable 'CArray' which uses pinned memory on the+-- GC'd heap.  Elements are stored according to the class 'Storable'.  You can+-- obtain a pointer to the array contents to manipulate elements from+-- languages like C.+--+-- 'CArray' is 16-byte aligned by default.  If you create a 'CArray' with+-- 'unsafeForeignPtrToCArray' then it may not be aligned.  This will be an issue+-- if you intend to use SIMD instructions.+--+-- 'CArray' is similar to 'Data.Array.Unboxed.UArray' but slower if you stay+-- within Haskell.  'CArray' can handle more types and can be used by external+-- libraries.+--+-- 'CArray' has an instance of 'Binary'.+-----------------------------------------------------------------------------++module Data.Array.CArray (+    -- * CArray type+    CArray,++    -- * Multi-dimensional++    -- ** Fast reshaping+    reshape,+    flatten,++    -- ** Query+    rank,+    shape,+    size,++    -- * Mapping++    -- ** General+    ixmapWithIndP,+    ixmapWithInd,+    ixmapWithP,+    ixmapWith,+    ixmapP,++    -- ** Slicing+    sliceStrideWithP,+    sliceStrideWith,+    sliceStrideP,+    sliceStride,+    sliceWithP,+    sliceWith,+    sliceP,+    slice,++    -- * Lifting+    liftArrayP,+    liftArray,+    liftArray2P,+    liftArray2,+    liftArray3P,+    liftArray3,++    -- * Norms+    normp,+    norm2,+    normSup,++    -- * Types+    Shapable,+    Abs,++    -- * Unsafe low-level+    withCArray,+    unsafeForeignPtrToCArray,+    toForeignPtr,+    unsafeCArrayToByteString,+    unsafeByteStringToCArray,+    createCArray,++   -- * The overloaded immutable array interface+   module Data.Array.IArray+) where++import Data.Ix.Shapable+import Data.Array.IArray+import Data.Array.CArray.Base

@@ -0,0 +1,565 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 610+{-# OPTIONS_GHC -frewrite-rules #-}+#else+{-# OPTIONS_GHC -fenable-rewrite-rules #-}+#endif+#endif+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Array.CArray.Base+-- Copyright   : (c) 2001 The University of Glasgow+--               (c) 2008 Jed Brown+-- License     : BSD-style+-- +-- Maintainer  : jed@59A2.org+-- Stability   : experimental+-- Portability : non-portable+--+-- This module provides both the immutable 'CArray' and mutable 'IOCArray'.  The+-- underlying storage is exactly the same - pinned memory on the GC'd heap.+-- Elements are stored according to the class 'Storable'.  You can obtain a+-- pointer to the array contents to manipulate elements from languages like C.+--+-- 'CArray' is 16-byte aligned by default.  If you create a 'CArray' with+-- 'unsafeForeignPtrToCArray' then it may not be aligned.  This will be an issue+-- if you intend to use SIMD instructions.+--+-- 'CArray' is similar to 'Data.Array.Unboxed.UArray' but slower if you stay+-- within Haskell.  'CArray' can handle more types and can be used by external+-- libraries.+--+-- 'IOCArray' is equivalent to 'Data.Array.Storable.StorableArray' and similar+-- to 'Data.Array.IO.IOUArray' but slower.  'IOCArray' has O(1) versions of+-- 'unsafeFreeze' and 'unsafeThaw' when converting to/from 'CArray'.+-----------------------------------------------------------------------------++module Data.Array.CArray.Base where++import Data.Array.Base+            (bounds, elems, listArray, unsafeAt, assocs, (!),+             numElements, getNumElements, showsIArray,+             unsafeFreeze, unsafeThaw,+             unsafeRead, unsafeWrite,+             unsafeArray, unsafeReplace, unsafeAccum,+             unsafeAccumArray, unsafeNewArray_)+import Data.Array.MArray+            (MArray(getBounds, newArray, newArray_), freeze, thaw)+import Data.Array.IArray (IArray)+import Data.Ix.Shapable (Shapable, shape, sShape, shapeToStride, size)+import Data.Ix (Ix, rangeSize, range, inRange, index)++import qualified Test.QuickCheck as QC+import Test.QuickCheck (Arbitrary, arbitrary, CoArbitrary, coarbitrary,)+import qualified Data.ByteString.Internal as S+import Data.Binary (Binary, get, put)++import System.IO.Unsafe (unsafePerformIO)+import Foreign.Storable+            (Storable, sizeOf, alignment, peek, peekElemOff, pokeElemOff)+import Foreign.ForeignPtr+            (ForeignPtr, withForeignPtr, castForeignPtr, touchForeignPtr)+import Foreign.Marshal.Array (copyArray, withArray)+import Foreign.Ptr (plusPtr, alignPtr, castPtr)++import Data.Word                (Word8, Word)+import Data.Generics            (Data(..), Typeable)+import GHC.Ptr                  (Ptr(..))+import GHC.ForeignPtr           (ForeignPtr(..), mallocPlainForeignPtrBytes)++import Data.Complex (Complex, magnitude)+import Data.List (zipWith4, foldl')+import Control.Monad (replicateM, forM_, (>=>))+import Control.Applicative (liftA2)+++-- | The immutable array type.+data CArray i e = CArray !i !i Int !(ForeignPtr e)+    deriving (Data, Typeable)++-- | Absolutely equivalent representation, but used for the mutable interface.+data IOCArray i e = IOCArray !i !i Int !(ForeignPtr e)+    deriving (Data, Typeable)++instance Storable e => MArray IOCArray e IO where+    getBounds (IOCArray l u _ _) = return (l,u)++    getNumElements (IOCArray _ _ n _) = return n++    newArray (l,u) e0 = do+        fp <- mallocForeignPtrArrayAligned n+        withForeignPtr fp $ \a ->+            forM_ [0 .. n - 1] $ \i -> pokeElemOff a i e0+        return (IOCArray l u n fp)+        where n = rangeSize (l,u)++    unsafeNewArray_ (l,u) = do+        let n = rangeSize (l,u)+        fp <- mallocForeignPtrArrayAligned n+        return (IOCArray l u n fp)++    newArray_ = unsafeNewArray_++    unsafeRead (IOCArray _ _ _ fp) i =+        withForeignPtr fp $ \a -> peekElemOff a i++    unsafeWrite (IOCArray _ _ _ fp) i e =+        withForeignPtr fp $ \a -> pokeElemOff a i e++-- | The pointer to the array contents is obtained by 'withCArray'.+-- The idea is similar to 'ForeignPtr' (used internally here).+-- The pointer should be used only during execution of the 'IO' action+-- retured by the function passed as argument to 'withCArray'.+withCArray :: CArray i e -> (Ptr e -> IO a) -> IO a+withCArray (CArray _ _ _ fp) f = withForeignPtr fp f++withIOCArray :: IOCArray i e -> (Ptr e -> IO a) -> IO a+withIOCArray (IOCArray _ _ _ fp) f = withForeignPtr fp f++-- | If you want to use it afterwards, ensure that you+-- 'touchCArray' after the last use of the pointer,+-- so the array is not freed too early.+touchIOCArray :: IOCArray i e -> IO ()+touchIOCArray (IOCArray _ _ _ fp) = touchForeignPtr fp++-- | /O(1)/ Construct a 'CArray' from an arbitrary 'ForeignPtr'.  It is+-- the caller's responsibility to ensure that the 'ForeignPtr' points to+-- an area of memory sufficient for the specified bounds.+unsafeForeignPtrToCArray+   :: Ix i => ForeignPtr e -> (i,i) -> IO (CArray i e)+unsafeForeignPtrToCArray p (l,u) =+   return (CArray l u (rangeSize (l,u)) p)++-- | /O(1)/ Construct a 'CArray' from an arbitrary 'ForeignPtr'.  It is+-- the caller's responsibility to ensure that the 'ForeignPtr' points to+-- an area of memory sufficient for the specified bounds.+unsafeForeignPtrToIOCArray+   :: Ix i => ForeignPtr e -> (i,i) -> IO (IOCArray i e)+unsafeForeignPtrToIOCArray p (l,u) =+   return (IOCArray l u (rangeSize (l,u)) p)++-- | /O(1)/ Extract ForeignPtr from a CArray.+toForeignPtr :: CArray i e -> (Int, ForeignPtr e)+toForeignPtr (CArray _ _ n fp) = (n, fp)++-- | /O(1)/ Turn a CArray into a ByteString.  Unsafe because it uses+-- 'castForeignPtr' and thus is not platform independent.+unsafeCArrayToByteString :: (Storable e) => CArray i e -> S.ByteString+unsafeCArrayToByteString (CArray _ _ l fp) = go undefined fp+    where go :: (Storable e) => e -> ForeignPtr e -> S.ByteString+          go dummy fp' = S.fromForeignPtr (castForeignPtr fp') 0 (l * sizeOf dummy)++-- | /O(1)/ Turn a ByteString into a CArray.  Unsafe because it uses+-- 'castForeignPtr' and thus is not platform independent.  Returns 'Nothing' if+-- the range specified is larger than the size of the ByteString or the start of+-- the ByteString does not fulfil the alignment requirement of the resulting+-- CArray (as specified by the Storable instance).+unsafeByteStringToCArray :: (Ix i, Storable e)+                            => (i,i) -> S.ByteString -> Maybe (CArray i e)+unsafeByteStringToCArray lu bs = go undefined lu+    where go :: (Ix i, Storable e) => e -> (i,i) -> Maybe (CArray i e)+          go dummy (l,u) | safe = Just (CArray l u n fp)+                         | otherwise = Nothing+              where n = rangeSize (l,u)+                    !((ForeignPtr addr contents), off, len) = S.toForeignPtr bs+                    !p@(Ptr addr') = Ptr addr `plusPtr` off+                    fp = ForeignPtr addr' contents+                    safe = sizeOf dummy * n <= len && p == p `alignPtr` alignment dummy++copy :: (Ix i, Storable e) => CArray i e -> IO (CArray i e)+copy ain@(CArray l u n _) =+    createCArray (l,u) $ \op ->+        withCArray ain $ \ip ->+            copyArray op ip n++freezeIOCArray :: (Ix i, Storable e) => IOCArray i e -> IO (CArray i e)+freezeIOCArray = unsafeFreezeIOCArray >=> copy++unsafeFreezeIOCArray :: (Ix i) => IOCArray i e -> IO (CArray i e)+unsafeFreezeIOCArray (IOCArray l u n fp) = return (CArray l u n fp)++thawIOCArray :: (Ix i, Storable e) => CArray i e -> IO (IOCArray i e)+thawIOCArray = copy >=> unsafeThawIOCArray++unsafeThawIOCArray :: (Ix i) => CArray i e -> IO (IOCArray i e)+unsafeThawIOCArray (CArray l u n fp) = return (IOCArray l u n fp)++-- Since we can remove the (Storable e) restriction for these, the rules are+-- compact and general.+{-# RULES+"unsafeFreeze/IOCArray" unsafeFreeze = unsafeFreezeIOCArray+"unsafeThaw/IOCArray" unsafeThaw = unsafeThawIOCArray+  #-}++-- Since we can't parameterize the rules with the (Storable e) constraint, we+-- have to specialize manually.  This is unfortunate since it is less general.+{-# RULES+"freeze/IOCArray/Int"    freeze      = freezeIOCArray :: (Ix i) => IOCArray i Int -> IO (CArray i Int)+"freeze/IOCArray/Float"  freeze      = freezeIOCArray :: (Ix i) => IOCArray i Float -> IO (CArray i Float)+"freeze/IOCArray/Double" freeze      = freezeIOCArray :: (Ix i) => IOCArray i Double -> IO (CArray i Double)+"thaw/IOCArray/Int"      thaw        = thawIOCArray   :: (Ix i) => CArray i Int -> IO (IOCArray i Int)+"thaw/IOCArray/Float"    thaw        = thawIOCArray   :: (Ix i) => CArray i Float -> IO (IOCArray i Float)+"thaw/IOCArray/Double"   thaw        = thawIOCArray   :: (Ix i) => CArray i Double -> IO (IOCArray i Double)+  #-}+++instance Storable e => IArray CArray e where+    {-# INLINE bounds #-}+    bounds (CArray l u _ _) = (l,u)+    {-# INLINE numElements #-}+    numElements (CArray _ _ n _) = n+    {-# NOINLINE unsafeArray #-}+    unsafeArray lu ies = unsafePerformIO $ unsafeArrayCArray lu ies (zeroElem (undefined :: e))+    {-# INLINE unsafeAt #-}+    unsafeAt (CArray _ _ _ fp) i = S.inlinePerformIO $+                                   withForeignPtr fp $ \a -> peekElemOff a i+    {-# NOINLINE unsafeReplace #-}+    unsafeReplace arr ies = unsafePerformIO $ unsafeReplaceCArray arr ies+    {-# NOINLINE unsafeAccum #-}+    unsafeAccum f arr ies = unsafePerformIO $ unsafeAccumCArray f arr ies+    {-# NOINLINE unsafeAccumArray #-}+    unsafeAccumArray f e0 lu ies = unsafePerformIO $ unsafeAccumArrayCArray f e0 lu ies+++-- | Hackish way to get the zero element for a Storable type.+{-# NOINLINE zeroElem #-}+zeroElem :: Storable a => a -> a+zeroElem u = unsafePerformIO $+    withArray (replicate (sizeOf u) (0 :: Word8)) $ peek . castPtr++{-# INLINE unsafeArrayCArray #-}+unsafeArrayCArray :: (Storable e, Ix i)+                  => (i,i) -> [(Int, e)] -> e -> IO (CArray i e)+unsafeArrayCArray lu ies default_elem = do+    marr <- newArray lu default_elem+    mapM_ (uncurry $ unsafeWrite marr) ies+    unsafeFreezeIOCArray marr++{-# INLINE unsafeReplaceCArray #-}+unsafeReplaceCArray :: (Storable e, Ix i)+                       => CArray i e -> [(Int, e)] -> IO (CArray i e)+unsafeReplaceCArray arr ies = do+    marr <- thawIOCArray arr+    mapM_ (uncurry $ unsafeWrite marr) ies+    unsafeFreezeIOCArray marr++{-# INLINE unsafeAccumCArray #-}+unsafeAccumCArray :: (Storable e, Ix i)+                            => (e -> e' -> e) -> CArray i e -> [(Int, e')]+                                              -> IO (CArray i e)+unsafeAccumCArray f arr ies = do+    marr <- thawIOCArray arr+    forM_ ies $ \(i, new) -> do+        old <- unsafeRead marr i+        unsafeWrite marr i (f old new)+    unsafeFreezeIOCArray marr++{-# INLINE unsafeAccumArrayCArray #-}+unsafeAccumArrayCArray :: (Storable e, Ix i)+                          => (e -> e' -> e) -> e -> (i,i) -> [(Int, e')]+                                            -> IO (CArray i e)+unsafeAccumArrayCArray f e0 lu ies = do+    marr <- newArray lu e0+    forM_ ies $ \(i, new) -> do+        old <- unsafeRead marr i+        unsafeWrite marr i (f old new)+    unsafeFreezeIOCArray marr++{-# INLINE eqCArray #-}+eqCArray :: (Storable e, Ix i, Eq e)+                   => CArray i e -> CArray i e -> Bool+eqCArray arr1@(CArray l1 u1 n1 _) arr2@(CArray l2 u2 n2 _) =+    if n1 == 0 then n2 == 0 else+        l1 == l2 && u1 == u2 &&+           and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. n1 - 1]]++{-# INLINE [1] cmpCArray #-}+cmpCArray :: (Storable e, Ix i, Ord e)+                    => CArray i e -> CArray i e -> Ordering+cmpCArray arr1 arr2 = compare (assocs arr1) (assocs arr2)++{-# INLINE cmpIntCArray #-}+cmpIntCArray :: (Storable e, Ord e)+                       => CArray Int e -> CArray Int e -> Ordering+cmpIntCArray arr1@(CArray l1 u1 n1 _) arr2@(CArray l2 u2 n2 _) =+    if n1 == 0 then if n2 == 0 then EQ else LT else+    if n2 == 0 then GT else+    case compare l1 l2 of+        EQ    -> foldr cmp (compare u1 u2) [0 .. (n1 `min` n2) - 1]+        other -> other+    where+    cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of+        EQ    -> rest+        other -> other++{-# RULES "cmpCArray/Int" cmpCArray = cmpIntCArray #-}++instance (Ix ix, Eq e, Storable e) => Eq (CArray ix e) where+    (==) = eqCArray++instance (Ix ix, Ord e, Storable e) => Ord (CArray ix e) where+    compare = cmpCArray++instance (Ix ix, Show ix, Show e, Storable e) => Show (CArray ix e) where+    showsPrec = showsIArray++--+-- General purpose array operations which happen to be very fast for CArray.+--++-- | O(1) reshape an array.  The number of elements in the new shape must not+-- exceed the number in the old shape.  The elements are in C-style ordering.+reshape :: (Ix i, Ix j) => (j,j) -> CArray i e -> CArray j e+reshape (l',u') (CArray _ _ n fp) | n' > n = error "reshape: new size too large"+                                  | otherwise = CArray l' u' n' fp+    where n' = rangeSize (l', u')++-- | O(1) make a rank 1 array from an arbitrary shape.+-- It has the property that 'reshape (0, size a - 1) a == flatten a'.+flatten :: Ix i => CArray i e -> CArray Int e+flatten (CArray _ _ n fp) = CArray 0 (n - 1) n fp++--+-- None of the following are specific to CArray.  Some could have slightly+-- faster versions specialized to CArray.  In general, slicing is expensive+-- because the slice is not contiguous in memory, so must be copied.  There are+-- many specialized versions.+--++-- | Generic slice and map.  This takes the new range, the inverse map on+-- indices, and function to produce the next element.  It is the most general+-- operation in its class.+ixmapWithIndP :: (Ix i, Ix i', IArray a e, IArray a' e')+                 => (i',i') -> (i' -> i) -> (i -> e -> i' -> e') -> a i e -> a' i' e'+ixmapWithIndP lu f g arr = listArray lu+                           [ let i = f i' in g i (arr ! i) i' | i' <- range lu ]++-- | Less polymorphic version.+ixmapWithInd :: (Ix i, Ix i', IArray a e, IArray a e')+                => (i',i') -> (i' -> i) -> (i -> e -> i' -> e') -> a i e -> a i' e'+ixmapWithInd = ixmapWithIndP++-- | Perform an operation on the elements, independent of their location.+ixmapWithP  :: (Ix i, Ix i', IArray a e, IArray a' e')+               => (i',i') -> (i' -> i) -> (e -> e') -> a i e -> a' i' e'+ixmapWithP lu f g arr = listArray lu+                        [ g (arr ! f i') | i' <- range lu ]++-- | Less polymorphic version.+ixmapWith  :: (Ix i, Ix i', IArray a e, IArray a e')+              => (i',i') -> (i' -> i) -> (e -> e') -> a i e -> a i' e'+ixmapWith = ixmapWithP++-- | More polymorphic version of 'ixmap'.+ixmapP :: (Ix i, Ix i', IArray a e, IArray a' e)+          => (i',i') -> (i' -> i) -> a i e -> a' i' e+ixmapP lu f arr = ixmapWithP lu f id arr++-- | More friendly sub-arrays with element mapping.+sliceStrideWithP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e')+                    => (i',i') -> (i,i,i) -> (e -> e') -> a i e -> a' i' e'+sliceStrideWithP lu (start,next,end) f arr+    | all (inRange (bounds arr)) [start,next,end] = listArray lu es+    | otherwise = error "sliceStrideWith: out of bounds"+    where is = offsetShapeFromThenTo (shape arr) (index' start) (index' next) (index' end)+          es = map (f . (unsafeAt arr)) is+          index' = indexes arr++-- | Less polymorphic version.+sliceStrideWith :: (Ix i, Shapable i, Ix i', IArray a e, IArray a e')+                   => (i',i') -> (i,i,i) -> (e -> e') -> a i e -> a i' e'+sliceStrideWith = sliceStrideWithP++-- | Strided sub-array without element mapping.+sliceStrideP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e)+                => (i',i') -> (i,i,i) -> a i e -> a' i' e+sliceStrideP lu sne = sliceStrideWithP lu sne id++-- | Less polymorphic version.+sliceStride :: (Ix i, Shapable i, Ix i', IArray a e)+               => (i',i') -> (i,i,i) -> a i e -> a i' e+sliceStride = sliceStrideP++-- | Contiguous sub-array with element mapping.+sliceWithP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e')+              => (i',i') -> (i,i) -> (e -> e') -> a i e -> a' i' e'+sliceWithP lu (start,end) f arr+    | all (inRange (bounds arr)) [start,end] = listArray lu es+    | otherwise = error "sliceWith: out of bounds"+    where is = offsetShapeFromTo (shape arr) (index' start) (index' end)+          es = map (f . (unsafeAt arr)) is+          index' = indexes arr++-- | Less polymorphic version.+sliceWith :: (Ix i, Shapable i, Ix i', IArray a e, IArray a e')+             => (i',i') -> (i,i) -> (e -> e') -> a i e -> a i' e'+sliceWith = sliceWithP++-- | Contiguous sub-array without element mapping.+sliceP :: (Ix i, Shapable i, Ix i', IArray a e, IArray a' e)+          => (i',i') -> (i,i) -> a i e -> a' i' e+sliceP lu se = sliceWithP lu se id++-- | Less polymorphic version.+slice ::  (Ix i, Shapable i, Ix i', IArray a e)+          => (i',i') -> (i,i) -> a i e -> a i' e+slice = sliceP++-- | In-place map on CArray.  Note that this is /IN PLACE/ so you should not+-- retain any reference to the original.  It flagrantly breaks referential+-- transparency!+{-# INLINE mapCArrayInPlace #-}+mapCArrayInPlace :: (Ix i, Storable e) => (e -> e) -> CArray i e -> CArray i e+mapCArrayInPlace f a = S.inlinePerformIO $ do+    withCArray a $ \p ->+        forM_ [0 .. size a - 1] $ \i ->+            peekElemOff p i >>= pokeElemOff p i . f+    return a++-----------------------------------------+-- These are meant to be internal only+indexes :: (Ix i, Shapable i, IArray a e) => a i e -> i -> [Int]+indexes a i = map pred $ (sShape . fst . bounds) a i++offsetShapeFromThenTo :: [Int] -> [Int] -> [Int] -> [Int] -> [Int]+offsetShapeFromThenTo s a b c = foldr (liftA2 (+)) [0] (ilists stride a b c)+    where ilists = zipWith4 (\s' a' b' c' -> map (*s') $ enumFromThenTo a' b' c')+          stride = shapeToStride s++offsetShapeFromTo :: [Int] -> [Int] -> [Int] -> [Int]+offsetShapeFromTo = offsetShapeFromTo' id++offsetShapeFromTo' :: ([[Int]] -> [[Int]]) -> [Int] -> [Int] -> [Int] -> [Int]+offsetShapeFromTo' f s a b = foldr (liftA2 (+)) [0] (f $ ilists stride a b)+    where ilists = zipWith3 (\s' a' b' -> map (*s') $ enumFromTo a' b')+          stride = shapeToStride s++offsets :: (Ix a, Shapable a) => (a, a) -> a -> [Int]+offsets lu i = reverse . osets (index lu i) . reverse . scanl1 (*) . uncurry sShape $ lu+    where osets 0 [] = []+          osets i' (b:bs) = r : osets d bs+              where (d,r) = i' `divMod` b+          osets _ _ = error "osets"+-----------------------------------------++-- | p-norm on the array taken as a vector+normp :: (Ix i, RealFloat e', Abs e e', IArray a e) => e' -> a i e -> e'+normp p a | 1 <= p && not (isInfinite p) = (** (1/p)) $ foldl' (\z e -> z + (abs_ e) ** p) 0 (elems a)+          | otherwise = error "normp: p < 1"++-- | 2-norm on the array taken as a vector (Frobenius norm for matrices)+norm2 :: (Ix i, Floating e', Abs e e', IArray a e) => a i e -> e'+norm2 a = sqrt $ foldl' (\z e -> z + abs_ e ^ (2 :: Int)) 0 (elems a)++-- | Sup norm on the array taken as a vector+normSup :: (Ix i, Num e', Ord e', Abs e e', IArray a e) => a i e -> e'+normSup a = foldl' (\z e -> z `max` abs_ e) 0 (elems a)++-- | Polymorphic version of amap.+liftArrayP :: (Ix i, IArray a e, IArray a1 e1)+              => (e -> e1) -> a i e -> a1 i e1+liftArrayP f a = listArray (bounds a) (map f (elems a))++-- | Equivalent to amap.  Here for consistency only.+liftArray :: (Ix i, IArray a e, IArray a e1)+              => (e -> e1) -> a i e -> a i e1+liftArray = liftArrayP++-- | Polymorphic 2-array lift.+liftArray2P :: (Ix i, IArray a e, IArray a1 e1, IArray a2 e2)+              => (e -> e1 -> e2) -> a i e -> a1 i e1 -> a2 i e2+liftArray2P f a b | aBounds == bounds b =+                     listArray aBounds (zipWith f (elems a) (elems b))+                 | otherwise = error "liftArray2: array bounds must match"+    where aBounds = bounds a++-- | Less polymorphic version.+liftArray2 :: (Ix i, IArray a e, IArray a e1, IArray a e2)+              => (e -> e1 -> e2) -> a i e -> a i e1 -> a i e2+liftArray2 = liftArray2P++-- | Polymorphic 3-array lift.+liftArray3P :: (Ix i, IArray a e, IArray a1 e1, IArray a2 e2, IArray a3 e3)+               => (e -> e1 -> e2 -> e3) -> a i e -> a1 i e1 -> a2 i e2 -> a3 i e3+liftArray3P f a b c | aBounds == bounds b && aBounds == bounds c =+                       listArray aBounds (zipWith3 f (elems a) (elems b) (elems c))+                   | otherwise = error "liftArray2: array bounds must match"+    where aBounds = bounds a++-- | Less polymorphic version.+liftArray3 :: (Ix i, IArray a e, IArray a e1, IArray a e2, IArray a e3)+              => (e -> e1 -> e2 -> e3) -> a i e -> a i e1 -> a i e2 -> a i e3+liftArray3 = liftArray3P+++-- | Hack so that norms have a sensible type.+class Abs a b | a -> b where+    abs_ :: a -> b+instance Abs (Complex Double) Double where+    abs_ = magnitude+instance Abs (Complex Float) Float where+    abs_ = magnitude+instance Abs Double Double where+    abs_ = abs+instance Abs Float Float where+    abs_ = abs+++-- | Allocate an array which is 16-byte aligned.  Essential for SIMD instructions.+mallocForeignPtrArrayAligned :: Storable a => Int -> IO (ForeignPtr a)+mallocForeignPtrArrayAligned n = doMalloc undefined+  where+    doMalloc :: Storable b => b -> IO (ForeignPtr b)+    doMalloc dummy = mallocForeignPtrBytesAligned (n * sizeOf dummy)++-- | Allocate memory which is 16-byte aligned.  This is essential for SIMD+-- instructions.  We know that mallocPlainForeignPtrBytes will give word-aligned+-- memory, so we pad enough to be able to return the desired amount of memory+-- after aligning our pointer.+mallocForeignPtrBytesAligned :: Int -> IO (ForeignPtr a)+mallocForeignPtrBytesAligned n = do+    (ForeignPtr addr contents) <- mallocPlainForeignPtrBytes (n + pad)+    let !(Ptr addr') = alignPtr (Ptr addr) 16+    return (ForeignPtr addr' contents)+    where pad = 16 - sizeOf (undefined :: Word)++-- | Make a new CArray with an IO action.+createCArray :: (Ix i, Storable e) => (i,i) -> (Ptr e -> IO ()) -> IO (CArray i e)+createCArray lu f = do+    fp <- mallocForeignPtrArrayAligned (rangeSize lu)+    withForeignPtr fp f+    unsafeForeignPtrToCArray fp lu++unsafeCreateCArray :: (Ix i, Storable e) => (i,i) -> (Ptr e -> IO ()) -> CArray i e+unsafeCreateCArray lu =  unsafePerformIO . createCArray lu+++instance (Ix i, Binary i, Binary e, Storable e) => Binary (CArray i e) where+    put a = do+        put (bounds a)+        mapM_ put (elems a)+    get = do+        lu <- get+        es <- replicateM (rangeSize lu) get+        return $ listArray lu es+++instance+    (Ix i, Arbitrary i, Storable e, Arbitrary e) =>+        Arbitrary (CArray i e) where+    arbitrary = do+        a <- QC.arbitrary+        b <- QC.arbitrary+        let rng = (min a b, max a b)+        fmap (listArray rng) $ QC.vector (rangeSize rng)++instance+    (Ix i, CoArbitrary i, Storable e, CoArbitrary e) =>+        CoArbitrary (CArray i e) where+    coarbitrary a = coarbitrary (assocs a)

@@ -0,0 +1,40 @@+-----------------------------------------------------------------------------+-- |+-- Module      : Data.Array.IOCArray+-- Copyright   : (c) 2008 Jed Brown+-- License     : BSD-style+-- +-- Maintainer  : jed@59A2.org+-- Stability   : experimental+-- Portability : non-portable+--+-- This module provides both the mutable 'IOCArray' which uses pinned memory on+-- the GC'd heap.  Elements are stored according to the class 'Storable'.  You+-- can obtain a pointer to the array contents to manipulate elements from+-- languages like C.+--+-- 'IOCArray' is 16-byte aligned by default.  If you create a 'IOCArray' with+-- 'unsafeForeignPtrToIOCArray' then it may not be aligned.  This will be an+-- issue if you intend to use SIMD instructions.+--+-- 'IOCArray' is equivalent to 'Data.Array.Storable.StorableArray' and similar+-- to 'Data.Array.IO.IOUArray' but slower.  'IOCArray' has O(1) versions of+-- 'unsafeFreeze' and 'unsafeThaw' when converting to/from 'CArray'.+-----------------------------------------------------------------------------+++module Data.Array.IOCArray (+    -- * IOCArray type+    IOCArray,++    -- * Foreign support+    withIOCArray,+    touchIOCArray,+    unsafeForeignPtrToIOCArray,++    -- * The overloaded mutable array interface+    module Data.Array.MArray+) where++import Data.Array.CArray.Base+import Data.Array.MArray

@@ -7,13 +7,17 @@ --   Sterling Clover's translation of Tim Hochberg's Clean implementation  module Main where-import System.Environment-import Data.Bits-import Data.List-import Data.Array.CArray-import Control.Arrow +import System.Environment (getArgs)+import Data.Bits (setBit, testBit, shiftL, shiftR, (.&.), (.|.))+import Data.List (partition, intersperse, find, delete)+import Data.Array.CArray (CArray, Array, array, (!))+import Control.Arrow (first, (&&&))+import Prelude hiding (flip)++ --- The Board ---+n_elem, n_col, n_row :: Int n_elem = 5 n_col = 5 n_row = 10@@ -27,8 +31,13 @@ colors :: [Color] colors = [0..9] +cellAt :: Int -> Int -> Int cellAt x y = x + n_col * y++coordOf :: Int -> (Int, Int) coordOf i = snd &&& fst $ i `quotRem` n_col++isValid :: Int -> Col -> Bool isValid x y = 0 <= x && x < n_col && 0 <= y && y < n_row  --- Piece Operations ---@@ -53,9 +62,9 @@ 	  [E,  NW, NW, NW]]  permutations :: Piece -> [Piece]-permutations p = take 12 (perms p)+permutations = take 12 . perms     where-      perms p = p:(flip p) : perms (rotate p)+      perms p = p : flip p : perms (rotate p)       rotate piece = map r piece           where r E  = NE                 r NE = NW@@ -96,8 +105,13 @@     | otherwise = 1 + first0 (i `shiftR` 1)  --- Making the Bitmasks ---+mod2 :: Int -> Int mod2 x = x .&. 1++packSize :: Num a => a -> a -> a packSize a b = a*5+b++unpackSize :: Integral a => a -> (a, a) unpackSize n = quotRem n 5  move :: Direction -> CellCoord -> CellCoord@@ -153,7 +167,7 @@         | test mask x = x         | otherwise   = fnd test (x+step) -noLeftIslands :: Mask -> Bool+noLeftIslands, noRightIslands :: Mask -> Bool noLeftIslands  mask  = noLineIslands mask 0 20 5 noRightIslands mask  = noLineIslands mask 4 24 5 @@ -173,7 +187,7 @@     | x < 0 || x >= n_col = m     | y < 0 || y >= 6     = m     | testBit m i = m-    | otherwise = foldl (\m d -> fill m (move d cc)) (setBit m i)+    | otherwise = foldl (\mi d -> fill mi (move d cc)) (setBit m i)                   [E, NE, NW, W, SW, SE]     where i = cellAt x y @@ -182,9 +196,10 @@ masksForColor c = concatMap atCell cells   where     (evens, odds) = templatesForColor c-    atCell n-        | even y = [(y, retag (m `shiftL` x) c) | m <- evens , isok m x y]-        | odd  y = [(y, retag (m `shiftL` x) c) | m <- odds  , isok m x y]+    atCell n =+        if even y+          then [(y, retag (m `shiftL` x) c) | m <- evens , isok m x y]+          else [(y, retag (m `shiftL` x) c) | m <- odds  , isok m x y]         where (x, y) = coordOf n  isok :: Mask -> Row -> Col -> Bool@@ -250,7 +265,7 @@ solutions = solveCell 0 colors 0 [] []  solveCell :: Row -> [Color] -> Mask -> Solution -> [String] -> [String]-solveCell _ [] board soln results = let s = toString soln+solveCell _ [] _board soln results = let s = toString soln                                     in  s:(reverse s):results solveCell !row !todo !board !soln results     | top/=m_top = foldr solveMask results@@ -258,9 +273,10 @@     | otherwise  = solveCell (row+1) todo (board `shiftR` n_col) soln results     where top = board .&. m_top           masks = masksAtCell ! (row, (firstZero ! top) )-          solveMask (!m,!c) results =-              solveCell row (delete c todo) (untag m .|. board) (m:soln) results+          solveMask (!m,!c) ress =+              solveCell row (delete c todo) (untag m .|. board) (m:soln) ress +main :: IO () main = do     n <- return.read.head =<< getArgs     let nsolutions = take n solutions

@@ -7,13 +7,17 @@ --   Sterling Clover's translation of Tim Hochberg's Clean implementation  module Main where-import System.Environment-import Data.Bits-import Data.List-import Data.Array.Unboxed-import Control.Arrow +import System.Environment (getArgs)+import Data.Bits (setBit, testBit, shiftL, shiftR, (.&.), (.|.))+import Data.List (partition, intersperse, find, delete)+import Data.Array.Unboxed (UArray, Array, array, (!))+import Control.Arrow (first, (&&&))+import Prelude hiding (flip)++ --- The Board ---+n_elem, n_col, n_row :: Int n_elem = 5 n_col = 5 n_row = 10@@ -27,8 +31,13 @@ colors :: [Color] colors = [0..9] +cellAt :: Int -> Int -> Int cellAt x y = x + n_col * y++coordOf :: Int -> (Int, Int) coordOf i = snd &&& fst $ i `quotRem` n_col++isValid :: Int -> Col -> Bool isValid x y = 0 <= x && x < n_col && 0 <= y && y < n_row  --- Piece Operations ---@@ -53,9 +62,9 @@ 	  [E,  NW, NW, NW]]  permutations :: Piece -> [Piece]-permutations p = take 12 (perms p)+permutations = take 12 . perms     where-      perms p = p:(flip p) : perms (rotate p)+      perms p = p : flip p : perms (rotate p)       rotate piece = map r piece           where r E  = NE                 r NE = NW@@ -96,8 +105,13 @@     | otherwise = 1 + first0 (i `shiftR` 1)  --- Making the Bitmasks ---+mod2 :: Int -> Int mod2 x = x .&. 1++packSize :: Num a => a -> a -> a packSize a b = a*5+b++unpackSize :: Integral a => a -> (a, a) unpackSize n = quotRem n 5  move :: Direction -> CellCoord -> CellCoord@@ -153,7 +167,7 @@         | test mask x = x         | otherwise   = fnd test (x+step) -noLeftIslands :: Mask -> Bool+noLeftIslands, noRightIslands :: Mask -> Bool noLeftIslands  mask  = noLineIslands mask 0 20 5 noRightIslands mask  = noLineIslands mask 4 24 5 @@ -173,7 +187,7 @@     | x < 0 || x >= n_col = m     | y < 0 || y >= 6     = m     | testBit m i = m-    | otherwise = foldl (\m d -> fill m (move d cc)) (setBit m i)+    | otherwise = foldl (\mi d -> fill mi (move d cc)) (setBit m i)                   [E, NE, NW, W, SW, SE]     where i = cellAt x y @@ -182,9 +196,10 @@ masksForColor c = concatMap atCell cells   where     (evens, odds) = templatesForColor c-    atCell n-        | even y = [(y, retag (m `shiftL` x) c) | m <- evens , isok m x y]-        | odd  y = [(y, retag (m `shiftL` x) c) | m <- odds  , isok m x y]+    atCell n =+        if even y+          then [(y, retag (m `shiftL` x) c) | m <- evens , isok m x y]+          else [(y, retag (m `shiftL` x) c) | m <- odds  , isok m x y]         where (x, y) = coordOf n  isok :: Mask -> Row -> Col -> Bool@@ -250,7 +265,7 @@ solutions = solveCell 0 colors 0 [] []  solveCell :: Row -> [Color] -> Mask -> Solution -> [String] -> [String]-solveCell _ [] board soln results = let s = toString soln+solveCell _ [] _board soln results = let s = toString soln                                     in  s:(reverse s):results solveCell !row !todo !board !soln results     | top/=m_top = foldr solveMask results@@ -258,9 +273,10 @@     | otherwise  = solveCell (row+1) todo (board `shiftR` n_col) soln results     where top = board .&. m_top           masks = masksAtCell ! (row, (firstZero ! top) )-          solveMask (!m,!c) results =-              solveCell row (delete c todo) (untag m .|. board) (m:soln) results+          solveMask (!m,!c) ress =+              solveCell row (delete c todo) (untag m .|. board) (m:soln) ress +main :: IO () main = do     n <- return.read.head =<< getArgs     let nsolutions = take n solutions

@@ -1,4 +1,5 @@ {-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns#-}  --@@ -9,24 +10,31 @@ -- nsieve over an ST monad Bool array -- -import Data.Array.IOCArray-import Data.Array.Base-import Data.Array.CArray.Base-import System.IO.Unsafe (unsafePerformIO)-import System.Environment-import Control.Monad-import Data.Bits-import Text.Printf+import Data.Array.IOCArray (IOCArray)+import Data.Array.MArray (MArray, newArray)+import Data.Array.Base (unsafeRead, unsafeWrite) +import System.Environment (getArgs)+import Control.Monad (when)+import Data.Bits (shiftL)+import Text.Printf (printf)+++main :: IO () main = do     n <- getArgs >>= readIO . head :: IO Int     mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2] +sieve :: Int -> IO () sieve n = do-   let r = unsafePerformIO (do a <- newArray (2,n) True :: IO (IOCArray Int Bool)-                               go a n 2 0)+   r <- do+      a <- newArray (2,n) True :: IO (IOCArray Int Bool)+      go a n 2 0    printf "Primes up to %8d %8d\n" (n::Int) (r::Int) :: IO () +go ::+   (MArray array Bool m, Num a) =>+   array Int Bool -> Int -> Int -> a -> m a go !a !m !n !c     | n == m    = return c     | otherwise = do@@ -40,5 +48,3 @@                           | otherwise = go a m (n+1) (c+1)                     in loop (n `shiftL` 1)                else go a m (n+1) c--

@@ -1,4 +1,5 @@ {-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns#-}  --@@ -9,24 +10,31 @@ -- nsieve over an ST monad Bool array -- -import Control.Monad-import Data.Array.Storable-import Data.Array.Base-import System.IO.Unsafe (unsafePerformIO)-import System.Environment-import Control.Monad-import Data.Bits-import Text.Printf+import Data.Array.Storable (StorableArray)+import Data.Array.MArray (MArray, newArray)+import Data.Array.Base (unsafeRead, unsafeWrite) +import System.Environment (getArgs)+import Control.Monad (when)+import Data.Bits (shiftL)+import Text.Printf (printf)+++main :: IO () main = do     n <- getArgs >>= readIO . head :: IO Int     mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2] +sieve :: Int -> IO () sieve n = do-   let r = unsafePerformIO (do a <- newArray (2,n) True :: IO (StorableArray Int Bool)-                               go a n 2 0)+   r <- do+      a <- newArray (2,n) True :: IO (StorableArray Int Bool)+      go a n 2 0    printf "Primes up to %8d %8d\n" (n::Int) (r::Int) :: IO () +go ::+   (MArray array Bool m, Num a) =>+   array Int Bool -> Int -> Int -> a -> m a go !a !m !n !c     | n == m    = return c     | otherwise = do@@ -40,5 +48,3 @@                           | otherwise = go a m (n+1) (c+1)                     in loop (n `shiftL` 1)                else go a m (n+1) c--

@@ -1,4 +1,5 @@ {-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns#-}  --@@ -9,23 +10,31 @@ -- nsieve over an ST monad Bool array -- -import Control.Monad.ST-import Data.Array.ST-import Data.Array.Base-import System.Environment-import Control.Monad-import Data.Bits-import Text.Printf+import Control.Monad.ST (ST, runST)+import Data.Array.ST (STUArray)+import Data.Array.MArray (MArray, newArray)+import Data.Array.Base (unsafeRead, unsafeWrite) +import System.Environment (getArgs)+import Control.Monad (when)+import Data.Bits (shiftL)+import Text.Printf (printf)+++main :: IO () main = do     n <- getArgs >>= readIO . head :: IO Int     mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2] +sieve :: Int -> IO () sieve n = do    let r = runST (do a <- newArray (2,n) True :: ST s (STUArray s Int Bool)                      go a n 2 0)    printf "Primes up to %8d %8d\n" (n::Int) (r::Int) :: IO () +go ::+   (MArray array Bool m, Num a) =>+   array Int Bool -> Int -> Int -> a -> m a go !a !m !n !c     | n == m    = return c     | otherwise = do@@ -39,5 +48,3 @@                           | otherwise = go a m (n+1) (c+1)                     in loop (n `shiftL` 1)                else go a m (n+1) c--

@@ -1,14 +1,10 @@ #!/bin/sh -compile () {-    ghc --make -O2 $1 -o $2-}- time_run () {     arg=$1     shift     for e in $* ; do-	time ./$e $arg > $e.out+	time ../dist/build/$e/$e $arg > $e.out     done     diffn $* }@@ -24,12 +20,5 @@     echo '########' Failures: $ret } -compile nsieve-bits-u.hs nsU-compile nsieve-bits-c.hs nsC-compile nsieve-bits-s.hs nsS--compile meteor-contest-u.hs mcU-compile meteor-contest-c.hs mcC--time_run 8 nsU nsC nsS-time_run 2098 mcU mcC+time_run 8 nsieve-bits-u nsieve-bits-c nsieve-bits-s+time_run 2098 meteor-contest-u meteor-contest-c

@@ -1,39 +1,23 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, NoMonomorphismRestriction, UndecidableInstances #-}-import Control.Arrow-import Test.QuickCheck-import Text.Show.Functions+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+import qualified Test.QuickCheck as QC+import Test.QuickCheck (Property, (==>))+import Control.Arrow ((&&&), (***))+import Text.Show.Functions () import Data.Array.CArray+          (CArray, flatten, ixmapWithInd, rank, reshape, shape, size, sliceWith) import Data.Ix.Shapable (shapeToStride) import Data.Array.Unboxed-import Data.Binary-import Data.List-import Foreign.Storable-import Text.Printf+          (IArray, Ix, UArray,+           accum, amap, bounds, elems, inRange, ixmap, listArray, rangeSize)+import Foreign.Storable (Storable)+import Text.Printf (printf) import System.Environment (getArgs)-import System.IO-import System.Random+-- import System.Random -instance (Ix i, Arbitrary i, Storable e, Arbitrary e) => Arbitrary (CArray i e) where-    arbitrary = do-        a <- arbitrary-        b <- arbitrary-        let l = min a b-            u = max a b-        es <- vector (rangeSize (l,u))-        return $ listArray (l,u) es-    coarbitrary a = coarbitrary (assocs a) -instance (Ix i, Arbitrary i, Arbitrary e, IArray UArray e) => Arbitrary (UArray i e) where-    arbitrary = do-        a <- arbitrary-        b <- arbitrary-        let l = min a b-            u = max a b-        es <- vector (rangeSize (l,u))-        return $ listArray (l,u) es-    coarbitrary a = coarbitrary (assocs a)-+-- cf. storablevector/test class Model a b where model :: a -> b  instance (Ix i, IArray a e, Model i i', Model e e') => Model (a i e) ((i',i'),[e']) where@@ -59,27 +43,36 @@ instance (Model a a', Model b b', Model c c', Model d d') => Model (a,b,c,d) (a',b',c',d') where     model (a,b,c,d) = (model a, model b, model c, model d) -f =|= g = \a         ->-    model (f a)         == g (model a)+(=||=) ::+   (Model x1 y1, Model x y, Eq y) =>+   (x2 -> x1 -> x) -> (x2 -> y1 -> y) -> x2 -> x1 -> Bool++(=|||=) ::+   (Model x2 y2, Model x y, Eq y) =>+   (x3 -> x2 -> x1 -> x) -> (x3 -> y2 -> x1 -> y) -> x3 -> x2 -> x1 -> Bool+++infix 1 =||=, =|||=+ f =||= g = \a b       ->     model (f a b)       == g a (model b)-infix 1 =|=-infix 1 =||=- f =|||= g = \a b c     ->     model (f a b c)     == g a (model b) c-eq4 f g = \a b c d   ->-    model (f a b c d)   == g (model a) (model b) (model c) (model d)-eq5 f g = \a b c d e ->-    model (f a b c d e) == g (model a) (model b) (model c) (model d) (model e)  (===) :: (Eq b) => (a -> b) -> (a -> b) -> a -> Bool (f === g) x = f x == g x infixl 1 === +transposeArray :: CArray (Int,Int) Double -> CArray (Int,Int) Double transposeArray a = ixmap ((swap *** swap) (bounds a)) swap a     where swap = (\(i,j) -> (j,i)) ++type Test2D = CArray (Int,Int) Double -> Bool++prop_flatten_flatten, prop_reshape_flatten, prop_rank,+    prop_shape_size, prop_size, prop_shape_stride_last, prop_transpose :: Test2D+ prop_flatten_flatten = flatten . flatten === flatten prop_reshape_flatten a = reshape (0, size a - 1) a == flatten a prop_rank = length . shape === rank@@ -89,15 +82,17 @@ prop_transpose = transposeArray . transposeArray === id  ca_tests :: [(String, CArray (Int,Int) Double -> Bool)]-ca_tests = [ ("flatten flatten"   , prop_flatten_flatten)-           , ("reshape flatten"   , prop_reshape_flatten)-           , ("rank"              , prop_rank)-           , ("shape size"        , prop_shape_size)-           , ("size"              , prop_size)-           , ("shape stride last" , prop_shape_stride_last)-           , ("transpose^2"       , prop_transpose)-           ]+ca_tests =+    ("flatten flatten"   , prop_flatten_flatten) :+    ("reshape flatten"   , prop_reshape_flatten) :+    ("rank"              , prop_rank) :+    ("shape size"        , prop_shape_size) :+    ("size"              , prop_size) :+    ("shape stride last" , prop_shape_stride_last) :+    ("transpose^2"       , prop_transpose) :+    [] +prop_amap :: (Int -> Double) -> CArray Int Int -> Bool prop_amap =    (amap :: (Int -> Double) -> CArray Int Int -> CArray Int Double)           =||= (amap :: (Int -> Double) -> UArray Int Int -> UArray Int Double) @@ -107,22 +102,24 @@ prop_ixmapWithInd_amap f a = size a > 0 ==> ixmapWithInd (bounds a) id (\_ e _ -> f e) a == amap f a  type Acc = Int+prop_accum :: (Int -> Acc -> Int) -> CArray Int Int -> [(Int, Acc)] -> Property prop_accum f a ies = all (inRange (bounds a) . fst) ies     ==> (      (accum :: (Int -> Acc -> Int) -> CArray Int Int -> [(Int, Acc)] -> CArray Int Int)          =|||= (accum :: (Int -> Acc -> Int) -> UArray Int Int -> [(Int, Acc)] -> UArray Int Int)) f a ies +type Transform = CArray Int Int -> CArray Int Int++prop_composeAssoc ::+    Transform -> Transform -> Transform -> CArray Int Int -> Bool prop_composeAssoc f g h = (f . g) . h === f . (g . h)-    where types = [f,g,h] :: [CArray Int Int -> CArray Int Int] +main :: IO () main = do-    x <- getArgs-    let n = if null x then 100 else read . head $ x-        conf = Config { configMaxTest = n-                      , configMaxFail = 1000-                      , configSize = (+ 3) . (`div` 2)-                      , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s]-                      }-        mycheck (s,a) = printf "%-25s: " s >> check conf a+    args <- getArgs+    n <- case args of [] -> return 100; str:_ -> readIO str+    let mycheck (s,a) =+            printf "%-25s: " s >>+            QC.quickCheckWith (QC.stdArgs {QC.maxSuccess = n}) a     mapM_ mycheck ca_tests     mapM_ mycheck [ ("amap"        , prop_amap) ]     mapM_ mycheck [ ("accum"       , prop_accum) ]