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