carray 0.1.0.0 → 0.1.1
raw patch · 10 files changed
+2/−871 lines, 10 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Data.Array.CArray.Base: instance (RealFloat a, Storable a) => Storable (Complex a)
Files
- Data/Array/CArray/Base.hs +1/−13
- README +0/−29
- carray.cabal +1/−1
- tests/meteor-contest-c.hs +0/−268
- tests/meteor-contest-u.hs +0/−268
- tests/nsieve-bits-c.hs +0/−42
- tests/nsieve-bits-s.hs +0/−42
- tests/nsieve-bits-u.hs +0/−41
- tests/runtests.sh +0/−35
- tests/tests.hs +0/−132
Data/Array/CArray/Base.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -frewrite-rules #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, MagicHash,- FlexibleInstances, FlexibleContexts, UnboxedTuples, ScopedTypeVariables,- DeriveDataTypeable, CPP #-}+ FlexibleInstances, FlexibleContexts, UnboxedTuples, DeriveDataTypeable, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Array.CArray.Base@@ -533,17 +532,6 @@ , rangeSize (i,i')] sBounds [a,b,c,d,e,f,g,h,i] = ((0,0,0,0,0,0,0,0,0) ,(a-1,b-1,c-1,d-1,e-1,f-1,g-1,h-1,i-1))----- Represent the Complex value so that it conforms to the C99, C++, and FFTW--- Complex format. This instance should probably be in the base libs.-instance (RealFloat a, Storable a) => Storable (Complex a) where- sizeOf _ = 2 * sizeOf (undefined :: a)- alignment _ = sizeOf (undefined :: a)- peek p = do- [r,i] <- peekArray 2 (castPtr p)- return (r :+ i)- poke p (r :+ i) = pokeArray (castPtr p) [r,i] -- | Hack so that norms have a sensible type.
− README
@@ -1,29 +0,0 @@-This package provides immutable and mutable arrays that can be used in foreign-calls. They are 16-byte aligned by default to facilitate use of SIMD-instructions. To build this package, use:-- runhaskell Setup.lhs configure- runhaskell Setup.lhs build- runhaskell Setup.lhs haddock (optional)- runhaskell Setup.lhs install--Then run the tests:-- cd tests- ghc -O2 --make tests.hs -o tests && ./tests # checks QC properties --In addition, there are versions two of shootout entries which use arrays.-Modified versions of these are in the tests directory, using various array-implementations. To build, benchmark, and check that results match, run:-- ./runtests.sh---Exposed Modules:--Data.Array.CArray Immutable interface, enhanced for foreign calls,- multiple dimensions, mapping, and norms.--Data.Array.IOCArray Mutable interface, enhanced for foreign calls--Data.Array.CArray.Base Internals
carray.cabal view
@@ -1,5 +1,5 @@ name: carray-version: 0.1.0.0+version: 0.1.1 synopsis: A C-compatible array library. description: A C-compatible array library.
− tests/meteor-contest-c.hs
@@ -1,268 +0,0 @@-{-# OPTIONS -O2 -fbang-patterns -optc-O3 #-}---- The Computer Language Benchmarks Game--- http://shootout.alioth.debian.org/------ 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----- The Board ----n_elem = 5-n_col = 5-n_row = 10--m_top :: Mask-m_top = 0x1F--cells :: [Cell]-cells = [0..49]--colors :: [Color]-colors = [0..9]--cellAt x y = x + n_col * y-coordOf i = snd &&& fst $ i `quotRem` n_col-isValid x y = 0 <= x && x < n_col && 0 <= y && y < n_row----- Piece Operations ----data Direction = E | SE | SW | W | NW | NE deriving (Enum, Eq, Ord)-type Piece = [Direction]-type CellCoord = (Int, Int)-type Mask = Int; type Color = Int; type Row = Int;-type Col = Int; type Tag = Int; type Cell = Int-type Solution = [Mask]--pieces :: Array Int Piece-pieces = array (0,9) $ zip [0..9] $- [[E, E, E, SE],- [SE, SW, W, SW],- [W, W, SW, SE],- [E, E, SW, SE],- [NW, W, NW, SE, SW],- [E, E, NE, W],- [NW, NE, NE, W],- [NE, SE, E, NE],- [SE, SE, E, SE],- [E, NW, NW, NW]]--permutations :: Piece -> [Piece]-permutations p = take 12 (perms p)- where- perms p = p:(flip p) : perms (rotate p)- rotate piece = map r piece- where r E = NE- r NE = NW- r NW = W- r W = SW- r SW = SE- r SE = E- flip piece = map f piece- where f E = W- f NE = NW- f NW = NE- f W = E- f SW = SE- f SE = SW----- Mask Operations -----untag :: Mask -> Mask-untag mask = mask .&. 0x1ffffff--retag :: Mask -> Tag -> Mask-retag mask n = untag mask .|. n `shiftL` 25--tagof :: Mask -> Tag-tagof mask = mask `shiftR` 25--tag :: Mask -> Tag -> Mask-tag mask n = mask .|. n `shiftL` 25--count1s :: Mask -> Int-count1s i- | i == 0 = 0- | i .&. 1 == 1 = 1 + count1s (i `shiftR` 1)- | otherwise = count1s (i `shiftR` 1)--first0 :: Mask -> Int-first0 i- | i .&. 1 == 0 = 0- | otherwise = 1 + first0 (i `shiftR` 1)----- Making the Bitmasks ----mod2 x = x .&. 1-packSize a b = a*5+b-unpackSize n = quotRem n 5--move :: Direction -> CellCoord -> CellCoord-move E (x, y) = (x+1, y)-move W (x, y) = (x-1, y)-move NE (x, y) = (x+(mod2 y), y-1)-move NW (x, y) = (x+(mod2 y)-1, y-1)-move SE (x, y) = (x+(mod2 y), y+1)-move SW (x, y) = (x+(mod2 y)-1, y+1)--pieceBounds :: Piece -> Bool -> (Int, Int, Int, Int)-pieceBounds piece isodd = bnds piece 0 y0 0 y0 0 y0- where- y0 | isodd = 1 | otherwise = 0- bnds [] _ _ xmin ymin xmax ymax = (xmin, ymin, xmax, ymax)- bnds (d:rest) x y xmin ymin xmax ymax =- bnds rest x' y' (min x' xmin) (min y' ymin) (max x' xmax) (max y' ymax)- where (x', y') = move d (x, y)--pieceMask :: Piece -> (Mask, Mask)-pieceMask piece- | odd y1 = (tag (msk piece x2 y2 0) (packSize w2 h2),- tag (msk piece x1 (y1+1) 0 `shiftR` n_col) (packSize w1 h1))- | otherwise = (tag (msk piece x1 y1 0) (packSize w1 h1),- tag (msk piece x2 (y2+1) 0 `shiftR` n_col) (packSize w2 h2))- where- (xmin, ymin, xmax, ymax) = pieceBounds piece False- (x1, y1) = (-xmin, -ymin)- w1 = xmax - xmin- h1 = ymax - ymin- (xmin', ymin', xmax', ymax') = pieceBounds piece True- (x2, y2) = (-xmin', (-ymin')+1)- w2 = xmax' - xmin'- h2 = ymax' - ymin'- msk :: Piece -> Col -> Row -> Mask -> Mask- msk [] x y m = m `setBit` cellAt x y- msk (d:rest) x y m = msk rest x' y' (m `setBit` cellAt x y)- where (x', y') = move d (x, y)--templatesForColor :: Color -> ([Mask], [Mask])-templatesForColor c = (unzip . map pieceMask) perms- where perms | c == 5 = take 6 ps | otherwise = ps- ps = permutations $ pieces ! c----- Looking for Islands ----noLineIslands :: Mask -> Cell -> Cell -> Int -> Bool-noLineIslands mask start stop step- | (fnd testBit . fnd ((not .) . testBit) . fnd testBit) start > stop = True- | otherwise = False- where- fnd test !x- | x >= 25 = 25- | test mask x = x- | otherwise = fnd test (x+step)--noLeftIslands :: Mask -> Bool-noLeftIslands mask = noLineIslands mask 0 20 5-noRightIslands mask = noLineIslands mask 4 24 5--noIslands :: Mask -> Bool-noIslands board = noisles board (count1s board)--noisles :: Mask -> Int -> Bool-noisles _ 30 = True-noisles board ones- | (ones' - ones) `rem` n_elem /= 0 = False- | otherwise = noisles board' ones'- where board' = fill board (coordOf (first0 board))- ones' = count1s board'--fill :: Mask -> CellCoord -> Mask-fill m cc@(x, y)- | 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)- [E, NE, NW, W, SW, SE]- where i = cellAt x y----- More Mask Generation ----masksForColor :: Color -> [(Row, Mask)]-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]- where (x, y) = coordOf n--isok :: Mask -> Row -> Col -> Bool-isok mask x y =- isValid (x+width) (y+height) &&- case (y == 0, y+height==9) of- (False, False) -> noLeftIslands mask' && noRightIslands mask'- (False, True) -> noIslands (mask' `shiftL` (n_col * (y - 4)))- (True, _ ) -> noIslands mask'- where (width, height) = unpackSize (tagof mask)- mask' = untag mask `shiftL` x--masksAtCell :: Array (Row,Col) (Array Color [Mask])-masksAtCell = trps $ map (masksAt cells . masksForColor) colors--masksAt :: [Int] -> [(Row,Mask)]-> [[Mask]]-masksAt [] _ = []-masksAt (n:ns) !masks = map snd t : masksAt ns f- where- (t, f) = partition test masks- test (r, m) = n' >= 0 && n' < 25 && m `testBit` n'- where n' = n - (n_col * r)--trps :: [[[Mask]]] -> Array (Row, Col) (Array Color [Mask])-trps !a = array ((0,0),(9,4)) $ concatMap (uncurry (map . first . (,))) $- zip [0..9] [copy !! y | y <- [1,0,1,0,1,2,3,4,5,6]]- where- copy = [ [(x,copy' (cellAt x y)) | x <- [0..n_col-1]] |- y <- [1,2,5,6,7,8,9]]- copy' cell = array (0,9) $ map (\clr -> (clr,a !! clr !! cell)) colors----- Formatting ----format :: Bool -> String -> String-format _ [] = ""-format isodd chars | isodd = " " ++ str | otherwise = str- where- (cur, rest) = splitAt 5 chars- str = intersperse ' ' cur ++ " \n" ++ format (not isodd) rest--toString :: Solution -> String-toString !masks = map color cells- where- masksWithRows = withRows 0 0 (reverse masks)- withRows _ _ [] = []- withRows board r (m:rest) = (r', m) : withRows board' r' rest- where delta = first0 board `quot` n_col- board' = board `shiftR` (delta * n_col) .|. untag m- r' = r+delta- color n = maybe '.' (("0123456789" !!) . tagof . snd)- (find matches masksWithRows)- where- matches (r, m)- | n' < 0 || n' > 30 = False- | otherwise = (untag m) `testBit` n'- where n' = n - (n_col * r)----- Generate the solutions ----firstZero :: CArray Int Int-firstZero = array (0,31) $ zip [0..31]- [0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,5]--solutions :: [String]-solutions = solveCell 0 colors 0 [] []--solveCell :: Row -> [Color] -> Mask -> Solution -> [String] -> [String]-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- [(m, c) | c <- todo, m <- masks ! c, board .&. m == 0]- | 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--main = do- n <- return.read.head =<< getArgs- let nsolutions = take n solutions- putStrLn $ (show $ length nsolutions) ++ " solutions found\n"- putStrLn . format False . minimum $ nsolutions- putStrLn . format False . maximum $ nsolutions
− tests/meteor-contest-u.hs
@@ -1,268 +0,0 @@-{-# OPTIONS -O2 -fbang-patterns -optc-O3 #-}---- The Computer Language Benchmarks Game--- http://shootout.alioth.debian.org/------ 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----- The Board ----n_elem = 5-n_col = 5-n_row = 10--m_top :: Mask-m_top = 0x1F--cells :: [Cell]-cells = [0..49]--colors :: [Color]-colors = [0..9]--cellAt x y = x + n_col * y-coordOf i = snd &&& fst $ i `quotRem` n_col-isValid x y = 0 <= x && x < n_col && 0 <= y && y < n_row----- Piece Operations ----data Direction = E | SE | SW | W | NW | NE deriving (Enum, Eq, Ord)-type Piece = [Direction]-type CellCoord = (Int, Int)-type Mask = Int; type Color = Int; type Row = Int;-type Col = Int; type Tag = Int; type Cell = Int-type Solution = [Mask]--pieces :: Array Int Piece-pieces = array (0,9) $ zip [0..9] $- [[E, E, E, SE],- [SE, SW, W, SW],- [W, W, SW, SE],- [E, E, SW, SE],- [NW, W, NW, SE, SW],- [E, E, NE, W],- [NW, NE, NE, W],- [NE, SE, E, NE],- [SE, SE, E, SE],- [E, NW, NW, NW]]--permutations :: Piece -> [Piece]-permutations p = take 12 (perms p)- where- perms p = p:(flip p) : perms (rotate p)- rotate piece = map r piece- where r E = NE- r NE = NW- r NW = W- r W = SW- r SW = SE- r SE = E- flip piece = map f piece- where f E = W- f NE = NW- f NW = NE- f W = E- f SW = SE- f SE = SW----- Mask Operations -----untag :: Mask -> Mask-untag mask = mask .&. 0x1ffffff--retag :: Mask -> Tag -> Mask-retag mask n = untag mask .|. n `shiftL` 25--tagof :: Mask -> Tag-tagof mask = mask `shiftR` 25--tag :: Mask -> Tag -> Mask-tag mask n = mask .|. n `shiftL` 25--count1s :: Mask -> Int-count1s i- | i == 0 = 0- | i .&. 1 == 1 = 1 + count1s (i `shiftR` 1)- | otherwise = count1s (i `shiftR` 1)--first0 :: Mask -> Int-first0 i- | i .&. 1 == 0 = 0- | otherwise = 1 + first0 (i `shiftR` 1)----- Making the Bitmasks ----mod2 x = x .&. 1-packSize a b = a*5+b-unpackSize n = quotRem n 5--move :: Direction -> CellCoord -> CellCoord-move E (x, y) = (x+1, y)-move W (x, y) = (x-1, y)-move NE (x, y) = (x+(mod2 y), y-1)-move NW (x, y) = (x+(mod2 y)-1, y-1)-move SE (x, y) = (x+(mod2 y), y+1)-move SW (x, y) = (x+(mod2 y)-1, y+1)--pieceBounds :: Piece -> Bool -> (Int, Int, Int, Int)-pieceBounds piece isodd = bnds piece 0 y0 0 y0 0 y0- where- y0 | isodd = 1 | otherwise = 0- bnds [] _ _ xmin ymin xmax ymax = (xmin, ymin, xmax, ymax)- bnds (d:rest) x y xmin ymin xmax ymax =- bnds rest x' y' (min x' xmin) (min y' ymin) (max x' xmax) (max y' ymax)- where (x', y') = move d (x, y)--pieceMask :: Piece -> (Mask, Mask)-pieceMask piece- | odd y1 = (tag (msk piece x2 y2 0) (packSize w2 h2),- tag (msk piece x1 (y1+1) 0 `shiftR` n_col) (packSize w1 h1))- | otherwise = (tag (msk piece x1 y1 0) (packSize w1 h1),- tag (msk piece x2 (y2+1) 0 `shiftR` n_col) (packSize w2 h2))- where- (xmin, ymin, xmax, ymax) = pieceBounds piece False- (x1, y1) = (-xmin, -ymin)- w1 = xmax - xmin- h1 = ymax - ymin- (xmin', ymin', xmax', ymax') = pieceBounds piece True- (x2, y2) = (-xmin', (-ymin')+1)- w2 = xmax' - xmin'- h2 = ymax' - ymin'- msk :: Piece -> Col -> Row -> Mask -> Mask- msk [] x y m = m `setBit` cellAt x y- msk (d:rest) x y m = msk rest x' y' (m `setBit` cellAt x y)- where (x', y') = move d (x, y)--templatesForColor :: Color -> ([Mask], [Mask])-templatesForColor c = (unzip . map pieceMask) perms- where perms | c == 5 = take 6 ps | otherwise = ps- ps = permutations $ pieces ! c----- Looking for Islands ----noLineIslands :: Mask -> Cell -> Cell -> Int -> Bool-noLineIslands mask start stop step- | (fnd testBit . fnd ((not .) . testBit) . fnd testBit) start > stop = True- | otherwise = False- where- fnd test !x- | x >= 25 = 25- | test mask x = x- | otherwise = fnd test (x+step)--noLeftIslands :: Mask -> Bool-noLeftIslands mask = noLineIslands mask 0 20 5-noRightIslands mask = noLineIslands mask 4 24 5--noIslands :: Mask -> Bool-noIslands board = noisles board (count1s board)--noisles :: Mask -> Int -> Bool-noisles _ 30 = True-noisles board ones- | (ones' - ones) `rem` n_elem /= 0 = False- | otherwise = noisles board' ones'- where board' = fill board (coordOf (first0 board))- ones' = count1s board'--fill :: Mask -> CellCoord -> Mask-fill m cc@(x, y)- | 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)- [E, NE, NW, W, SW, SE]- where i = cellAt x y----- More Mask Generation ----masksForColor :: Color -> [(Row, Mask)]-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]- where (x, y) = coordOf n--isok :: Mask -> Row -> Col -> Bool-isok mask x y =- isValid (x+width) (y+height) &&- case (y == 0, y+height==9) of- (False, False) -> noLeftIslands mask' && noRightIslands mask'- (False, True) -> noIslands (mask' `shiftL` (n_col * (y - 4)))- (True, _ ) -> noIslands mask'- where (width, height) = unpackSize (tagof mask)- mask' = untag mask `shiftL` x--masksAtCell :: Array (Row,Col) (Array Color [Mask])-masksAtCell = trps $ map (masksAt cells . masksForColor) colors--masksAt :: [Int] -> [(Row,Mask)]-> [[Mask]]-masksAt [] _ = []-masksAt (n:ns) !masks = map snd t : masksAt ns f- where- (t, f) = partition test masks- test (r, m) = n' >= 0 && n' < 25 && m `testBit` n'- where n' = n - (n_col * r)--trps :: [[[Mask]]] -> Array (Row, Col) (Array Color [Mask])-trps !a = array ((0,0),(9,4)) $ concatMap (uncurry (map . first . (,))) $- zip [0..9] [copy !! y | y <- [1,0,1,0,1,2,3,4,5,6]]- where- copy = [ [(x,copy' (cellAt x y)) | x <- [0..n_col-1]] |- y <- [1,2,5,6,7,8,9]]- copy' cell = array (0,9) $ map (\clr -> (clr,a !! clr !! cell)) colors----- Formatting ----format :: Bool -> String -> String-format _ [] = ""-format isodd chars | isodd = " " ++ str | otherwise = str- where- (cur, rest) = splitAt 5 chars- str = intersperse ' ' cur ++ " \n" ++ format (not isodd) rest--toString :: Solution -> String-toString !masks = map color cells- where- masksWithRows = withRows 0 0 (reverse masks)- withRows _ _ [] = []- withRows board r (m:rest) = (r', m) : withRows board' r' rest- where delta = first0 board `quot` n_col- board' = board `shiftR` (delta * n_col) .|. untag m- r' = r+delta- color n = maybe '.' (("0123456789" !!) . tagof . snd)- (find matches masksWithRows)- where- matches (r, m)- | n' < 0 || n' > 30 = False- | otherwise = (untag m) `testBit` n'- where n' = n - (n_col * r)----- Generate the solutions ----firstZero :: UArray Int Int-firstZero = array (0,31) $ zip [0..31]- [0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,5]--solutions :: [String]-solutions = solveCell 0 colors 0 [] []--solveCell :: Row -> [Color] -> Mask -> Solution -> [String] -> [String]-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- [(m, c) | c <- todo, m <- masks ! c, board .&. m == 0]- | 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--main = do- n <- return.read.head =<< getArgs- let nsolutions = take n solutions- putStrLn $ (show $ length nsolutions) ++ " solutions found\n"- putStrLn . format False . minimum $ nsolutions- putStrLn . format False . maximum $ nsolutions
− tests/nsieve-bits-c.hs
@@ -1,42 +0,0 @@-{-# OPTIONS -O2 -optc-O -fbang-patterns #-}------ The Computer Language Shootout--- http://shootout.alioth.debian.org/------ Contributed by Don Stewart--- 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-import Control.Monad-import Data.Bits-import Text.Printf--main = do- n <- getArgs >>= readIO . head :: IO Int- mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2]--sieve n = do- let r = unsafePerformIO (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 !a !m !n !c- | n == m = return c- | otherwise = do- e <- unsafeRead a n- if e then let loop !j- | j < m = do- x <- unsafeRead a j- when x $ unsafeWrite a j False- loop (j+n)-- | otherwise = go a m (n+1) (c+1)- in loop (n `shiftL` 1)- else go a m (n+1) c--
− tests/nsieve-bits-s.hs
@@ -1,42 +0,0 @@-{-# OPTIONS -O2 -optc-O -fbang-patterns #-}------ The Computer Language Shootout--- http://shootout.alioth.debian.org/------ Contributed by Don Stewart--- 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-import Control.Monad-import Data.Bits-import Text.Printf--main = do- n <- getArgs >>= readIO . head :: IO Int- mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2]--sieve n = do- let r = unsafePerformIO (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 !a !m !n !c- | n == m = return c- | otherwise = do- e <- unsafeRead a n- if e then let loop !j- | j < m = do- x <- unsafeRead a j- when x $ unsafeWrite a j False- loop (j+n)-- | otherwise = go a m (n+1) (c+1)- in loop (n `shiftL` 1)- else go a m (n+1) c--
− tests/nsieve-bits-u.hs
@@ -1,41 +0,0 @@-{-# OPTIONS -O2 -optc-O -fbang-patterns #-}------ The Computer Language Shootout--- http://shootout.alioth.debian.org/------ Contributed by Don Stewart--- nsieve over an ST monad Bool array-----import Control.Monad.ST-import Data.Array.ST-import Data.Array.Base-import System-import Control.Monad-import Data.Bits-import Text.Printf--main = do- n <- getArgs >>= readIO . head :: IO Int- mapM_ (sieve . (10000 *) . (2 ^)) [n, n-1, n-2]--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 !a !m !n !c- | n == m = return c- | otherwise = do- e <- unsafeRead a n- if e then let loop !j- | j < m = do- x <- unsafeRead a j- when x $ unsafeWrite a j False- loop (j+n)-- | otherwise = go a m (n+1) (c+1)- in loop (n `shiftL` 1)- else go a m (n+1) c--
− tests/runtests.sh
@@ -1,35 +0,0 @@-#!/bin/sh--compile () {- ghc --make -O2 $1 -o $2-}--time_run () {- arg=$1- shift- for e in $* ; do- time ./$e $arg > $e.out- done- diffn $*-}--diffn () {- ref=$1- ret=0- shift- for f in $* ; do- diff $ref.out $f.out- ret=$(( $ret + $?))- done- 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
− tests/tests.hs
@@ -1,132 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, NoMonomorphismRestriction #-}-import Control.Arrow-import Test.QuickCheck-import Text.Show.Functions-import Data.Array.CArray-import Data.Array.CArray.Base (shapeToStride)-import Data.Array.Unboxed-import Data.List-import Foreign.Storable-import Text.Printf-import System.Environment (getArgs)-import System.IO-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)--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- model = (model . bounds &&& map model . elems)-instance (Model i i', Model e e', Ix i', IArray a e') => Model ((i,i),[e]) (a i' e') where- model = uncurry listArray . (model *** map model)-instance (Ix i, Ix i', Model i i', Model e e', Storable e, IArray UArray e')- => Model (CArray i e) (UArray i' e') where- model = uncurry listArray . (model . bounds &&& map model . elems)-instance (Ix i, Ix i', Model i i', Model e e', Storable e', IArray UArray e)- => Model (UArray i e) (CArray i' e') where- model = uncurry listArray . (model . bounds &&& map model . elems)---- Types are trivially modeled by themselves-instance Model Bool Bool where model = id-instance Model Int Int where model = id-instance Model Float Float where model = id-instance Model Double Double where model = id-instance (Model a a', Model b b') => Model (a,b) (a',b') where- model (a,b) = (model a, model b)-instance (Model a a', Model b b', Model c c') => Model (a,b,c) (a',b',c') where- model (a,b,c) = (model a, model b, model c)-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)-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 a = ixmap ((swap *** swap) (bounds a)) swap a- where swap = (\(i,j) -> (j,i))--prop_flatten_flatten = flatten . flatten === flatten-prop_reshape_flatten a = reshape (0, size a - 1) a == flatten a-prop_rank = length . shape === rank-prop_shape_size = product . shape === size-prop_size = size === rangeSize . bounds-prop_shape_stride_last = last . shapeToStride . shape === const 1-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)- ]--prop_amap = (amap :: (Int -> Double) -> CArray Int Int -> CArray Int Double)- =||= (amap :: (Int -> Double) -> UArray Int Int -> UArray Int Double)--prop_slice_all :: (Int -> Double) -> CArray (Int,Int) Int -> Property-prop_slice_all f a = size a > 0 ==> sliceWith (bounds a) (bounds a) f a == amap f a-prop_ixmapWithInd_amap :: (Int -> Double) -> CArray (Int,Int) Int -> Property-prop_ixmapWithInd_amap f a = size a > 0 ==> ixmapWithInd (bounds a) id (\_ e _ -> f e) a == amap f a--type Acc = Int-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--prop_composeAssoc f g h = (f . g) . h === f . (g . h)- where types = [f,g,h] :: [CArray Int Int -> CArray Int Int]--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- mapM_ mycheck ca_tests- mapM_ mycheck [ ("amap" , prop_amap) ]- mapM_ mycheck [ ("accum" , prop_accum) ]- mapM_ mycheck [ ("composeAssoc", prop_composeAssoc) ]- mapM_ mycheck [ ("slice all" , prop_slice_all)- , ("ixmapWithInd amap" , prop_ixmapWithInd_amap) ]---- arb n k = generate n (mkStdGen k) arbitrary