Add the reverse-complement shootout benchmark
[nofib.git] / shootout / reverse-complement / Main.hs
1 {-
2 The Computer Language Benchmarks Game
3 http://benchmarksgame.alioth.debian.org/
4
5 contributed by Louis Wasserman
6 -}
7
8 import Control.Monad
9 import Foreign
10 import Data.ByteString.Internal
11 import System.IO
12
13 data Buf = Buf !Int !Int !(Ptr Word8)
14
15 withBuf run = run . Buf 0 ini =<< mallocBytes ini
16 where ini = 1024
17
18 newSize len sz
19 | len <= sz = sz
20 | otherwise = newSize len (2 * sz)
21
22 {-# INLINE putBuf #-}
23 putBuf pS lS (Buf lD szD pD) run
24 | lD' > szD = do
25 let szD' = newSize lD' szD
26 pD' <- reallocBytes pD szD'
27 copyArray (pD' +* lD) pS lS
28 run (Buf lD' szD' pD')
29 | otherwise = do
30 copyArray (pD +* lD) pS lS
31 run (Buf lD' szD pD)
32 where lD' = lD + lS
33
34 findChar p n c zero one = do
35 q <- memchr p c (fromIntegral (n :: Int))
36 if q == nullPtr then zero else one $! q `minusPtr` p
37
38 clearBuf (Buf _ lB pB) = Buf 0 lB pB
39
40 main = allocaArray 82 $ \ line ->
41 let go !buf = do
42 !m <- hGetBuf stdin line 82
43 if m == 0 then revcomp buf else do
44 findChar line m (c2w '>')
45 (putBuf line m buf go)
46 (\ end -> do
47 putBuf line end buf revcomp
48 putBuf (line +* end) (m - end) (clearBuf buf)
49 go)
50 in withBuf go
51
52 (+*) = advancePtr
53
54 {-# INLINE comps #-}
55 comps = Prelude.zipWith (\ a b -> (fromEnum a, c2w b)) "AaCcGgTtUuMmRrYyKkVvHhDdBb"
56 "TTGGCCAAAAKKYYRRMMBBDDHHVV"
57
58 ca :: Ptr Word8
59 ca = inlinePerformIO $ do
60 !a <- mallocArray 200
61 mapM_ (\ i -> pokeByteOff a (fromIntegral i) i ) [0..199::Word8]
62 mapM_ (uncurry (pokeByteOff a)) comps
63 return a
64
65 revcomp (Buf lBuf _ pBuf) = when (lBuf > 0) $ ca `seq`
66 findChar pBuf lBuf (c2w '\n') undefined $ \ begin -> let
67 begin' = begin + 1
68 rc :: Ptr Word8 -> Ptr Word8 -> IO ()
69 rc !i !j | i < j = do
70 x <- peek i
71 if x == c2w '\n' then let !i' = i +* 1 in rc1 j i' =<< peek i'
72 else rc1 j i x
73 rc i j = when (i == j) (poke i =<< comp =<< peek i)
74
75 rc1 !j !i !xi = do
76 y <- peek j
77 if y == c2w '\n' then let !j' = j +* (-1) in rc2 i xi j' =<< peek j'
78 else rc2 i xi j y
79
80 comp = peekElemOff ca . fromIntegral
81
82 rc2 !i !xi !j !xj = do
83 poke j =<< comp xi
84 poke i =<< comp xj
85 rc (i +* 1) (j +* (-1))
86 in do
87 hPutBuf stdout pBuf begin'
88 rc (pBuf +* begin') (pBuf +* (lBuf - 1))
89 hPutBuf stdout (pBuf +* begin') (lBuf - begin - 1)