carray 0.1.5 → 0.1.5.1
raw patch · 9 files changed
+848/−2 lines, 9 filesdep ~arraydep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: array, base
API changes (from Hackage documentation)
Files
- Data/Array/CArray/Base.hs +2/−1
- carray.cabal +9/−1
- tests/meteor-contest-c.hs +269/−0
- tests/meteor-contest-u.hs +269/−0
- tests/nsieve-bits-c.hs +44/−0
- tests/nsieve-bits-s.hs +44/−0
- tests/nsieve-bits-u.hs +43/−0
- tests/runtests.sh +35/−0
- tests/tests.hs +133/−0
Data/Array/CArray/Base.hs view
@@ -41,9 +41,10 @@ import Control.Applicative import Control.Monad+import Data.Ix import Data.Ix.Shapable import Data.Array.Base-import Data.Array.MArray+import Data.Array.MArray () import Data.Array.IArray () import qualified Data.ByteString.Internal as S import Data.Binary
carray.cabal view
@@ -1,5 +1,5 @@ name: carray-version: 0.1.5+version: 0.1.5.1 synopsis: A C-compatible array library. description: A C-compatible array library.@@ -16,6 +16,14 @@ stability: experimental cabal-version: >=1.2 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 flag splitBase description: array was in base < 3
+ tests/meteor-contest-c.hs view
@@ -0,0 +1,269 @@+{-# OPTIONS -O2 -optc-O3 #-}+{-# LANGUAGE BangPatterns#-}++-- 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 = Main.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 view
@@ -0,0 +1,269 @@+{-# OPTIONS -O2 -optc-O3 #-}+{-# LANGUAGE BangPatterns#-}++-- 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 = Main.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 view
@@ -0,0 +1,44 @@+{-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE BangPatterns#-}++--+-- 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 view
@@ -0,0 +1,44 @@+{-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE BangPatterns#-}++--+-- 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 view
@@ -0,0 +1,43 @@+{-# OPTIONS -O2 -optc-O #-}+{-# LANGUAGE BangPatterns#-}++--+-- 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 view
@@ -0,0 +1,35 @@+#!/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 view
@@ -0,0 +1,133 @@+{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, NoMonomorphismRestriction, UndecidableInstances #-}+import Control.Arrow+import Test.QuickCheck+import Text.Show.Functions+import Data.Array.CArray+import Data.Ix.Shapable (shapeToStride)+import Data.Array.Unboxed+import Data.Binary+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