{-# OPTIONS -funbox-strict-fields -fbang-patterns #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- Contributed by Don Stewart, Chris Kuklewicz and Alson Kemp.
-- Updated for ByteString by Chris Kuklewicz February, 2007
--
-- Compile with: -O2 -package parsec
--
-- An idiomatic Haskell entry using lazy regex combinators, described in the paper:
--
--  Manuel  M. T. Chakravarty, Lazy Lexing is Fast.
--  In A. Middeldorp and T. Sato, editors, Proceedings of Fourth Fuji
--  International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.
 
import Monad
 
import Data.Array (Array, assocs, accumArray,bounds,listArray)
import Data.Array.Base (unsafeAt)
 
import Data.ByteString.Base
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Char8  as BC
 
import Word
import List hiding (delete)
import qualified Data.Map as M
import System
import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec ((<|>),(<?>),pzero)
 
------------------------------------------------------------------------
 
main = putStr . work =<< B.getContents
 
work !fileIn = unlines $ counts ++ [[],l0, l1, l2]
  where
    l0     = show $ B.length fileIn
    clean  = B.concat . delete "\n|>[^\n]+\n" $ fileIn
    l1     = show $ B.length clean
    counts = [ re++" "++show (count re clean) | re <- variants ]
    l2     = show $ L.length (iubsExpand clean)
 
iubsExpand = L.fromChunks . foldr1 (.) (map replace iubs) . return
 
variants = [    "agggtaaa|tttaccct"    ,"[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
           ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
           ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
iubs = map (\(s,new) -> (regex s,BC.pack new)) $
  [("B","(c|g|t)"),("D","(a|g|t)"),("H","(a|c|t)"),("K","(g|t)") ,("M","(a|c)")
  ,("N","(a|c|g|t)"),("R","(a|g)") ,("S","(c|g)"),("V","(a|c|g)"),("W","(a|t)") ,("Y","(c|t)")]
 
-- And that's it!
 
------------------------------------------------------------------------
 
-- external interface to regular expressions
 
regex = (either (error.show) accept) . (\x -> P.parse p_regex x x)
  where accept re = re (Lexer True Done) -- Close a regular expression into a Lexer.
 
(!) !a b = unsafeAt a (fromEnum $ (b - fst (bounds a)))
 
delete s = del where
  r = regex s
  del b = pieces 0 (run r b 0) where
    pieces end [] = unsafeDrop end b : []
    pieces !end ((start,stop):rest) = unsafeTake (start-end) (unsafeDrop end b) : pieces stop rest
 
count s b = runOverlappingCount r b 0
  where r = regex s
 
replace (r,new) = rep where
  rep [] = []
  rep (!b:bs) = pieces 0 (run r b 0) where
    pieces 0 []   = b : rep bs
    pieces end [] | B.length b > end = unsafeDrop end b : rep bs
                  | otherwise        = rep bs
 
    pieces end ((start,stop):rest)
        | start > end = unsafeTake (start-end) (unsafeDrop end b) : new : pieces stop rest
        | otherwise = new : pieces stop rest
 
run :: Lexer -> B.ByteString -> Int -> [(Int,Int)]
run lexerIn !b offsetIn = loop offsetIn
  where
    end = B.length b
    loop offset | offset == end = []
                | otherwise =
      let t@(start,stop) = lexOne b lexerIn offset
      in if start == -1 then  []
           else t : loop stop
 
runOverlappingCount :: Lexer -> B.ByteString -> Int -> Int
runOverlappingCount lexerIn !b offsetIn = loop offsetIn 0
  where
    end = B.length b
    loop !offset !c | offset == end = c
                    | otherwise =
      let start = fst $ lexOne b lexerIn offset
      in if start == -1 then c
           else loop (succ start) (succ c)
 
--
-- Construct a regex combinator from a string regex (use Parsec)
-- Designed to follow "man re_format" (Mac OS X 10.4.4)
--
-- The regular expressions accepted by the program include those using
-- |, empty group (), grouping with ( and ), wildcard '.', backslach
-- escaped characters "\.", greedy modifiers ? + and *, bracketed
-- alternatives including ranges such as [a-z0-9] and inverted
-- brackets such as [^]\n-].  Only 7-bit Ascii accepted.
 
-- 'p_regex' is the only "exported" function, used by 'regex' above
 
p_regex = liftM (foldr1 (>|<)) (P.sepBy1 p_branch (P.char '|'))
 
p_branch = liftM (($ epsilon).(foldr (.) id)) (P.many1 (p_atom >>= p_post_atom))
 
p_atom = P.try (P.string "()" >> return epsilon)
     <|> P.between (P.char '(') (P.char ')') p_regex
     <|> p_bracket <|> p_dot <|> p_escaped_char <|> p_other_char
     <|> (pzero <?> "cannot parse regexp atom")
 
p_post_atom atom = (P.char '?' >> return (atom `quest`))
               <|> (P.char '+' >> return (atom `plus`))
               <|> (P.char '*' >> return (atom `star`))
               <|> (return (atom +>))
 
p_bracket = (P.char '[') >> ( (P.char '^' >> p_set True) <|> (p_set False) )
 
p_set invert = do initial <- (P.option "" ((P.char ']' >> return "]") <|> (P.char '-' >> return "-")))
                  middle <- P.manyTill P.anyChar (P.char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-'  = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)) )
                  return $ if invert then alt ( ['\0'..'\127'] \\ characters )
                                     else alt characters
 
p_dot = P.char '.' >> return (alt ['\0'..'\127'])
 
p_escaped_char = P.char '\\' >> liftM char P.anyChar
 
p_other_char = liftM char (P.noneOf specials) where specials = "^.[$()|*+?\\"
 
--
--  And everything else is the modified CTK library.
--
--  Compiler Toolkit: Self-optimizing lexers
--  Author : Manuel M. T. Chakravarty
--
 
-- tree structure used to represent the lexer table
data Lexer = Lexer !Bool !Cont
 
-- represent the continuation of a lexer
            -- on top of the tree, where entries are dense, we use arrays
data Cont = Dense !BoundsNum !(Array Word8 Lexer)
          -- further down, where the valid entries are sparse, we
          -- use association lists, to save memory
          | Sparse !BoundsNum !(M.Map Word8 Lexer)
          -- end of a automaton
          | Done
 
type Regexp = Lexer -> Lexer
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>
 
-- Empty lexeme (noop)
epsilon = id :: Regexp
 
-- One character regexp
char c = (\l -> Lexer False (Dense (B 1 w w) (listArray (w,w) [l])))
  where w = c2w c
 
-- accepts a non-empty set of alternative characters
-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length ws) (minimum ws) (maximum ws)
                in Lexer False (aggregate bnds [(w, l) | w <- ws])
  where ws = map c2w cs
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- Concatenation of regexps is just concatenation of functions
(+>)  = (.) :: Regexp -> Regexp -> Regexp
 
-- disjunctive combination of two regexps, corresponding to x|y
re1 >|< re2  = \l -> re1 l >||< re2 l
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `star` y corresponds to the regular expression x*y
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- Scan forwards searching for a match anywhere at or after
-- startOffset.  Return offsets of first matching character and after
-- last matching character or (-1,-1) for failure
lexOne !b lexerIn !startOffset =
    let stop = oneLexeme lexerIn startOffset (-1)
    in if stop == -1
             then if startOffset < end
                    then lexOne b lexerIn (succ startOffset)
                    else (-1,-1)
             else (startOffset,stop)
  where
    end = B.length b
    oneLexeme (Lexer win cont) !offset !last =
      let last' = if win then offset else last
      in if offset == end
           then last' -- at end, has to be this action
           else oneChar cont (unsafeIndex b offset) (succ offset) last'   -- keep looking
 
    oneChar tbl !c !offset' !last = case peek tbl c of
      (Lexer win Done)   -> if win then offset' else last
      l'                 -> oneLexeme l' offset' last
 
    peek (Dense bn arr)  !c | c `inBounds` bn = arr ! c
    peek (Sparse bn cls) !c | c `inBounds` bn = M.findWithDefault (Lexer False Done) c cls
    peek _ _ = (Lexer False Done)
 
-- disjunctive combination of two lexers (longest match, right biased)
(Lexer win c) >||< (Lexer win' c')  = Lexer (win || win') (joinConts c c')
 
-- represents the number of (non-error) elements and the bounds of a
-- DFA transition table
data BoundsNum = B !Int !Word8 !Word8
 
-- combine two bounds
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- combine two disjunctive continuations
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, M.toList cls)
 
-- we use the dense representation if a table has at least the given
-- number of (non-error) elements
denseMin  = 1 :: Int
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer False Done) (lc, hc) cls)
  | otherwise     = Sparse bn (M.fromList (accum (>||<) cls))
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')

{-# OPTIONS -funbox-strict-fields -fbang-patterns #-}
--
-- This never uses 'Sparse' but remiving it killed performance -- ghc glitch?
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- http://haskell.org/haskellwiki/Shootout/Regex_DNA
-- Contributed by Don Stewart, Chris Kuklewicz and Alson Kemp.
-- Updated for ByteString by Chris Kuklewicz February, 2007
--
-- Compile with: -O2 -package parsec
--
-- An idiomatic Haskell entry using lazy regex combinators, described in the paper:
--
--  Manuel  M. T. Chakravarty, Lazy Lexing is Fast.
--  In A. Middeldorp and T. Sato, editors, Proceedings of Fourth Fuji
--  International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.
 
module Main(main) where
 
import Control.Monad (liftM)
import Data.Array (Array, assocs, accumArray,bounds,listArray)
import Data.Array.Base (unsafeAt)
import qualified Data.ByteString as B (ByteString,length,take,drop,index,concat,hGetContents)
import Data.ByteString.Base (c2w)
import qualified Data.ByteString.Char8  as BC (pack)
import qualified Data.ByteString.Lazy as L (length,fromChunks)
import Data.Word (Word8)
import Data.List (sort,nub,(\\))
import qualified Data.Map as M (Map,toList,fromList,findWithDefault)
import System.IO (stdin)
import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec ((<|>),(<?>),pzero)
 
(!) a b = unsafeAt a (fromEnum $ (b - fst (bounds a)))
 
main = do
  wholeFile <- B.hGetContents stdin
  putStr (work wholeFile)
 
work fileIn =
    let l0     = show $ B.length fileIn in l0 `seq`
    let clean  = B.concat . delete "\n|>[^\n]+\n" $ fileIn
        l1     = show $ B.length clean in l1 `seq`
    let counts = [ stringRegex++" "++show (count stringRegex clean) |
                   stringRegex <- variants ]  -- Count the variants one at a time.
        l2     = show $ L.length (iubsExpand clean)
    in unlines $ counts ++ [[],l0, l1, l2]
 
iubsExpand = L.fromChunks
             . foldr1 (.) (map (\snew input -> replace snew input) iubs)
             . (:[])
 
variants = [    "agggtaaa|tttaccct"    ,"[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
           ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
           ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
iubs = map (\(s,new) -> (regex s,BC.pack new)) $
  [("B","(c|g|t)"),("D","(a|g|t)"),("H","(a|c|t)"),("K","(g|t)") ,("M","(a|c)")
  ,("N","(a|c|g|t)"),("R","(a|g)") ,("S","(c|g)"),("V","(a|c|g)"),("W","(a|t)") ,("Y","(c|t)")]
 
-- EXTERNAL INTERFACE TO REGULAR EXPRESSIONS
 
regex = (either (error.show) accept) . (\x -> P.parse p_regex x x)
  where accept re = re (Lexer True Done) -- Close a regular expression into a Lexer.
 
delete s = del where
  r = regex s
  del b = pieces 0 (run r b 0) where
    pieces end [] = B.drop end b : []
    pieces end ((start,stop):rest) = B.take (start-end) (B.drop end b) : pieces stop rest
 
count s b = runOverlappingCount r b 0
  where r = regex s
 
replace (r,new) = rep where
  rep [] = []
  rep (b:bs) = pieces 0 (run r b 0) where
    pieces 0 [] = b : rep bs
    pieces end [] | B.length b > end = B.drop end b : rep bs
                  | otherwise = rep bs
    pieces end ((start,stop):rest) | start > end = B.take (start-end) (B.drop end b) : new : pieces stop rest
                                   | otherwise = new : pieces stop rest
 
run :: Lexer -> B.ByteString -> Int -> [(Int,Int)]
run lexerIn b offsetIn = loop offsetIn
  where
    end = B.length b
    loop offset | offset == end = []
                | otherwise =
      let t@(start,stop) = lexOne b lexerIn offset
      in if start == -1 then  []
           else t : loop stop
 
runOverlappingCount :: Lexer -> B.ByteString -> Int -> Int
runOverlappingCount lexerIn b offsetIn = loop offsetIn 0
  where
    end = B.length b
    loop !offset !c | offset == end = c
                    | otherwise =
      let start = fst $ lexOne b lexerIn offset
      in if start == -1 then c
           else loop (succ start) (succ c)
 
----------------------------------------------------------------
-- Construct a regex combinator from a string regex (use Parsec)
-- Designed to follow "man re_format" (Mac OS X 10.4.4)
--
-- The regular expressions accepted by the program include those using
-- |, empty group (), grouping with ( and ), wildcard '.', backslach
-- escaped characters "\.", greedy modifiers ? + and *, bracketed
-- alternatives including ranges such as [a-z0-9] and inverted
-- brackets such as [^]\n-].  Only 7-bit Ascii accepted.
 
-- 'p_regex' is the only "exported" function, used by 'regex' above
 
p_regex = liftM (foldr1 (>|<)) (P.sepBy1 p_branch (P.char '|'))
 
p_branch = liftM (($ epsilon).(foldr (.) id)) (P.many1 (p_atom >>= p_post_atom))
 
p_atom = P.try (P.string "()" >> return epsilon)
     <|> P.between (P.char '(') (P.char ')') p_regex
     <|> p_bracket <|> p_dot <|> p_escaped_char <|> p_other_char
     <|> (pzero <?> "cannot parse regexp atom")
 
p_post_atom atom = (P.char '?' >> return (atom `quest`))
               <|> (P.char '+' >> return (atom `plus`))
               <|> (P.char '*' >> return (atom `star`))
               <|> (return (atom +>))
 
p_bracket = (P.char '[') >> ( (P.char '^' >> p_set True) <|> (p_set False) )
 
p_set invert = do initial <- (P.option "" ((P.char ']' >> return "]") <|> (P.char '-' >> return "-")))
                  middle <- P.manyTill P.anyChar (P.char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-'  = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)) )
                  return $ if invert then alt ( ['\0'..'\127'] \\ characters )
                                     else alt characters
 
p_dot = P.char '.' >> return (alt ['\0'..'\127'])
 
p_escaped_char = P.char '\\' >> liftM char P.anyChar
 
p_other_char = liftM char (P.noneOf specials) where specials = "^.[$()|*+?\\"
 
------------------------------------------------------------------------
--  And everything else is the midified CTK library.
--
--  Compiler Toolkit: Self-optimizing lexers
--
--  Author : Manuel M. T. Chakravarty
--  Created: 24 February 95, 2 March 99
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--  Copyright (c) 2004-6 Don Stewart
--
--  Self-optimizing lexer combinators.
--
--  For detailed information, see ``Lazy Lexing is Fast'', Manuel
--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
--  Fourth Fuji International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)
--
--             http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
--  Thanks to Simon L. Peyton Jones and Roman Leshchinskiy for their
--  helpful suggestions that improved the design of this library.
 
-- INTERNAL IMPLEMENTATION OF REGULAR EXPRESSIONS
 
-- tree structure used to represent the lexer table
data Lexer = Lexer !Bool !Cont
 
-- represent the continuation of a lexer
            -- on top of the tree, where entries are dense, we use arrays
data Cont = Dense !BoundsNum !(Array Word8 Lexer)
          -- further down, where the valid entries are sparse, we
          -- use association lists, to save memory
          | Sparse !BoundsNum !(M.Map Word8 Lexer)
          -- end of a automaton
          | Done
 
type Regexp = Lexer -> Lexer
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>
 
-- Empty lexeme (noop)
epsilon = id :: Regexp
 
-- One character regexp
char c = (\l -> Lexer False (Dense (B 1 w w) (listArray (w,w) [l])))
  where w = c2w c
 
-- accepts a non-empty set of alternative characters
-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length ws) (minimum ws) (maximum ws)
                in Lexer False (aggregate bnds [(w, l) | w <- ws])
  where ws = map c2w cs
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- Concatenation of regexps is just concatenation of functions
(+>)  = (.) :: Regexp -> Regexp -> Regexp
 
-- disjunctive combination of two regexps, corresponding to x|y
re1 >|< re2  = \l -> re1 l >||< re2 l
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `star` y corresponds to the regular expression x*y
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- Scan forwards searching for a match anywhere at or after
-- startOffset.  Return offsets of first matching character and after
-- last matching character or (-1,-1) for failure
lexOne b lexerIn !startOffset = let stop = oneLexeme lexerIn startOffset (-1)
                                in if stop == -1
                                     then if startOffset < end
                                            then lexOne b lexerIn (succ startOffset)
                                            else (-1,-1)
                                     else (startOffset,stop)
  where
    end = B.length b
    oneLexeme (Lexer win cont) !offset !last =
      let last' = if win then offset else last
      in if offset == end
           then last' -- at end, has to be this action
           else oneChar cont (B.index b offset) (succ offset) last'   -- keep looking
 
    oneChar tbl !c !offset' !last = case peek tbl c of
      (Lexer win Done)   -> if win then offset' else last
      l'                 -> oneLexeme l' offset' last
 
    peek (Dense bn arr)  !c | c `inBounds` bn = arr ! c
    peek (Sparse bn cls) !c | c `inBounds` bn = M.findWithDefault (Lexer False Done) c cls
    peek _ _ = (Lexer False Done)
 
-- disjunctive combination of two lexers (longest match, right biased)
(Lexer win c) >||< (Lexer win' c')  = Lexer (win || win') (joinConts c c')
 
-- represents the number of (non-error) elements and the bounds of a
-- DFA transition table
data BoundsNum = B !Int !Word8 !Word8
 
-- combine two bounds
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- combine two disjunctive continuations
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, M.toList cls)
 
-- we use the dense representation if a table has at least the given
-- number of (non-error) elements
denseMin  = 1 :: Int
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer False Done) (lc, hc) cls)
  | otherwise     = Sparse bn (M.fromList (accum (>||<) cls))
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')

{-# OPTIONS -funbox-strict-fields #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- http://haskell.org/hawiki/ShootoutEntry
-- Contributed by Don Stewart, Chris Kuklewicz and Alson Kemp.
--
-- Compile with: -O2 -package parsec
--
-- An idiomatic Haskell entry using lazy regex combinators, described in the paper:
--
--  Manuel  M. T. Chakravarty, Lazy Lexing is Fast.  
--  In A. Middeldorp and T. Sato, editors, Proceedings of Fourth Fuji
--  International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.
--
-- For more about higher-order combinator-based lexing and parsing in Haskell consult:
--
--  Graham Hutton. Higher-order functions for parsing. (1992)
--  Journal of Functional Programming 2: 232-343. 
--
--  Jeroen Fokker. Functional Parsers. (1995) 
--  Lecture Notes of the Baastad Spring school on Functional Programming.
--
--  Graham Hutton and Erik Meijer. Monadic Parser Combinators. (1996)
--  Technical report NOTTCS-TR-96-4. Department of Computer Science, University of Nottingham.
--
--  Steve Hill. Combinators for parsing expressions. (1996)
--  Journal of Functional Programming 6(3): 445-463. 
--
--  Andrew Partridge and David Wright. 
--  Predictive parser combinators need four values to report errors. (1996)
--  Journal of Functional Programming 6(2): 355-364.
--
--  Doaitse Swierstra and Luc Duponcheel. 
--  Deterministic, Error-Correcting Combinator Parsers. (1996)
--  Advanced Functional Programming. LNCS 1129: 185-207.
--
--  Pieter Koopman and Rinus Plasmeijer. Efficient Combinator Parsers. (1999)
--  Implementation of Functional Languages. Springer Verlag, LNCS 1595: 122-138.
--
--  Doaitse Swierstra and Pablo Azero. 
--  Fast, Error Correcting Parser Combinators: A Short Tutorial. (1999)
--  SOFSEM'99 Theory and Practice of Informatics. LNCS 1725: 111-129.
--
--  Arthur Baars, Andres Loh, and Doaitse Swierstra. Parsing Permutation Phrases. (2001) 
--  Proceedings of the ACM SIGPLAN Haskell Workshop, 171?183.
--
-- And many other sources.
--
import List (sort,nub,(\\))
import Data.Array (Array, (!), assocs, accumArray)
import Control.Monad (liftM)
import qualified Data.Map as M
import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec ((<|>),(<?>),pzero)
 
main = interact $ \stdin ->
    let l0     = show $ length stdin in l0 `seq` 
    let clean  = fst $ run (reDelete "\n|>[^\n]+\n") stdin 0
        l1     = show $ length clean in l1 `seq` 
    let counts = [ stringRegex++" "++(show . snd . snd $ (run (reCount stringRegex) clean 0)) | 
                   stringRegex <- variants ]  -- Count the variants one at a time.
        l2     = show $ length (iubsExpand clean)
    in unlines $ counts ++ [[],l0, l1, l2]
 
-- Substitute certain chars for patterns. The replacements are running one at a time.
iubsExpand = foldl1 (.) (map (\snew input -> concat . fst $ run (reReplace snew) input 0) iubs)
 
variants = [    "agggtaaa|tttaccct"    ,"[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
           ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
           ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
iubs = [("B","(c|g|t)"),("D","(a|g|t)"),("H","(a|c|t)"),("K","(g|t)") ,("M","(a|c)")
 ,("N","(a|c|g|t)"),("R","(a|g)") ,("S","(c|g)"),("V","(a|c|g)"),("W","(a|t)") ,("Y","(c|t)")]
 
----------------------------------------------------------------
-- Construct a regex combinator from a string regex (use Parsec)
-- Designed to follow "man re_format" (Mac OS X 10.4.4)
--
-- regex is the only "exported" function from this section
regex = (either (error.show) id) . (\x -> P.parse p_regex x x)
 
p_regex = liftM (foldr1 (>|<)) (P.sepBy1 p_branch (P.char '|'))
 
p_branch = liftM (($ epsilon).(foldr (.) id)) (P.many1 (p_atom >>= p_post_atom))
 
p_atom = P.try (P.string "()" >> return epsilon)
     <|> P.between (P.char '(') (P.char ')') p_regex
     <|> p_bracket <|> p_dot <|> p_escaped_char <|> p_other_char 
     <|> (pzero <?> "cannot parse regexp atom")
 
p_post_atom atom = (P.char '?' >> return (atom `quest`))
               <|> (P.char '+' >> return (atom `plus`))
               <|> (P.char '*' >> return (atom `star`)) 
               <|> (return (atom +>))
 
p_bracket = (P.char '[') >> ( (P.char '^' >> p_set True) <|> (p_set False) )
 
p_set invert = do initial <- (P.option "" ((P.char ']' >> return "]") <|> (P.char '-' >> return "-")))
                  middle <- P.manyTill P.anyChar (P.char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-'  = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)) )
                  return $ if invert then alt ( ['\0'..'\127'] \\ characters )
                                     else alt characters
 
p_dot = P.char '.' >> return (alt ['\0'..'\127'])
 
p_escaped_char = P.char '\\' >> liftM char P.anyChar
 
p_other_char = liftM char (P.noneOf specials) where specials = "^.[$()|*+?\\"
 
------------------------------------------------------------------------
--  And everything else is the CTK library.
--
--  Compiler Toolkit: Self-optimizing lexers
--
--  Author : Manuel M. T. Chakravarty
--  Created: 24 February 95, 2 March 99
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--  Copyright (c) 2004-6 Don Stewart
--
--  Self-optimizing lexer combinators.
--
--  For detailed information, see ``Lazy Lexing is Fast'', Manuel
--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
--  Fourth Fuji International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)
--
--             http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
--  Thanks to Simon L. Peyton Jones and Roman Leshchinskiy for their
--  helpful suggestions that improved the design of this library.
 
-- EXTERNAL INTERFACE
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>, `action`, `meta`
infixl 2 >|<, >||<
 
reReplace (s,new) = (regex "." `action` Just) >||< (regex s `action` const (Just new))
reDelete s = (regex "." `action` \[c] -> Just c) >||< (regex s `action` const Nothing)
reCount s = regex s `meta1` \_ lexer m -> R Nothing (succ m) lexer
 
-- Empty lexeme (noop)
epsilon = id :: Regexp t
 
-- One character regexp
char c = (\l -> Lexer NoAction (Sparse (B 1 c c) (M.singleton c l))) :: Regexp t
 
-- accepts a non-empty set of alternative characters
-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length cs) (minimum cs) (maximum cs)
                in Lexer NoAction (aggregate bnds [(c, l) | c <- cs])
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- Concatenation of regexps is just concatenation of functions
(+>)  = (.) :: Regexp t -> Regexp t -> Regexp t
 
-- disjunctive combination of two regexps, corresponding to x|y
re1 >|< re2  = \l -> re1 l >||< re2 l
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `star` y corresponds to the regular expression x*y
--
-- The definition used below can be obtained by equational reasoning from this
-- one (which is much easier to understand): 
--
--   star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2
--
-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),
-- whereas below it is of type `Lexer s t'.  Thus, below we have a graphical
-- body (finite representation of an infinite structure), which doesn't grow
-- with the size of the accepted lexeme - in contrast to the definition using
-- the functional recursion.
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- Close a regular expression into a Lexer with an action that
-- converts the lexeme into a token.  action and meta advance by the
-- length of the lexeme while action1 and meta1 advance a single
-- character.
action re a  = re `meta` a' where a' lexeme lexer s = R (a lexeme) s lexer
{-# INLINE action #-}
action1 re a  = re `meta1` a' where a' lexeme lexer s = R (a lexeme) s lexer
{-# INLINE action1 #-}
meta re a  = re (Lexer (Action a) Done)
{-# INLINE meta #-}
meta1 re a  = re (Lexer (Action1 a) Done)
{-# INLINE meta1 #-}
 
-- disjunctive combination of two lexers (longest match, right biased)
(Lexer a c) >||< (Lexer a' c')  = Lexer (joinActions a a') (joinConts c c')
 
-- Take a Lexer, input string, and initial state
-- Returns ([token],(remaining input,final state))
run _ [] state = ([], ([],state))
run l csIn state = case lexOne l csIn state of
  (Nothing , _ , cs', state') -> run l cs' state'
  (Just t  , l', cs', state') -> let (ts, final) = run l' cs' state'; ts' = (t:ts)
                                 in ts' `seq` (ts',final)
  where
    -- accept a single lexeme
    lexOne l0 cs0 state0 = oneLexeme l0 cs0 state0 id lexErr
 
      where
        lexErr = (Just undefined, l, tail cs0, state0)
 
        -- we implement the "principle of the longest match" by taking
        -- a potential result quad down (in the last argument); the
        -- potential result quad is updated whenever we pass by an
        -- action (different from `NoAction'); initially it is lexErr
        oneLexeme (Lexer a cont) cs state csDL last =
          let last' = case a of NoAction -> last; _ -> doaction a (csDL []) cs state last
          in case cs of
               []      -> last'    -- at end, has to be this action
               (c:cs') -> last' `seq` oneChar cont c cs' state csDL last'   -- keep looking
 
        -- There are more chars. Look at the next one. Now, if the
        -- next tbl is Done, then there is no next transition, so
        -- immediately execute the matching action.
        oneChar tbl c cs state csDL last = case peek tbl c of
          (Lexer action Done)   -> doaction action (csDL [c]) cs state last
          l'                    -> oneLexeme l' cs state (csDL . (c:)) last
 
        -- Do the lookup of the current character in the DFA transition table.
        peek (Dense bn arr)  c | c `inBounds` bn = arr ! c
        peek (Sparse bn cls) c | c `inBounds` bn = M.findWithDefault (Lexer NoAction Done) c cls
        peek _ _ = (Lexer NoAction Done)
 
        -- execute the action if present and finalise the current lexeme
        doaction (Action f) csDL cs state _ =  case f (csDL) l0 state of
          (R Nothing s' l') | not . null $ cs -> s' `seq` lexOne l' cs s'
          (R res     s' l')                   -> s' `seq` (res, l', cs, s')
        doaction (Action1 f) csDL cs state _ = case f (csDL) l0 state of
          (R Nothing s' l') | not . null $ cs -> s' `seq` lexOne l' (tail csIn) s'
          (R res     s' l')                   -> s' `seq` (res, l', (tail csIn), s')
        doaction NoAction _ _ _ last = last
 
-- INTERNAL IMPLEMENTATION
 
-- represents the number of (non-error) elements and the bounds of a
-- DFA transition table
data BoundsNum = B !Int !Char !Char
 
-- we use the dense representation if a table has at least the given
-- number of (non-error) elements
denseMin  = 20 :: Int
 
-- combine two bounds
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- Lexical actions take a lexeme with its position and may return a
-- token; in a variant, an error can be returned
--
-- * if there is no token returned, the current lexeme is discarded
--   lexing continues looking for a token
type Action t = String -> Lexer t -> Maybe t
 
-- Meta actions transform the lexeme, the old lexer, and a
-- user-defined state; they may return the old or a new lexer, which
-- is then used for accepting the next token (this is important to
-- implement non-regular behaviour like nested comments)
type Meta t = String -> Lexer t -> S -> Result t
 
data Result t = R (Maybe t) !S !(Lexer t)
 
-- threaded top-down during lexing (with current input)
type S = Int
 
-- tree structure used to represent the lexer table
--
-- * each node in the tree corresponds to a state of the lexer; the
--   associated actions are those that apply when the corresponding
--   state is reached
data Lexer t = Lexer (LexAction t) (Cont t)
 
-- represent the continuation of a lexer
            -- on top of the tree, where entries are dense, we use arrays
data Cont t = Dense BoundsNum (Array Char (Lexer t))
            -- further down, where the valid entries are sparse, we
            -- use association lists, to save memory
            | Sparse BoundsNum (M.Map Char (Lexer t))
            -- end of a automaton
            | Done
 
-- lexical action
data LexAction t = Action !(Meta t) | Action1 !(Meta t) | NoAction  -- need new LexAction for advance by 1
 
-- a regular expression
type Regexp t = Lexer t -> Lexer t
 
-- combine two disjunctive continuations
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct 
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, M.toList cls)
 
-- combine two actions. Use the latter in case of overlap (right biased!)
joinActions NoAction a'       = a'
joinActions a        NoAction = a
joinActions _        a'       = a' -- error "Lexers.>||<: Overlapping actions!"
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer NoAction Done) (lc, hc) cls)
  | otherwise     = Sparse bn (M.fromList (accum (>||<) cls))
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')

THIS HAS BEEN WITHDRAWN
 
The parser it created was "possessive" where it should have been "greedy"
 
The offending code was
 
type T s = CharParser s ()
type CT s = CharParser () (T s)
 
p_post_atom :: T s -> CT s
p_post_atom atom = (char '?' >> return (optional atom))
               <|> (char '+' >> return (skipMany1 atom))
               <|> (char '*' >> return (skipMany atom))
               <|> return atom

-- February 25th, 2006
 
type T s = CharParser s ()
type TT s = T s -> T s
type CTT s = CharParser () (TT s)
 
p_post_atom :: TT s -> CTT s
p_post_atom atom = (char '?' >> return (\cont -> try (atom cont) <|> cont))
               <|> (char '+' >> return (atom . star atom))
               <|> (char '*' >> return (star atom))
               <|> return atom
  where star :: TT s -> T s -> T s
        star x cont = fix (\this -> try (x this) <|> cont)

-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- For the regex-dna benchmark
--
-- http://haskell.org/hawiki/ShootoutEntry
--
-- March 3rd, 2006
-- 
-- Pure parsec solution
-- by Chris Kuklewicz and Don Stewart
--
-- This satisfies the new stringent specification
--
import Control.Monad.Fix (fix)
import Control.Monad (liftM,liftM2,msum,sequence)
import Data.Either (either)
import Data.List -- (intersperse,nub,sort,foldl')
import Text.ParserCombinators.Parsec
import Debug.Trace
 
main = interact $ \input ->
  let length1 = show $ length input in length1 `seq`
  let clean = reRemove ">[^\n]*\n|\n" input
      length2 = show $ length clean in length2 `seq`
  let table = map (\regexp -> regexp ++ (' ':show (reCount regexp clean))) variants
   -- length3 = show $ length (super clean)
   -- The foldl' below is more orthodox, but slower
      length3 = show $ length $ foldl' reReplace3 clean iubs
  in unlines $ table ++ ["",length1,length2,length3]
 
variants = ["agggtaaa|tttaccct","[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
  ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
  ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
iubs = map (\ (c,new) -> (parseRegexp c, c, new) ) $
  [("B","(c|g|t)"),("D","(a|g|t)"),("H","(a|c|t)"),("K","(g|t)"),("M","(a|c)")
  ,("N","(a|c|g|t)"),("R","(a|g)"),("S","(c|g)"),("V","(a|c|g)"),("W","(a|t)"),("Y","(c|t)")]
 
-- clean is a bit more clever, searching for each replacement in turn.
-- Each reReplaceMap takes a continuation to use for input that does
-- not match, each continuation leads to the next reReplaceMap (ending
-- in 'id' ).  This is not searching in parallel!
super = foldr1 (.) (map reReplaceMap iubs) id
 
-- Regexp INTERFACE
 
-- Replace each match of regexp with new in the input, processing everything before returning
-- (Used to clean in the input string)
reReplace regexp new input = 
  let regexp' = parseRegexp regexp
      parser = sepBy (many (notFollowedBy (try (regexp' >> return '\0')) >> anyChar)) regexp'
      result = either (error.show) id (parse parser regexp input)
  in concat $ intersperse new result
 
-- Replace each match of regexp with new in the input, returning the matching or non-matching blocks lazily
-- (Currently unused)
reReplace1 regexp new s =
  let regexp' = parseRegexp regexp
      parser = do value <- (try regexp' >> return new) 
                           <|> do c <- anyChar
                                  cs <- many (notFollowedBy (try (regexp' >> return '\0')) >> anyChar)
                                  return (c:cs)
                  rest <- getInput
                  return (value,rest)
      helper "" = ""
      helper input = let (this,next) = either (error.show) id (parse parser regexp input)
                     in this ++ helper next
  in helper s
 
takeAppend :: String -> Int -> String -> String
takeAppend s n e = loop s n
  where loop _ 0 = e
        loop (x:xs) n = x : loop xs (pred n)
{-# INLINE takeAppend #-}
 
takeS :: String -> Int -> ShowS -> ShowS
takeS s n e x = loop s n -- trace ("\n>"++show n++"<\n") loop s n
  where loop _ 0 = e x
        loop (x:xs) n = x : loop xs (pred n)
 
reReplace2 regexp new s =
  let newS = shows new
      regexp' = parseRegexp regexp
      parser = do start <- getInput
                  let loop n | n `seq` True = (try regexp' >> (return (takeAppend start n new)))
                                              <|> (anyChar >> loop (succ n)) <|> (eof >> return start)
                  liftM2 (,) (loop (0::Int)) getInput
      helper "" = ""
      helper input = let (this,next) = either (error.show) id (parse parser regexp input)
                     in this ++ helper next
  in helper s
 
reRemove regexp s = reReplace3 s (parseRegexp regexp,regexp,"")
 
reReplace3 s (regexp',regexp,new) =
  let newS = (new++)
      parser = do start <- getInput
                  let loop n | n `seq` True = 
                        (try regexp' >> updateState (. (takeS start n newS)) >> parser)
                        <|> (anyChar >> loop (succ n)) <|> (eof >> getState >>= \f -> return (f . (const start)))
                  loop 0
      result = either (error.show) id (runParser parser id regexp s) $ ""
  in result
 
-- Count the number of non-overlapping matches of regexp in the input
-- (Used to count each of the sequences)
reCount regexp input =
  let regexp' = parseRegexp regexp
      parser = (try regexp' >> updateState (+1) >> parser) <|> (anyChar >> parser) <|> (eof >> getState)
  in either (error.show) id (runParser parser (0::Int) regexp input)
 
reCount' regexp input =
  let regexp' = parseRegexp regexp
      parser = (eof >> getState) <|> ( ( (try regexp' >> updateState (+1)) <|> (anyChar >> return ()) ) >> parser )
  in either (error.show) id (runParser parser (0::Int) regexp input)
 
-- When regexp' matches replace it with new otherwise pass the block the non-matching block to cont
-- (Used by clean to replace the IUBS codes)
reReplaceMap (regexp',regexp,new) cont input =
  let parser = do value <- (regexp' >> return new)
                           <|> do c <- anyChar
                                  cs <- many (notFollowedBy (try (regexp' >> return '\0')) >> anyChar)
                                  return (cont (c:cs))
                  rest <- getInput
                  return (value,rest)
 
      helper "" = ""
      helper rest = let (this,next) = either (error.show) id (parse parser regexp rest)
                    in this ++ helper next
  in helper input
 
-- Turn a string regexp into a Parsec parser
type T s = CharParser s ()
type TT s = T s -> T s
type CTT s = CharParser () (TT s)
 
parseRegexp :: String -> T s
parseRegexp = (either (error.show) ($ return ())) . (\x -> parse p_regexp x x)
 
-- Regexp IMPLEMENTATION (exporting p_regexp to Rexexp INTERFACE)
 
p_regexp :: CTT s
p_regexp = do branches <- sepBy1 p_branch (char '|')
              return (\cont -> let branches' = map (\branch -> try (branch cont)) branches
                               in msum branches')
 
p_branch :: CTT s                                   
p_branch = return . (foldr1 (.)) =<< many1 p_piece
 
p_piece :: CTT s
p_piece = p_atom >>= p_post_atom
 
p_atom :: CTT s
p_atom = try (string "()" >> return id) <|> 
         between (char '(') (char ')') p_regexp <|>
         p_bracket <|> p_dot <|> p_escaped_char <|> p_other_char
 
p_post_atom :: TT s -> CTT s
p_post_atom atom = (char '?' >> return (\cont -> try (atom cont) <|> cont))
               <|> (char '+' >> return (atom . star atom))
               <|> (char '*' >> return (star atom))
               <|> return atom
  where star :: TT s -> T s -> T s
        star x cont = fix (\this -> try (x this) <|> cont)
 
p_bracket :: CTT s
p_bracket = char '[' >> ( (char '^' >> p_set True) <|> (p_set False) )
 
p_set :: Bool -> CTT s
p_set invert = do initial <- option "" ((char ']' >> return "]") <|> (char '-' >> return "-"))
                  middle <- manyTill anyChar (char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-' = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)) ) -- can't be empty
                  if invert then use (noneOf characters)
                            else use (oneOf characters)
 
p_dot :: CTT s
p_dot = char '.' >> use anyChar
 
p_escaped_char :: CTT s
p_escaped_char = char '\\' >> anyChar >>= use . char
 
p_other_char :: CTT s
p_other_char = label (noneOf specials) ("none of "++show specials) >>= use . char 
    where specials = "^.[$()|*+?\\"
 
-- use is needed to alter the returned type of character parsers to (TT s)
use :: CharParser s ignore -> CTT s
use x = return (x >>)

{-
  find the maximal number of characters to skip when a regular expression parser
  just failed.
 
  when we know after how many characters a parser failed and where the first
  pattern may appear in a valid pattern, the minimum of these numbers should be
  the number of characters we can skip, if i'm not mistaken.
 
  NOTE: code is not fully tested and substring is not implemented for strings of
  different lengths.
 
  Contributed by: Johannes Ahlmann
-}
import Data.List
import Text.ParserCombinators.Parsec
 
-- split input regular expression into [[Char]] to be later expanded by sequence
-- NOTE: only supports non-negated brackets and "other" chars, yet
p_regexp = sepBy1 p_branch (char '|')
p_bracket = between (char '[') (char ']') (many1 $ noneOf "]")
p_branch  = many1 ((try p_bracket) <|> (noneOf specials >>= return . (:[])))
    where specials = "^.[$()|*+?\\"
 
-- substring function that also returns at what position "a" is contained in "b"
containsAt a b = if length b >= length a then length b else error "not implemented"
 
-- function to determine if and where "a" or one of its prefixes is the postfix of "b"
tailsAt a b = if null tl then lb else lb - (maximum tl)
  where tl = [length y | x <- (drop 1 . inits) a, y <- tails b, x == y]
        lb = length b
allowsSkip a b = min (tailsAt a b) (containsAt a b)
 
-- calculate the minimum number of characters to skip for all expanded variants of a regexp
skipper vars = if null skipLengths then minimum (map length vars) else minimum skipLengths
  where skipLengths = map (uncurry allowsSkip) [(a,b) | a <- vars, b <- vars, a /= b]
 
myparse = either (error.show) id . parse p_regexp ""
expand  = concatMap sequence . myparse
 
-- calculate the number of characters to skip, such that no other pattern could fit into them.
skipLength regexp = skipper $ expand regexp

-- by ChrisKuklewicz
-- Proposed, untested trick to replace msum for p_regexp definition
 
-- Returns the Left Column for failure
--             Right Column for success
sub p = do i <- getInput
           let e = parse p "sub" i
           case e of
             Left pe -> do let c = sourceColumn (errorPos pe)
                           return (Left c)
             Right _ -> do c <- liftM sourceColumn getPosition
                           return (Right c)
 
-- Returns the Left Column for failures (minimum of two failure Columns)
--             Right Column for a success (use first success, left biased)
orSub p1 p2 = do ec1 <- p1
                 case ec1 of
                   Left c1 -> do ec2 <- p2
                                 case ec2 of
                                   Left c2 -> return (Left (min c1 c2))
                                   right -> return right
                   right -> return right
 
msumSub [x] = (sub x)
msumSub xs = foldr1 orSub (map sub xs)

-- Never tested:
 
-- Don't let the parser fail, capture the error column in the return value explicitly
-- Note that x is a parser for exactly one character
use x = return ( (x >> liftM Right getPosition) <|> (liftM Left getPosition) )
 
-- series replaces the (>>) that sequence_ folds into the list with different abort semantics
series [x] = x
series (x:xs) = do ec <- x
                   case ec of
                     Right _ -> series xs
                     left -> return left

-- All I can say is it compiles; it has never been tested
 
-- replace return () for "()" atoms
myUnit = liftM Right getPosition
 
-- Replace optional for '?' modifier
myOptional p = do missed <- liftM Right getPosition
                  ec <- p
                  case ec of 
                    Left _ -> return missed
                    right -> return right
 
-- mySkip is Helper for mySkipMany and mySkipMany1
mySkip prev = do ec <- p
                 case ec of
                   Left _ -> return prev
                   right -> loop right
 
-- Replace skipMany for '*' modifier
mySkipMany p = liftM (mySkip.Right) getPosition
 
-- Replace skipMany1 for '+' modifier
mySkipMany1 p = do ec <- p
                   case ec of
                     right@(Right _) -> mySkip right
                     left -> return left

{- | Regular Expressions with the TCL RE library.
 
  TCL development header have to be installed.
 
  To compile:
    c2hs /usr/include/tcl8.4/tcl-private/generic/regcustom.h T.chs
    ghc -ffi -ltcl8.4 --make T.hs
 
  Contributed by Johannes Ahlmann    
-}
module Main where
import Foreign
import Foreign.C
 
 
 
-- | find the relative start and end of a match. assumes at least one match was found
getMatchExtent re = do
  info <- mallocBytes {#sizeof Tcl_RegExpInfo#} -- little speedup in extracting
  reInfo re info
  start <- {#get Tcl_RegExpInfo.matches->start#} info
  end   <- {#get Tcl_RegExpInfo.matches->end#}   info
  free info
  return (start,end)
 
 
-- | count occurrences of regular expression in string
-- FIXME: maybe use "end" instead of "start+1" for validity (overlapping matches). speedwise it makes no difference.
countOccs re cString n = do 
  m <- reExec nullPtr re cString cString -- real start if different!??
  if m /= 1
    then return n 
    else do
      (start,end) <- getMatchExtent re
      countOccs re (advancePtr cString (fromIntegral $ start + 1)) (n+1)
 
 
---
 
 
rExpressions = ["agggtaaa|tttaccct"   
               ,"[cgt]gggtaaa|tttaccc[acg]" 
               ,"a[act]ggtaaa|tttacc[agt]t"
               ,"ag[act]gtaaa|tttac[agt]ct"
               ,"agg[act]taaa|ttta[agt]cct"
               ,"aggg[acg]aaa|ttt[cgt]ccct"
               ,"agggt[cgt]aa|tt[acg]accct"
               ,"agggta[cgt]a|t[acg]taccct"
               ,"agggtaa[cgt]|[acg]ttaccct" 
               ]
 
 
-- | given a string and a regular expression, count the REs number of occurences
counter s rx = withCString rx (\p -> do 
                  re <- reCompile nullPtr p
                  n  <- countOccs re s 0
                  return (rx, n))
 
main = do
  input  <- getContents
  counts <- withCString input (\s -> mapM (counter s) rExpressions)
  mapM (\(e,c) -> putStrLn (e ++ " " ++ show c)) counts 
 
 
 
reCompile = {#call unsafe Tcl_RegExpCompile as ^ #}
reExec    = {#call unsafe Tcl_RegExpExec    as ^ #}
reInfo    = {#call unsafe Tcl_RegExpGetInfo as ^ #}

{-# OPTIONS -funbox-strict-fields #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- http://haskell.org/hawiki/ShootoutEntry
-- Contributed by Don Stewart, Chris Kuklewicz and Alson Kemp.
--
-- Compile with: -O2 -package parsec
--
-- An idiomatic Haskell entry using lazy regex combinators, described in the paper:
--
--  Manuel  M. T. Chakravarty, Lazy Lexing is Fast.  
--  In A. Middeldorp and T. Sato, editors, Proceedings of Fourth Fuji
--  International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.
--
-- For more about higher-order combinator-based lexing and parsing in Haskell consult:
--
--  Graham Hutton. Higher-order functions for parsing. (1992)
--  Journal of Functional Programming 2: 232-343. 
--
--  Jeroen Fokker. Functional Parsers. (1995) 
--  Lecture Notes of the Baastad Spring school on Functional Programming.
--
--  Graham Hutton and Erik Meijer. Monadic Parser Combinators. (1996)
--  Technical report NOTTCS-TR-96-4. Department of Computer Science, University of Nottingham.
--
--  Steve Hill. Combinators for parsing expressions. (1996)
--  Journal of Functional Programming 6(3): 445-463. 
--
--  Andrew Partridge and David Wright. 
--  Predictive parser combinators need four values to report errors. (1996)
--  Journal of Functional Programming 6(2): 355-364.
--
--  Doaitse Swierstra and Luc Duponcheel. 
--  Deterministic, Error-Correcting Combinator Parsers. (1996)
--  Advanced Functional Programming. LNCS 1129: 185-207.
--
--  Pieter Koopman and Rinus Plasmeijer. Efficient Combinator Parsers. (1999)
--  Implementation of Functional Languages. Springer Verlag, LNCS 1595: 122-138.
--
--  Doaitse Swierstra and Pablo Azero. 
--  Fast, Error Correcting Parser Combinators: A Short Tutorial. (1999)
--  SOFSEM'99 Theory and Practice of Informatics. LNCS 1725: 111-129.
--
--  Arthur Baars, Andres Loh, and Doaitse Swierstra. Parsing Permutation Phrases. (2001) 
--  Proceedings of the ACM SIGPLAN Haskell Workshop, 171?183.
--
-- And many other sources.
--
 
import Prelude hiding   (last)
import List
import Maybe
import Data.Array            (Array, (!), assocs, accumArray)
import qualified Data.Map    as M
import qualified Data.IntMap as I
 
import Control.Monad
import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec ((<|>),GenParser)
 
main = interact $ \s0 ->
    let l0 = length s0 in l0 `seq` 
    let s1       = fst $ run clean (LS s0 I.empty)
        l1       = length s1 in l1 `seq` 
    let (LS _ m) = snd $ run count  (LS s1 I.empty)
        (LS _ n) = snd $ run count' (LS s1 I.empty)
        counts   = map (\(i,p) -> p++" "++show (I.findWithDefault 0 i m)) $ (init variants)
        counts'  = (snd.last) variants++" "++show (I.findWithDefault 0 0 n)
        l2       = length . concat . fst $ run replace  (LS s1 I.empty)
    in unlines $ (counts++[counts']) ++ [[]] ++ map show [l0, l1, l2]
 
-- remove "\n" and lines with ">"
clean = (regex "."            `action` \[c] -> Just c)
   >||< (regex "\n|>[^\n]+\n" `action` const Nothing)
 
-- count all variants, accumulating count in state threaded through regex matcher
count  = foldl1 (>||<) $ [ match (regex s, n) | (n,s) <- variants ]
count' = match (regex ((snd.last) variants), 0) -- obscure issue with overlapping patterns
 
-- each pattern keeps track of its own count, so we can perform a single pass
match (p,i) = p `meta` \_ m -> R Nothing (I.insertWith (+) i 1 m) Nothing
 
variants = zip [0..]
  ["agggtaaa|tttaccct","[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
  ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
  ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
-- substitute certain chars for patterns
replace = (regex "." `action` \c -> Just c)
     >||< foldl1 (>||<) (map (\(c,p) -> regex [c] `action` const (Just p)) pairs)
 
pairs = [('B',"(c|g|t)"),('D',"(a|g|t)"),  ('H',"(a|c|t)"),('K',"(g|t)")
        ,('M',"(a|c)"),  ('N',"(a|c|g|t)"),('R',"(a|g)"),  ('S',"(c|g)")
        ,('V',"(a|c|g)"),('W',"(a|t)"),    ('Y',"(c|t)") ]
 
------------------------------------------------------------------------
--
-- Construct a regex combinator expression from a string regex
--
-- I know, I know, in Haskell we'd just write the combinator expression
-- directly, but people complained that they're not `real' regular
-- expressions. That's clearly wrong in my opinion -- combinators
-- accurately describe and implement regular expressions (they're
-- semantically identical). The syntax is an embedded domain-specific
-- language in Haskell, not an untyped string. Sigh.
--
 
regex = (either (error.show) id) . (\x -> P.parse p_regex x x)
 
p_regex = liftM (foldr1 (>|<)) (P.sepBy1 p_branch (P.char '|'))
 
p_branch = liftM (($ epsilon).(foldr (.) id)) (P.many1 (p_atom >>= p_post_atom))
 
p_atom = P.try (P.string "()" >> return epsilon) -- must not consume '(' yet
     <|> P.between (P.char '(') (P.char ')') p_regex
     <|> p_bracket <|> p_dot <|> p_escaped_char <|> p_other_char
 
p_post_atom atom = (P.char '?' >> return (atom `quest`))
               <|> (P.char '+' >> return (atom `plus`))
               <|> (P.char '*' >> return (atom `star`)) 
               <|> (return (atom +>))
 
p_bracket = (P.char '[') >> ( (P.char '^' >> p_set True) <|> (p_set False) )
 
p_set invert = do initial <- (P.option "" ((P.char ']' >> return "]") <|> (P.char '-' >> return "-")))
                  middle <- P.manyTill P.anyChar (P.char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-'  = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)) )
                  return $ if invert then alt ( ['\0'..'\127'] \\ characters )
                                     else alt characters
 
p_dot = P.char '.' >> return (alt ['\0'..'\127'])
p_escaped_char = P.char '\\' >> liftM char P.anyChar
p_other_char = liftM char (P.noneOf specials) where specials = "^.[$()|*+?\\"
 
------------------------------------------------------------------------
-- And everything else is the CTK library.
 
--  Compiler Toolkit: Self-optimizing lexers
--
--  Author : Manuel M. T. Chakravarty
--  Created: 24 February 95, 2 March 99
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--  Copyright (c) 2004-6 Don Stewart
--
--  Self-optimizing lexer combinators.
--
--  For detailed information, see ``Lazy Lexing is Fast'', Manuel
--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
--  Fourth Fuji International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)
--
--             http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
--  Thanks to Simon L. Peyton Jones and Roman Leshchinskiy for their
--  helpful suggestions that improved the design of this library.
--
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>, `action`, `meta`
infixl 2 >|<, >||<
 
-- we use the dense representation if a table has at least the given number of 
-- (non-error) elements
denseMin :: Int
denseMin  = 20
 
-- represents the number of (non-error) elements and the bounds of a table
data BoundsNum = B !Int !Char !Char
 
-- combine two bounds
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- Lexical actions take a lexeme with its position and may return a token; in
-- a variant, an error can be returned
--
-- * if there is no token returned, the current lexeme is discarded lexing
--   continues looking for a token
type Action t = String -> Maybe t
 
-- Meta actions transform the lexeme, and a user-defined state; they
-- may return a lexer, which is then used for accepting the next token
-- (this is important to implement non-regular behaviour like nested
-- comments)
type Meta t = String -> S -> Result t
 
data Result t = R (Maybe t) !S (Maybe (Lexer t))
 
-- threaded top-down during lexing (current input, meta state)
data LexerState = LS !String !S
 
type S = I.IntMap Int
 
-- tree structure used to represent the lexer table
--
-- * each node in the tree corresponds to a state of the lexer; the associated 
--   actions are those that apply when the corresponding state is reached
data Lexer t = Lexer (LexAction t) (Cont t)
 
-- represent the continuation of a lexer
data Cont t = -- on top of the tree, where entries are dense, we use arrays
                Dense BoundsNum (Array Char (Lexer t))
 
                -- further down, where the valid entries are sparse, we
                -- use association lists, to save memory
              | Sparse BoundsNum (M.Map Char (Lexer t))
 
              | Done -- end of a automaton
 
-- lexical action
data LexAction t = Action !(Meta t) | NoAction
 
-- a regular expression
type Regexp t = Lexer t -> Lexer t
 
-- Empty lexeme
epsilon :: Regexp t
epsilon = id
 
-- One character regexp
char :: Char -> Regexp t
char c = \l -> Lexer NoAction (Sparse (B 1 c c) (M.singleton c l))
 
-- Concatenation of regexps
(+>) :: Regexp t -> Regexp t -> Regexp t
(+>)  = (.)
 
-- Close a regular expression with an action that converts the lexeme into a
-- token
--
-- * Note: After the application of the action, the position is advanced
--         according to the length of the lexeme.  This implies that normal
--         actions should not be used in the case where a lexeme might contain 
--         control characters that imply non-standard changes of the position, 
--         such as newlines or tabs.
--
action re a  = re `meta` a' where a' lexeme s = R (a lexeme) s Nothing
{-# INLINE action #-}
 
-- Close a regular expression with a meta action
--
-- * Note: Meta actions have to advance the position in dependence of the
--         lexeme by themselves.
--
meta re a  = re (Lexer (Action a) Done)
{-# INLINE meta #-}
 
-- disjunctive combination of two regexps
re >|< re'  = \l -> re l >||< re' l
 
-- disjunctive combination of two lexers
(Lexer a c) >||< (Lexer a' c')  = Lexer (joinActions a a') (joinConts c c')
 
-- combine two disjunctive continuations
--
joinConts :: Cont t -> Cont t -> Cont t
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct 
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, M.toList cls)
 
-- combine two actions. Use the latter in case of overlap (!)
joinActions NoAction a'       = a'
joinActions a        NoAction = a
joinActions _        a'       = a' -- error "Lexers.>||<: Overlapping actions!"
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer NoAction Done) (lc, hc) cls)
  | otherwise     = Sparse bn (M.fromList (accum (>||<) cls))
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')
 
-- x `star` y corresponds to the regular expression x*y
--
-- The definition used below can be obtained by equational reasoning from this
-- one (which is much easier to understand): 
--
--   star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2
--
-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),
-- whereas below it is of type `Lexer s t'.  Thus, below we have a graphical
-- body (finite representation of an infinite structure), which doesn't grow
-- with the size of the accepted lexeme - in contrast to the definition using
-- the functional recursion.
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- accepts a non-empty set of alternative characters
--  Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length cs) (minimum cs) (maximum cs)
                in Lexer NoAction (aggregate bnds [(c, l) | c <- cs])
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- apply a lexer, yielding a token sequence and a list of errors
--
-- * Currently, all errors are fatal; thus, the result is undefined in case of 
--   an error (this changes when error correction is added).
-- * The final lexer state is returned.
-- * The order of the error messages is undefined.
-- * the following is moderately tuned
--
run _ st@(LS [] _) = ([], st)
run l st = case lexOne l st of
    (Nothing , _ , st') -> run l st'
    (Just t, l', st')   -> let (ts, final) = run l' st'; ts' = (t:ts)
                           in ts' `seq` (ts',final)
  where
    -- accept a single lexeme
    lexOne l0 st'@(LS cs s) = oneLexeme l0 st' id lexErr
 
      where
        lexErr = (Just undefined, l, (LS (tail cs) s))
 
        -- we take an open list of characters down, where we accumulate the
        -- lexeme; this function returns maybe a token, the next lexer to use
        -- (can be altered by a meta action), the new lexer state, and a list
        -- of errors
        --
        -- we implement the "principle of the longest match" by taking a
        -- potential result quadruple down (in the last argument); the
        -- potential result quadruple is updated whenever we pass by an action 
        -- (different from `NoAction'); initially it is an error result
        --
        oneLexeme (Lexer a cont) state@(LS cs s) csDL last =
            let last' = doaction a csDL state last
            in case cs of
                []      -> last'    -- at end, has to be this action
                (c:cs') -> oneChar cont c (LS cs' s) csDL last'   -- keep looking
 
        -- There are more chars. Look at the next one
        -- Now, if the next tbl is Done, then there is no more
        -- transition, so immediately execute our action
        oneChar tbl c state csDL last = case peek tbl c of
                Nothing              -> last
                Just (Lexer a Done)  -> doaction a (\l -> csDL (c:l)) state last
                Just l'              -> oneLexeme l' state (\l -> csDL (c:l)) last
 
        -- Do the lookup.
        peek (Dense bn arr)  c | c `inBounds` bn = Just $ arr ! c
        peek (Sparse bn cls) c | c `inBounds` bn = M.lookup c cls
        peek _ _    = Nothing
 
        -- execute the action if present and finalise the current lexeme
        doaction (Action f) csDL (LS cs s) _ = case f (($[]) csDL) s of
                (R Nothing s' l') | not . null $ cs -> lexOne (fromMaybe l0 l') (LS cs s')
                (R res     s' l')  -> (res, (fromMaybe l0 l'), (LS cs s'))
 
        doaction NoAction _ _ last = last

{-# OPTIONS -funbox-strict-fields #-}
--
-- The Computer Language Shootout - http://shootout.alioth.debian.org/
-- Haskell Wiki page for Shootout entries - http://haskell.org/hawiki/ShootoutEntry
--
-- Contributed by Don Stewart
-- Haskell RegEx C bindings are slow (see the other GHC entry), so this shows 
-- that Haskell can compete with a purely functional entry based on lazy 
-- regex combinators as detailed in the RegEx section.
 
import Prelude hiding   (last)
import List
import Maybe
import Data.Array            (Array, (!), assocs, accumArray)
import qualified Data.Map    as M
import qualified Data.IntMap as I
 
main = interact $ \s0 ->
    let l0 = length s0 in l0 `seq` 
    let s1       = fst $ run clean (LS s0 I.empty)
        l1       = length s1 in l1 `seq` 
    let (LS _ m) = snd $ run count  (LS s1 I.empty)
        (LS _ n) = snd $ run count' (LS s1 I.empty)
        counts   = map (\(i,p) -> p++" "++show (I.findWithDefault 0 i m)) $ (init variants)
        counts'  = (snd.last) variants++" "++show (I.findWithDefault 0 0 n) -- work around for count'
        l2       = length . concat . fst $ run replace  (LS s1 I.empty)
    in unlines $ (counts++[counts']) ++ [[]] ++ map show [l0, l1, l2]
 
-- remove "\n" and lines with ">"
clean = (dot                                   `action` \[c] -> Just c)
   >||< (char '\n'                             `action` const Nothing)
   >||< (char '>' +> anyButNL `star` char '\n' `action` const Nothing)
 
-- count all variants, accumulating count in state threaded through regex matcher
-- note: count' is a workaround for an obscure problem with overlapping patterns(?)
count = (dot `action` const Nothing)
   >||< (foldl1 (>||<) $ map match (zip pats [0..]))
  where
    pats = [(string "agggtaaa"                            >|<  string "tttaccct")
           ,((alt "cgt" +> string "gggtaaa")              >|< (string "tttaccc" +> alt "acg"))
           ,((char 'a'   +> alt "act" +> string "ggtaaa") >|< (string "tttacc" +> alt "agt" +> t))
           ,((string "ag" +> alt "act" +> string "gtaaa") >|< (string "tttac" +> alt "agt" +> string "ct"))
           ,((string "agg" +> alt "act" +> string "taaa") >|< (string "ttta" +> alt "agt" +> string "cct"))
           ,((string "aggg" +> alt "acg" +> string "aaa") >|< (string "ttt" +> alt "cgt" +> string "ccct"))
           ,((string "agggt" +> alt "cgt" +> string "aa") >|< (string "tt" +> alt "acg" +> string "accct"))
           ,((string "agggta" +> alt "cgt" +> a)          >|< (char 't'   +> alt "acg" +> string "taccct"))]
count' = match (((string "agggtaa" +> alt "cgt") >|< (alt "acg" +> string "ttaccct")),0)
 
-- substitute certain chars for patterns
replace = (alt (['a'..'z'] ++ ['A'..'Z']) `action` \c -> Just c)
     >||< foldl1 (>||<) (map (\(c,p) -> char c `action` const (Just p)) pairs)
 
-- Utility functions and constants
-- each pattern keeps track of its own count, so we can perform a single pass
match (p,i) = p `meta` \_ m -> R Nothing (I.insertWith (+) i 1 m) Nothing
 
dot      = alt   ['\32' .. '\122']  -- defines the "." RegEx of any character
anyButNL = alt $ ['\32' .. '\122'] \\ ['\n'] -- same as "." but excludes newline
variants = zip [0..]
  ["agggtaaa|tttaccct","[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
  ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
  ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
pairs = [('B',"(c|g|t)"),('D',"(a|g|t)"),  ('H',"(a|c|t)"),('K',"(g|t)")
        ,('M',"(a|c)"),  ('N',"(a|c|g|t)"),('R',"(a|g)"),  ('S',"(c|g)")
        ,('V',"(a|c|g)"),('W',"(a|t)"),    ('Y',"(c|t)") ]
 
------------------------------------------------------------------------
-- And now the regex library
------------------------------------------------------------------------
--  Compiler Toolkit: Self-optimizing lexers
--
--  Author : Manuel M. T. Chakravarty
--  Created: 24 February 95, 2 March 99
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--  Copyright (c) 2004-6 Don Stewart
--
--  Self-optimizing lexer combinators.
--
--  For detailed information, see ``Lazy Lexing is Fast'', Manuel
--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
--  Fourth Fuji International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)
--
--             http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
--  Thanks to Simon L. Peyton Jones and Roman Leshchinskiy for their
--  helpful suggestions that improved the design of this library.
--
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>, `action`, `meta`
infixl 2 >|<, >||<
 
-- we use the dense representation if a table has at least the given number of 
-- (non-error) elements
denseMin :: Int
denseMin  = 20
 
-- represents the number of (non-error) elements and the bounds of a table
data BoundsNum = B !Int !Char !Char
 
-- combine two bounds
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- Lexical actions take a lexeme with its position and may return a token; in
-- a variant, an error can be returned
--
-- * if there is no token returned, the current lexeme is discarded lexing
--   continues looking for a token
type Action t = String -> Maybe t
 
-- Meta actions transform the lexeme, and a user-defined state; they
-- may return a lexer, which is then used for accepting the next token
-- (this is important to implement non-regular behaviour like nested
-- comments)
type Meta t = String -> S -> Result t
 
data Result t = R (Maybe t) !S (Maybe (Lexer t))
 
-- threaded top-down during lexing (current input, meta state)
data LexerState = LS !String !S
 
type S = I.IntMap Int
 
-- tree structure used to represent the lexer table
--
-- * each node in the tree corresponds to a state of the lexer; the associated 
--   actions are those that apply when the corresponding state is reached
data Lexer t = Lexer (LexAction t) (Cont t)
 
-- represent the continuation of a lexer
data Cont t = -- on top of the tree, where entries are dense, we use arrays
                Dense BoundsNum (Array Char (Lexer t))
 
                -- further down, where the valid entries are sparse, we
                -- use association lists, to save memory
              | Sparse BoundsNum (M.Map Char (Lexer t))
 
              | Done -- end of a automaton
 
-- lexical action
data LexAction t = Action !(Meta t) | NoAction
 
-- a regular expression
type Regexp t = Lexer t -> Lexer t
 
-- Empty lexeme
epsilon :: Regexp t
epsilon = id
 
-- One character regexp
char :: Char -> Regexp t
char c = \l -> Lexer NoAction (Sparse (B 1 c c) (M.singleton c l))
 
-- Concatenation of regexps
(+>) :: Regexp t -> Regexp t -> Regexp t
(+>)  = (.)
 
-- Close a regular expression with an action that converts the lexeme into a
-- token
--
-- * Note: After the application of the action, the position is advanced
--         according to the length of the lexeme.  This implies that normal
--         actions should not be used in the case where a lexeme might contain 
--         control characters that imply non-standard changes of the position, 
--         such as newlines or tabs.
--
action re a  = re `meta` a' where a' lexeme s = R (a lexeme) s Nothing
{-# INLINE action #-}
 
-- Close a regular expression with a meta action
--
-- * Note: Meta actions have to advance the position in dependence of the
--         lexeme by themselves.
--
meta re a  = re (Lexer (Action a) Done)
{-# INLINE meta #-}
 
-- disjunctive combination of two regexps
re >|< re'  = \l -> re l >||< re' l
 
-- disjunctive combination of two lexers
(Lexer a c) >||< (Lexer a' c')  = Lexer (joinActions a a') (joinConts c c')
 
-- combine two disjunctive continuations
--
joinConts :: Cont t -> Cont t -> Cont t
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct 
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, M.toList cls)
 
-- combine two actions. Use the latter in case of overlap (!)
joinActions NoAction a'       = a'
joinActions a        NoAction = a
joinActions _        a'       = a' -- error "Lexers.>||<: Overlapping actions!"
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer NoAction Done) (lc, hc) cls)
  | otherwise     = Sparse bn (M.fromList (accum (>||<) cls))
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')
 
-- x `star` y corresponds to the regular expression x*y
--
-- The definition used below can be obtained by equational reasoning from this
-- one (which is much easier to understand): 
--
--   star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2
--
-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),
-- whereas below it is of type `Lexer s t'.  Thus, below we have a graphical
-- body (finite representation of an infinite structure), which doesn't grow
-- with the size of the accepted lexeme - in contrast to the definition using
-- the functional recursion.
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- accepts a non-empty set of alternative characters
--  Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length cs) (minimum cs) (maximum cs)
                in Lexer NoAction (aggregate bnds [(c, l) | c <- cs])
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- apply a lexer, yielding a token sequence and a list of errors
--
-- * Currently, all errors are fatal; thus, the result is undefined in case of 
--   an error (this changes when error correction is added).
-- * The final lexer state is returned.
-- * The order of the error messages is undefined.
-- * the following is moderately tuned
--
run _ st@(LS [] _) = ([], st)
run l st = case lexOne l st of
    (Nothing , _ , st') -> run l st'
    (Just t, l', st')   -> let (ts, final) = run l' st'; ts' = (t:ts)
                           in ts' `seq` (ts',final)
  where
    -- accept a single lexeme
    lexOne l0 st'@(LS cs s) = oneLexeme l0 st' id lexErr
 
      where
        lexErr = (Just undefined, l, (LS (tail cs) s))
 
        -- we take an open list of characters down, where we accumulate the
        -- lexeme; this function returns maybe a token, the next lexer to use
        -- (can be altered by a meta action), the new lexer state, and a list
        -- of errors
        --
        -- we implement the "principle of the longest match" by taking a
        -- potential result quadruple down (in the last argument); the
        -- potential result quadruple is updated whenever we pass by an action 
        -- (different from `NoAction'); initially it is an error result
        --
        oneLexeme (Lexer a cont) state@(LS cs s) csDL last =
            let last' = doaction a csDL state last
            in case cs of
                []      -> last'    -- at end, has to be this action
                (c:cs') -> oneChar cont c (LS cs' s) csDL last'   -- keep looking
 
        -- There are more chars. Look at the next one
        -- Now, if the next tbl is Done, then there is no more
        -- transition, so immediately execute our action
        oneChar tbl c state csDL last = case peek tbl c of
                Nothing              -> last
                Just (Lexer a Done)  -> doaction a (\l -> csDL (c:l)) state last
                Just l'              -> oneLexeme l' state (\l -> csDL (c:l)) last
 
        -- Do the lookup.
        peek (Dense bn arr)  c | c `inBounds` bn = Just $ arr ! c
        peek (Sparse bn cls) c | c `inBounds` bn = M.lookup c cls
        peek _ _    = Nothing
 
        -- execute the action if present and finalise the current lexeme
        doaction (Action f) csDL (LS cs s) _ = case f (($[]) csDL) s of
                (R Nothing s' l') | not . null $ cs -> lexOne (fromMaybe l0 l') (LS cs s')
                (R res     s' l')  -> (res, (fromMaybe l0 l'), (LS cs s'))
 
        doaction NoAction _ _ last = last

{-# OPTIONS -funbox-strict-fields #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- http://haskell.org/hawiki/ShootoutEntry
--
-- Contributed by Don Stewart
-- A regex-dna entry based on lazy regex combinators, described in the paper:
--
--  ``Lazy Lexing is Fast'', Manuel  M. T. Chakravarty, in A.
--  Middeldorp and T. Sato, editors, Proceedings of Fourth Fuji
--  International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.
--
 
import Prelude hiding   (last)
import List
import Maybe
import Data.Array            (Array, (!), assocs, accumArray)
import qualified Data.IntMap as I
 
main = getContents >>= putStr . output
 
output s0 = unlines $ counts ++ [[]] ++ map show [length s0, length s1, length s2]
  where s1 = clean False s0
        s2 = replaceIubs s1
        (_,(LS _ m)) = execLexer patterns (LS s1 I.empty) 
        counts = map (\(i,p) -> p++" "++show (I.findWithDefault 0 i m)) $ variants
 
-- match variants
patterns = foldl1 (>||<) $ map (uncurry match) (zip pats [0..])
  where
    pats = [(string "agggtaaa"                      >|< string "tttaccct")
           ,((cgt +> string "gggtaaa")              >|< (string "tttaccc" +> acg))
           ,((a +> act +> string "ggtaaa")          >|< (string "tttacc" +> agt +> t))
           ,((string "ag" +> act +> string "gtaaa") >|< (string "tttac" +> agt +> string "ct"))
           ,((string "agg" +> act +> string "taaa") >|< (string "ttta" +> agt +> string "cct"))
           ,((string "aggg" +> acg +> string "aaa") >|< (string "ttt" +> cgt +> string "ccct"))
           ,((string "agggt" +> cgt +> string "aa") >|< (string "tt" +> acg +> string "accct"))
           ,((string "agggta" +> cgt +> a)          >|< (t +> acg +> string "taccct"))
           ,((string "agggtaa" +> cgt)              >|< (acg +> string "ttaccct"))]
 
    cgt = alt "cgt"; act = alt "act"; acg = alt "acg"; agt = alt "agt"
    a = char 'a'; t = char 't'
 
    -- each pattern keeps track of its own count, so we can perform a single pass
    match p i = p `meta` \_ m -> R Nothing (I.insertWith (+) i 1 m) Nothing
 
variants = zip [0..]
  ["agggtaaa|tttaccct","[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
  ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
  ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
------------------------------------------------------------------------
 
-- remove "\n" and lines with ">"
-- these should be a regex match. I don't think 'haskell pattern match' is legal :)
clean n []            = []
clean _     ('>':cs)  =    clean True  cs
clean _     ('\n':cs) =    clean False cs
clean True  (c:cs)    =    clean True  cs
clean False (c:cs)    = c:(clean False cs)
 
-- replace iubs, should also use regex matching
replaceIubs s = concatMap pairs s
pairs 'B' = "(c|g|t)"
pairs 'D' = "(a|g|t)"
pairs 'H' = "(a|c|t)"
pairs 'K' = "(g|t)"
pairs 'M' = "(a|c)"
pairs 'N' = "(a|c|g|t)"
pairs 'R' = "(a|g)"
pairs 'S' = "(c|g)"
pairs 'V' = "(a|c|g)"
pairs 'W' = "(a|t)"
pairs 'Y' = "(c|t)"
pairs a   = [a]
 
------------------------------------------------------------------------
-- And now the regex library
 
--  Compiler Toolkit: Self-optimizing lexers
--
--  Author : Manuel M. T. Chakravarty
--  Created: 24 February 95, 2 March 99
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--  Copyright (c) 2004-5 Don Stewart
--
--  Self-optimizing lexer combinators.
--
--  For detailed information, see ``Lazy Lexing is Fast'', Manuel
--  M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of
--  Fourth Fuji International Symposium on Functional and Logic Programming,
--  Springer-Verlag, LNCS 1722, 1999.  (See my Web page for details.)
--
--             http://www.cse.unsw.edu.au/~chak/papers/Cha99.html
--
--  Thanks to Simon L. Peyton Jones <simonpj@microsoft.com> and Roman
--  Lechtchinsky <wolfro@cs.tu-berlin.de> for their helpful suggestions that
--  improved the design of this library.
--
 
infixr 4 `quest`, `star`, `plus`
infixl 3 +>, `action`, `meta`
infixl 2 >|<, >||<
 
-- we use the dense representation if a table has at least the given number of 
-- (non-error) elements
--
denseMin :: Int
denseMin  = 20
 
-- represents the number of (non-error) elements and the bounds of a table
--
data BoundsNum = B !Int !Char !Char
 
-- combine two bounds
--
addBoundsNum (B n lc hc) (B n' lc' hc')  = B (n + n') (min lc lc') (max hc hc')
 
-- check whether a character is in the bounds
inBounds c (B _ lc hc) = c >= lc && c <= hc
 
-- Lexical actions take a lexeme with its position and may return a token; in
-- a variant, an error can be returned (EXPORTED)
--
-- * if there is no token returned, the current lexeme is discarded lexing
--   continues looking for a token
--
type Action    t = String -> Maybe t
 
-- Meta actions transform the lexeme, and a user-defined state; they
-- may return a lexer, which is then used for accepting the next token
-- (this is important to implement non-regular behaviour like nested
-- comments) (EXPORTED) 
--
type Meta t = String -> S -> Result t
 
data Result t = R (Maybe t) !S (Maybe (Lexer t))
 
-- threaded top-down during lexing (current input, meta state)
data LexerState = LS !String !S
 
type S = I.IntMap Int
 
-- tree structure used to represent the lexer table (EXPORTED ABSTRACTLY) 
--
-- * each node in the tree corresponds to a state of the lexer; the associated 
--   actions are those that apply when the corresponding state is reached
--
data Lexer t = Lexer (LexAction t) (Cont t)
 
-- represent the continuation of a lexer
--
data Cont t = -- on top of the tree, where entries are dense, we use arrays
                Dense BoundsNum (Array Char (Lexer t))
 
                -- further down, where the valid entries are sparse, we
                -- use association lists, to save memory
              | Sparse BoundsNum [(Char, Lexer t)]
 
                -- end of a automaton
              | Done
 
-- lexical action
data LexAction t = Action !(Meta t) | NoAction
 
-- a regular expression
type Regexp t = Lexer t -> Lexer t
 
-- Empty lexeme
epsilon :: Regexp t
epsilon = id
 
-- One character regexp
char :: Char -> Regexp t
char c = \l -> Lexer NoAction (Sparse (B 1 c c) [(c, l)])
 
-- Concatenation of regexps
(+>) :: Regexp t -> Regexp t -> Regexp t
(+>)  = (.)
 
-- Close a regular expression with an action that converts the lexeme into a
-- token
--
-- * Note: After the application of the action, the position is advanced
--         according to the length of the lexeme.  This implies that normal
--         actions should not be used in the case where a lexeme might contain 
--         control characters that imply non-standard changes of the position, 
--         such as newlines or tabs.
--
action re a  = re `meta` a'
  where a' lexeme s = R (a lexeme) s Nothing
{-# INLINE action #-}
 
-- Close a regular expression with a meta action (EXPORTED)
--
-- * Note: Meta actions have to advance the position in dependence of the
--         lexeme by themselves.
--
meta re a  = re (Lexer (Action a) Done)
{-# INLINE meta #-}
 
-- disjunctive combination of two regexps
re >|< re'  = \l -> re l >||< re' l
 
-- disjunctive combination of two lexers
(Lexer a c) >||< (Lexer a' c')  = Lexer (joinActions a a') (joinConts c c')
 
-- combine two disjunctive continuations
--
joinConts :: Cont t -> Cont t -> Cont t
joinConts Done c'   = c'
joinConts c    Done = c
joinConts c    c'   = let (bn , cls ) = listify c
                          (bn', cls') = listify c'
                      -- note: `addsBoundsNum' can, at this point, only
                      --       approx. the number of *non-overlapping* cases;
                      --       however, the bounds are correct 
                      in aggregate (addBoundsNum bn bn') (cls ++ cls')
  where listify (Dense  n arr) = (n, assocs arr)
        listify (Sparse n cls) = (n, cls)
 
-- combine two actions. Use the latter in case of overlap (!)
joinActions NoAction a'       = a'
joinActions a        NoAction = a
joinActions _        a'       = a' -- error "Lexers.>||<: Overlapping actions!"
 
-- Note: `n' is only an upper bound of the number of non-overlapping cases
aggregate bn@(B n lc hc) cls
  | n >= denseMin = Dense  bn (accumArray (>||<) (Lexer NoAction Done) (lc, hc) cls)
  | otherwise     = Sparse bn (accum (>||<) cls)
 
-- combine the elements in the association list that have the same key
accum _ []           = []
accum f ((c, el):ces) = let (ce, ces') = gather c el ces in ce : accum f ces'
  where gather k e []                             = ((k, e), [])
        gather k e (ke'@(k', e'):kes) | k == k'   = gather k (f e e') kes
                                      | otherwise = let (ke'', kes') = gather k e kes
                                                    in (ke'', ke':kes')
 
-- x `star` y corresponds to the regular expression x*y (EXPORTED)
--
-- The definition used below can be obtained by equational reasoning from this
-- one (which is much easier to understand): 
--
--   star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2
--
-- However, in the above, `self' is of type `Regexp s t' (ie, a functional),
-- whereas below it is of type `Lexer s t'.  Thus, below we have a graphical
-- body (finite representation of an infinite structure), which doesn't grow
-- with the size of the accepted lexeme - in contrast to the definition using
-- the functional recursion.
 
star re1 re2  = \l -> let self = re1 self >||< re2 l in self
 
-- x `plus` y corresponds to the regular expression x+y
plus re1 re2  = re1 +> (re1 `star` re2)
 
-- x `quest` y corresponds to the regular expression x?y
quest re1 re2  = (re1 +> re2) >|< re2
 
-- accepts a non-empty set of alternative characters
--  Equiv. to `(foldr1 (>|<) . map char) cs', but much faster
alt cs  = \l -> let bnds = B (length cs) (minimum cs) (maximum cs)
                in Lexer NoAction (aggregate bnds [(c, l) | c <- cs])
 
-- accept a character sequence
string cs = (foldr1 (+>) . map char) cs
 
-- apply a lexer, yielding a token sequence and a list of errors
--
-- * Currently, all errors are fatal; thus, the result is undefined in case of 
--   an error (this changes when error correction is added).
-- * The final lexer state is returned.
-- * The order of the error messages is undefined.
-- * the following is moderately tuned
--
execLexer _ st@(LS [] _) = ([], st)
execLexer l st = case lexOne l st of
    (Nothing , _ , st') -> execLexer l st'
    (Just t, l', st')   -> let (ts, final) = execLexer l' st' in (t:ts, final)
  where
    -- accept a single lexeme
    lexOne l0 st'@(LS cs s) = oneLexeme l0 st' id lexErr
 
      where
        lexErr = (Just undefined, l, (LS (tail cs) s))
 
        -- we take an open list of characters down, where we accumulate the
        -- lexeme; this function returns maybe a token, the next lexer to use
        -- (can be altered by a meta action), the new lexer state, and a list
        -- of errors
        --
        -- we implement the "principle of the longest match" by taking a
        -- potential result quadruple down (in the last argument); the
        -- potential result quadruple is updated whenever we pass by an action 
        -- (different from `NoAction'); initially it is an error result
        --
        oneLexeme (Lexer a cont) state@(LS cs s) csDL last =
            let last' = doaction a csDL state last
            in case cs of
                []      -> last'    -- at end, has to be this action
                (c:cs') -> oneChar cont c (LS cs' s) csDL last'   -- keep looking
 
        -- There are more chars. Look at the next one
        -- Now, if the next tbl is Done, then there is no more
        -- transition, so immediately execute our action
        oneChar tbl c state csDL last = case peek tbl c of
                Nothing              -> last
                Just (Lexer a Done)  -> doaction a (\l -> csDL (c:l)) state last
                Just l'              -> oneLexeme l' state (\l -> csDL (c:l)) last
 
        -- Do the lookup.
        peek (Dense bn arr)  c | c `inBounds` bn = Just $ arr ! c
        peek (Sparse bn cls) c | c `inBounds` bn = lookup c cls
        peek _ _    = Nothing
 
        -- execute the action if present and finalise the current lexeme
        doaction (Action f) csDL (LS cs s) _ = case f (($[]) csDL) s of
                (R Nothing s' l') | not . null $ cs -> lexOne (fromMaybe l0 l') (LS cs s')
                (R res     s' l')  -> (res, (fromMaybe l0 l'), (LS cs s'))
 
        doaction NoAction _ _ last = last

-- By Chris Kuklewicz, using Pattern idea from Alson
-- Add this code block to parse normal string regexp to (Regexp Char)
-- This code has not been space optimized, and need not be speed optimized
 
import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec ((<|>),GenParser)
import Control.Monad (liftM,liftM2)
 
-- The exported function from this code block
 
convert :: String -> Regexp Char
convert = reflect . parseRegex
 
-- The string regexp format, exported from this code block
 
variants = 
  ["agggtaaa|tttaccct","[cgt]gggtaaa|tttaccc[acg]","a[act]ggtaaa|tttacc[agt]t"
  ,"ag[act]gtaaa|tttac[agt]ct","agg[act]taaa|ttta[agt]cct","aggg[acg]aaa|ttt[cgt]ccct"
  ,"agggt[cgt]aa|tt[acg]accct","agggta[cgt]a|t[acg]taccct","agggtaa[cgt]|[acg]ttaccct"]
 
-- Make Regexp Char from Pattern
 
reflect :: Pattern -> Regexp Char
reflect PEnd         = epsilon
reflect (POr ps)     = foldl1 (>|<) (map reflect ps)
reflect (PConcat ps) = stitch ps
reflect (PQuest p)   = reflect p `quest` epsilon
reflect (PPlus p)    = reflect p `plus` epsilon
reflect (PStar p)    = reflect p `star` epsilon
reflect (PAny set)   = alt set
reflect (PAny' _)    = error "There is no [^abc] support"
reflect (PChar c)    = char c
reflect (PDot)       = error "There is no . support in Lexer"
reflect (PString s)  = string s
 
-- Help reflect (PConcat ps)
stitch :: [Pattern] -> Regexp Char
stitch []              = epsilon
stitch (x:[])          = reflect x
stitch ((PQuest p):xs) = reflect p `quest` stitch xs
stitch ((PPlus p) :xs) = reflect p `plus`  stitch xs
stitch ((PStar p) :xs) = reflect p `star`  stitch xs
stitch (x:xs) = (reflect x) +> stitch xs
 
-- Make p_regex to parse strings to Pattern
 
parseRegex = simplify.(either (error.show) id).(\x -> P.parse p_regex x x)
 
-- tr was for debugging
--tr = (\result -> do unsafePerformIO (print result >> return (return result)))
tr = return
 
p_regex = liftM POr (P.sepBy1 p_branch (P.char '|')) >>= tr
 
p_branch = liftM PConcat (P.many1 p_piece) >>= tr
 
p_piece = p_atom >>= p_post_atom >>= tr
 
p_atom = P.try (P.string "()" >> return PEnd)      -- must not consume '(' yet
         <|> P.between (P.char '(') (P.char ')') p_regex
         <|> p_bracket
         <|> p_dot
--         <|> p_caret
--         <|> p_dollar
         <|> p_escaped_char
         <|> p_other_char
--         <|> unsafePerformIO (print "no atom" >> return pzero)
 
-- p_post_atom takes the previous atom as a parameter
p_post_atom PEnd = return PEnd
p_post_atom atom = (P.char '?' >> return (PQuest atom))
                   <|> (P.char '+' >> return (PPlus atom))
                   <|> (P.char '*' >> return (PStar atom))
                   -- no {n,m} for p_bound yet
                   <|> (return atom)
 
p_bracket = (P.char '[') >> ( (P.char '^' >> p_set True) <|> (p_set False) ) >>= tr
 
-- p_set does not support [.ch.] or [=y=] or [:foo:]
p_set :: Bool -> GenParser Char st Pattern
p_set invert = do initial <- (P.option "" ((P.char ']' >> return "]") <|> (P.char '-' >> return "-")))
                  middle <- P.manyTill P.anyChar (P.char ']')
                  let expand [] = []
                      expand ('-':[]) = "-"
                      expand (a:'-':b:rest) | a /= '-' = (enumFromTo a b)++(expand rest)
                      expand (x:xs) | x /= '-'  = x:(expand xs)
                                    | otherwise = error "A dash is in the wrong place in a p_set"
                      characters = nub ( sort (initial ++ (expand middle)))
                      result = if invert then PAny' characters 
                                         else PAny characters
                  return result
 
p_dot = P.char '.' >> return PDot
 
p_escaped_char = P.char '\\' >> liftM PChar P.anyChar
 
p_other_char = liftM PChar (P.noneOf specials)
  where specials  = "^.[$()|*+?\\"  -- full set is "^.[$()|*+?{\\" but no '{' yet for bounds
 
notPEnd = filter (/=PEnd)
 
simplify x =
  case x of
    POr ps -> case notPEnd (map simplify ps) of
                [] -> PEnd
                [p] -> p
                ps' -> POr ps'
    PConcat ps -> case merge (notPEnd (map simplify ps)) of
                    [] -> PEnd
                    [p] -> p
                    ps' -> PConcat ps'
    PQuest p -> case (simplify p) of PEnd -> PEnd; p' -> PQuest p'
    PPlus p -> case (simplify p) of PEnd -> PEnd; p' -> PPlus p'
    PStar p -> case (simplify p) of PEnd -> PEnd; p' -> PStar p'
    x -> x
 
-- merge helps simplify PConcat
merge ((PChar c1):(PChar c2):xs) = merge $ (PString [c1,c2]):xs
merge ((PString s):(PChar c):xs) = merge $ (PString (s++[c])):xs
merge (x:xs) = x:merge xs
merge [] = []