diff --git a/Data/Array/CArray/Base.hs b/Data/Array/CArray/Base.hs --- a/Data/Array/CArray/Base.hs +++ b/Data/Array/CArray/Base.hs @@ -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. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 diff --git a/carray.cabal b/carray.cabal --- a/carray.cabal +++ b/carray.cabal @@ -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. diff --git a/tests/meteor-contest-c.hs b/tests/meteor-contest-c.hs deleted file mode 100644 --- a/tests/meteor-contest-c.hs +++ /dev/null @@ -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 diff --git a/tests/meteor-contest-u.hs b/tests/meteor-contest-u.hs deleted file mode 100644 --- a/tests/meteor-contest-u.hs +++ /dev/null @@ -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 diff --git a/tests/nsieve-bits-c.hs b/tests/nsieve-bits-c.hs deleted file mode 100644 --- a/tests/nsieve-bits-c.hs +++ /dev/null @@ -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 - - diff --git a/tests/nsieve-bits-s.hs b/tests/nsieve-bits-s.hs deleted file mode 100644 --- a/tests/nsieve-bits-s.hs +++ /dev/null @@ -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 - - diff --git a/tests/nsieve-bits-u.hs b/tests/nsieve-bits-u.hs deleted file mode 100644 --- a/tests/nsieve-bits-u.hs +++ /dev/null @@ -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 - - diff --git a/tests/runtests.sh b/tests/runtests.sh deleted file mode 100644 --- a/tests/runtests.sh +++ /dev/null @@ -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 diff --git a/tests/tests.hs b/tests/tests.hs deleted file mode 100644 --- a/tests/tests.hs +++ /dev/null @@ -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